From 6aa0e0017d7d0cddc006da885946934b06949a91 Mon Sep 17 00:00:00 2001 From: Robin Haberkorn Date: Fri, 14 Oct 2011 04:55:05 +0200 Subject: include libslang-1.4.9 and automatically build it and link erlang-slang against it few (erlang) people will still have libslang-1.4.9 installed or spend time to get it to link against the driver --- Makefile | 18 +- c_src/Makefile | 13 +- libslang/COPYING | 30 + libslang/COPYING.ART | 129 + libslang/COPYING.GPL | 340 ++ libslang/COPYRIGHT | 16 + libslang/INSTALL.pc | 8 + libslang/INSTALL.unx | 258 ++ libslang/INSTALL.vms | 10 + libslang/NEWS | 21 + libslang/README | 21 + libslang/UPGRADE.txt | 295 ++ libslang/autoconf/Makefile.in | 37 + libslang/autoconf/aclocal.m4 | 621 ++++ libslang/autoconf/config.guess | 1321 ++++++++ libslang/autoconf/config.sub | 1443 +++++++++ libslang/autoconf/configure.in | 146 + libslang/autoconf/install.sh | 251 ++ libslang/autoconf/mkinsdir.sh | 32 + libslang/changes.txt | 1505 +++++++++ libslang/configure | 2997 ++++++++++++++++++ libslang/demo/Makefile.in | 66 + libslang/demo/Makefile.w32 | 5 + libslang/demo/README | 43 + libslang/demo/configure | 1597 ++++++++++ libslang/demo/configure.in | 51 + libslang/demo/demolib.c | 96 + libslang/demo/keypad.c | 52 + libslang/demo/modules.unx | 4 + libslang/demo/pager.c | 280 ++ libslang/demo/smgtest.c | 799 +++++ libslang/demo/useropen.c | 119 + libslang/doc/OLD/help/README | 3 + libslang/doc/OLD/help/makefile.djg | 18 + libslang/doc/OLD/help/makefile.os2 | 70 + libslang/doc/OLD/help/makefile.unx | 8 + libslang/doc/OLD/help/slang.hlp | 241 ++ libslang/doc/OLD/help/slhelp.c | 587 ++++ libslang/doc/README | 25 + libslang/doc/grammar.txt | 131 + libslang/doc/internal/rpn.txt | 60 + libslang/doc/slangdoc.html | 27 + libslang/doc/text/cref.txt | 4870 +++++++++++++++++++++++++++++ libslang/doc/text/cslang.txt | 2989 ++++++++++++++++++ libslang/doc/text/slang.txt | 5642 +++++++++++++++++++++++++++++++++ libslang/doc/text/slangfun.txt | 5943 +++++++++++++++++++++++++++++++++++ libslang/doc/tm/Makefile | 100 + libslang/doc/tm/copyright.tm | 476 +++ libslang/doc/tm/cref.tm | 3430 +++++++++++++++++++++ libslang/doc/tm/cslang.tm | 2033 ++++++++++++ libslang/doc/tm/fixtex.sl | 56 + libslang/doc/tm/preface.tm | 95 + libslang/doc/tm/regexp.tm | 98 + libslang/doc/tm/rtl/array.tm | 378 +++ libslang/doc/tm/rtl/assoc.tm | 76 + libslang/doc/tm/rtl/bstr.tm | 151 + libslang/doc/tm/rtl/debug.tm | 98 + libslang/doc/tm/rtl/dir.tm | 223 ++ libslang/doc/tm/rtl/eval.tm | 119 + libslang/doc/tm/rtl/import.tm | 51 + libslang/doc/tm/rtl/info.tm | 202 ++ libslang/doc/tm/rtl/math.tm | 291 ++ libslang/doc/tm/rtl/message.tm | 111 + libslang/doc/tm/rtl/misc.tm | 201 ++ libslang/doc/tm/rtl/ospath.tm | 77 + libslang/doc/tm/rtl/posio.tm | 154 + libslang/doc/tm/rtl/posix.tm | 285 ++ libslang/doc/tm/rtl/stack.tm | 165 + libslang/doc/tm/rtl/stdio.tm | 421 +++ libslang/doc/tm/rtl/strops.tm | 736 +++++ libslang/doc/tm/rtl/struct.tm | 104 + libslang/doc/tm/rtl/time.tm | 137 + libslang/doc/tm/rtl/tm-sort.sl | 153 + libslang/doc/tm/rtl/type.tm | 245 ++ libslang/doc/tm/rtl/whatelse.sl | 116 + libslang/doc/tm/slang.tm | 4077 ++++++++++++++++++++++++ libslang/doc/tm/slangfun.tm | 121 + libslang/doc/tm/tools/Makefile | 46 + libslang/doc/tm/tools/README | 67 + libslang/doc/tm/tools/sl2tm.c | 216 ++ libslang/doc/tm/tools/tm2txt.c | 726 +++++ libslang/examples/assoc.sl | 46 + libslang/examples/life.sl | 131 + libslang/examples/prime.sl | 46 + libslang/examples/saveobj.sl | 630 ++++ libslang/examples/sort.sl | 62 + libslang/examples/utmp.sl | 67 + libslang/modules/Makefile.in | 56 + libslang/modules/README | 66 + libslang/modules/fcntl-module.c | 117 + libslang/modules/grep | 171 + libslang/modules/newt-module.c | 91 + libslang/modules/newt.sl | 14 + libslang/modules/pcre-module.c | 618 ++++ libslang/modules/select-module.c | 238 ++ libslang/modules/smg-module.c | 324 ++ libslang/modules/smg.sl | 70 + libslang/modules/template.c | 49 + libslang/modules/termios-module.c | 440 +++ libslang/modules/varray-module.c | 224 ++ libslang/modules/varray.sl | 37 + libslang/slang.lis | 267 ++ libslang/slsh/INSTALL | 26 + libslang/slsh/Makefile.g32 | 36 + libslang/slsh/Makefile.in | 74 + libslang/slsh/README | 43 + libslang/slsh/lib/arrayfuns.sl | 50 + libslang/slsh/lib/autoload.sl | 4 + libslang/slsh/lib/require.sl | 82 + libslang/slsh/lib/slsh.rc | 46 + libslang/slsh/scripts/badlinks | 78 + libslang/slsh/scripts/htmlstrip | 48 + libslang/slsh/scripts/ls | 333 ++ libslang/slsh/scripts/lsrpm | 85 + libslang/slsh/scripts/mv | 143 + libslang/slsh/scripts/purge | 65 + libslang/slsh/slsh.c | 481 +++ libslang/src/DESCRIP.MMS | 41 + libslang/src/Makefile.in | 214 ++ libslang/src/VMSMAKE.COM | 119 + libslang/src/_slang.h | 867 ++++++ libslang/src/calc.c | 225 ++ libslang/src/calc.sl | 374 +++ libslang/src/config.hin | 165 + libslang/src/curses/Makefile | 51 + libslang/src/curses/README | 11 + libslang/src/curses/battle.c | 710 +++++ libslang/src/curses/blue.c | 415 +++ libslang/src/curses/bs.c | 1253 ++++++++ libslang/src/curses/firework.c | 123 + libslang/src/curses/gdc.c | 212 ++ libslang/src/curses/hanoi.c | 292 ++ libslang/src/curses/knight.c | 555 ++++ libslang/src/curses/rain.c | 97 + libslang/src/curses/tclock.c | 177 ++ libslang/src/curses/view.c | 143 + libslang/src/curses/worm.c | 361 +++ libslang/src/jdmacros.h | 53 + libslang/src/keywhash.c | 190 ++ libslang/src/mkfiles/README | 28 + libslang/src/mkfiles/makefile.all | 620 ++++ libslang/src/mkfiles/mkmake.c | 41 + libslang/src/mkfiles/mkmake.exe | Bin 0 -> 11914 bytes libslang/src/modules.unx | 55 + libslang/src/pcconf.c | 92 + libslang/src/sl-feat.h | 61 + libslang/src/slang.c | 5998 ++++++++++++++++++++++++++++++++++++ libslang/src/slang.h | 2034 ++++++++++++ libslang/src/slarith.c | 1752 +++++++++++ libslang/src/slarith.inc | 784 +++++ libslang/src/slarray.c | 3306 ++++++++++++++++++++ libslang/src/slarrfun.c | 956 ++++++ libslang/src/slarrfun.inc | 370 +++ libslang/src/slarrmis.c | 38 + libslang/src/slassoc.c | 732 +++++ libslang/src/slbstr.c | 614 ++++ libslang/src/slclass.c | 1418 +++++++++ libslang/src/slcmd.c | 351 +++ libslang/src/slcmplex.c | 1142 +++++++ libslang/src/slcompat.c | 34 + libslang/src/slconfig.h | 239 ++ libslang/src/slcurses.c | 1021 ++++++ libslang/src/slcurses.h | 356 +++ libslang/src/sldisply.c | 2699 ++++++++++++++++ libslang/src/sldostty.c | 519 ++++ libslang/src/slerr.c | 181 ++ libslang/src/slerrno.c | 219 ++ libslang/src/slfile.c | 24 + libslang/src/slgetkey.c | 306 ++ libslang/src/slimport.c | 314 ++ libslang/src/slinclud.h | 30 + libslang/src/slintall.c | 29 + libslang/src/slistruc.c | 224 ++ libslang/src/slkeymap.c | 595 ++++ libslang/src/slkeypad.c | 182 ++ libslang/src/sllimits.h | 73 + libslang/src/slmalloc.c | 165 + libslang/src/slmath.c | 570 ++++ libslang/src/slmemchr.c | 47 + libslang/src/slmemcmp.c | 76 + libslang/src/slmemcpy.c | 49 + libslang/src/slmemset.c | 39 + libslang/src/slmisc.c | 605 ++++ libslang/src/slnspace.c | 294 ++ libslang/src/slos2tty.c | 288 ++ libslang/src/slospath.c | 227 ++ libslang/src/slpack.c | 785 +++++ libslang/src/slparse.c | 1970 ++++++++++++ libslang/src/slpath.c | 398 +++ libslang/src/slposdir.c | 1059 +++++++ libslang/src/slposio.c | 568 ++++ libslang/src/slprepr.c | 569 ++++ libslang/src/slproc.c | 155 + libslang/src/slqsort.c | 257 ++ libslang/src/slregexp.c | 937 ++++++ libslang/src/slrline.c | 836 +++++ libslang/src/slscanf.c | 712 +++++ libslang/src/slscroll.c | 450 +++ libslang/src/slsearch.c | 239 ++ libslang/src/slsignal.c | 336 ++ libslang/src/slsmg.c | 1579 ++++++++++ libslang/src/slstd.c | 809 +++++ libslang/src/slstdio.c | 1071 +++++++ libslang/src/slstring.c | 548 ++++ libslang/src/slstrops.c | 1690 ++++++++++ libslang/src/slstruct.c | 1112 +++++++ libslang/src/sltermin.c | 1178 +++++++ libslang/src/sltime.c | 305 ++ libslang/src/sltoken.c | 1533 +++++++++ libslang/src/sltypes.c | 1007 ++++++ libslang/src/slutty.c | 604 ++++ libslang/src/slvideo.c | 2337 ++++++++++++++ libslang/src/slvmstty.c | 382 +++ libslang/src/slw32tty.c | 354 +++ libslang/src/slxstrng.c | 43 + libslang/src/test/Makefile | 22 + libslang/src/test/README | 2 + libslang/src/test/anytype.sl | 63 + libslang/src/test/arith.sl | 201 ++ libslang/src/test/array.sl | 704 +++++ libslang/src/test/arrmult.sl | 163 + libslang/src/test/assoc.sl | 135 + libslang/src/test/bstring.sl | 32 + libslang/src/test/ifeval.sl | 404 +++ libslang/src/test/inc.sl | 15 + libslang/src/test/loops.sl | 130 + libslang/src/test/ns1.inc | 6 + libslang/src/test/ns2.inc | 6 + libslang/src/test/nspace.sl | 93 + libslang/src/test/nspace2.sl | 70 + libslang/src/test/ospath.sl | 42 + libslang/src/test/pack.sl | 107 + libslang/src/test/posixio.sl | 93 + libslang/src/test/prep.sl | 25 + libslang/src/test/selfload.sl | 42 + libslang/src/test/sltest.c | 182 ++ libslang/src/test/sscanf.sl | 182 ++ libslang/src/test/stdio.sl | 180 ++ libslang/src/test/strops.sl | 153 + libslang/src/test/struct.sl | 144 + libslang/src/test/syntax.sl | 142 + libslang/src/test/template.sl | 10 + libslang/src/untic.c | 90 + libslang/src/util/bcdump.c | 457 +++ libslang/src/util/chkproto.c | 225 ++ libslang/src/util/keywords.lis | 73 + libslang/src/util/perfhash.c | 600 ++++ 247 files changed, 119684 insertions(+), 8 deletions(-) create mode 100644 libslang/COPYING create mode 100644 libslang/COPYING.ART create mode 100644 libslang/COPYING.GPL create mode 100644 libslang/COPYRIGHT create mode 100644 libslang/INSTALL.pc create mode 100644 libslang/INSTALL.unx create mode 100644 libslang/INSTALL.vms create mode 100644 libslang/NEWS create mode 100644 libslang/README create mode 100644 libslang/UPGRADE.txt create mode 100644 libslang/autoconf/Makefile.in create mode 100644 libslang/autoconf/aclocal.m4 create mode 100755 libslang/autoconf/config.guess create mode 100755 libslang/autoconf/config.sub create mode 100644 libslang/autoconf/configure.in create mode 100755 libslang/autoconf/install.sh create mode 100755 libslang/autoconf/mkinsdir.sh create mode 100644 libslang/changes.txt create mode 100755 libslang/configure create mode 100644 libslang/demo/Makefile.in create mode 100644 libslang/demo/Makefile.w32 create mode 100644 libslang/demo/README create mode 100755 libslang/demo/configure create mode 100644 libslang/demo/configure.in create mode 100644 libslang/demo/demolib.c create mode 100644 libslang/demo/keypad.c create mode 100644 libslang/demo/modules.unx create mode 100644 libslang/demo/pager.c create mode 100644 libslang/demo/smgtest.c create mode 100644 libslang/demo/useropen.c create mode 100644 libslang/doc/OLD/help/README create mode 100644 libslang/doc/OLD/help/makefile.djg create mode 100644 libslang/doc/OLD/help/makefile.os2 create mode 100644 libslang/doc/OLD/help/makefile.unx create mode 100644 libslang/doc/OLD/help/slang.hlp create mode 100644 libslang/doc/OLD/help/slhelp.c create mode 100644 libslang/doc/README create mode 100644 libslang/doc/grammar.txt create mode 100644 libslang/doc/internal/rpn.txt create mode 100644 libslang/doc/slangdoc.html create mode 100644 libslang/doc/text/cref.txt create mode 100644 libslang/doc/text/cslang.txt create mode 100644 libslang/doc/text/slang.txt create mode 100644 libslang/doc/text/slangfun.txt create mode 100644 libslang/doc/tm/Makefile create mode 100644 libslang/doc/tm/copyright.tm create mode 100644 libslang/doc/tm/cref.tm create mode 100644 libslang/doc/tm/cslang.tm create mode 100644 libslang/doc/tm/fixtex.sl create mode 100644 libslang/doc/tm/preface.tm create mode 100644 libslang/doc/tm/regexp.tm create mode 100644 libslang/doc/tm/rtl/array.tm create mode 100644 libslang/doc/tm/rtl/assoc.tm create mode 100644 libslang/doc/tm/rtl/bstr.tm create mode 100644 libslang/doc/tm/rtl/debug.tm create mode 100644 libslang/doc/tm/rtl/dir.tm create mode 100644 libslang/doc/tm/rtl/eval.tm create mode 100644 libslang/doc/tm/rtl/import.tm create mode 100644 libslang/doc/tm/rtl/info.tm create mode 100644 libslang/doc/tm/rtl/math.tm create mode 100644 libslang/doc/tm/rtl/message.tm create mode 100644 libslang/doc/tm/rtl/misc.tm create mode 100644 libslang/doc/tm/rtl/ospath.tm create mode 100644 libslang/doc/tm/rtl/posio.tm create mode 100644 libslang/doc/tm/rtl/posix.tm create mode 100644 libslang/doc/tm/rtl/stack.tm create mode 100644 libslang/doc/tm/rtl/stdio.tm create mode 100644 libslang/doc/tm/rtl/strops.tm create mode 100644 libslang/doc/tm/rtl/struct.tm create mode 100644 libslang/doc/tm/rtl/time.tm create mode 100755 libslang/doc/tm/rtl/tm-sort.sl create mode 100644 libslang/doc/tm/rtl/type.tm create mode 100755 libslang/doc/tm/rtl/whatelse.sl create mode 100644 libslang/doc/tm/slang.tm create mode 100644 libslang/doc/tm/slangfun.tm create mode 100644 libslang/doc/tm/tools/Makefile create mode 100644 libslang/doc/tm/tools/README create mode 100644 libslang/doc/tm/tools/sl2tm.c create mode 100644 libslang/doc/tm/tools/tm2txt.c create mode 100644 libslang/examples/assoc.sl create mode 100644 libslang/examples/life.sl create mode 100644 libslang/examples/prime.sl create mode 100644 libslang/examples/saveobj.sl create mode 100644 libslang/examples/sort.sl create mode 100644 libslang/examples/utmp.sl create mode 100644 libslang/modules/Makefile.in create mode 100644 libslang/modules/README create mode 100644 libslang/modules/fcntl-module.c create mode 100755 libslang/modules/grep create mode 100644 libslang/modules/newt-module.c create mode 100644 libslang/modules/newt.sl create mode 100644 libslang/modules/pcre-module.c create mode 100644 libslang/modules/select-module.c create mode 100644 libslang/modules/smg-module.c create mode 100644 libslang/modules/smg.sl create mode 100644 libslang/modules/template.c create mode 100644 libslang/modules/termios-module.c create mode 100644 libslang/modules/varray-module.c create mode 100644 libslang/modules/varray.sl create mode 100644 libslang/slang.lis create mode 100644 libslang/slsh/INSTALL create mode 100644 libslang/slsh/Makefile.g32 create mode 100644 libslang/slsh/Makefile.in create mode 100644 libslang/slsh/README create mode 100644 libslang/slsh/lib/arrayfuns.sl create mode 100644 libslang/slsh/lib/autoload.sl create mode 100644 libslang/slsh/lib/require.sl create mode 100644 libslang/slsh/lib/slsh.rc create mode 100755 libslang/slsh/scripts/badlinks create mode 100755 libslang/slsh/scripts/htmlstrip create mode 100755 libslang/slsh/scripts/ls create mode 100755 libslang/slsh/scripts/lsrpm create mode 100755 libslang/slsh/scripts/mv create mode 100755 libslang/slsh/scripts/purge create mode 100644 libslang/slsh/slsh.c create mode 100644 libslang/src/DESCRIP.MMS create mode 100644 libslang/src/Makefile.in create mode 100644 libslang/src/VMSMAKE.COM create mode 100644 libslang/src/_slang.h create mode 100644 libslang/src/calc.c create mode 100644 libslang/src/calc.sl create mode 100644 libslang/src/config.hin create mode 100644 libslang/src/curses/Makefile create mode 100644 libslang/src/curses/README create mode 100644 libslang/src/curses/battle.c create mode 100644 libslang/src/curses/blue.c create mode 100644 libslang/src/curses/bs.c create mode 100644 libslang/src/curses/firework.c create mode 100644 libslang/src/curses/gdc.c create mode 100644 libslang/src/curses/hanoi.c create mode 100644 libslang/src/curses/knight.c create mode 100644 libslang/src/curses/rain.c create mode 100644 libslang/src/curses/tclock.c create mode 100644 libslang/src/curses/view.c create mode 100644 libslang/src/curses/worm.c create mode 100644 libslang/src/jdmacros.h create mode 100644 libslang/src/keywhash.c create mode 100644 libslang/src/mkfiles/README create mode 100644 libslang/src/mkfiles/makefile.all create mode 100644 libslang/src/mkfiles/mkmake.c create mode 100644 libslang/src/mkfiles/mkmake.exe create mode 100644 libslang/src/modules.unx create mode 100644 libslang/src/pcconf.c create mode 100644 libslang/src/sl-feat.h create mode 100644 libslang/src/slang.c create mode 100644 libslang/src/slang.h create mode 100644 libslang/src/slarith.c create mode 100644 libslang/src/slarith.inc create mode 100644 libslang/src/slarray.c create mode 100644 libslang/src/slarrfun.c create mode 100644 libslang/src/slarrfun.inc create mode 100644 libslang/src/slarrmis.c create mode 100644 libslang/src/slassoc.c create mode 100644 libslang/src/slbstr.c create mode 100644 libslang/src/slclass.c create mode 100644 libslang/src/slcmd.c create mode 100644 libslang/src/slcmplex.c create mode 100644 libslang/src/slcompat.c create mode 100644 libslang/src/slconfig.h create mode 100644 libslang/src/slcurses.c create mode 100644 libslang/src/slcurses.h create mode 100644 libslang/src/sldisply.c create mode 100644 libslang/src/sldostty.c create mode 100644 libslang/src/slerr.c create mode 100644 libslang/src/slerrno.c create mode 100644 libslang/src/slfile.c create mode 100644 libslang/src/slgetkey.c create mode 100644 libslang/src/slimport.c create mode 100644 libslang/src/slinclud.h create mode 100644 libslang/src/slintall.c create mode 100644 libslang/src/slistruc.c create mode 100644 libslang/src/slkeymap.c create mode 100644 libslang/src/slkeypad.c create mode 100644 libslang/src/sllimits.h create mode 100644 libslang/src/slmalloc.c create mode 100644 libslang/src/slmath.c create mode 100644 libslang/src/slmemchr.c create mode 100644 libslang/src/slmemcmp.c create mode 100644 libslang/src/slmemcpy.c create mode 100644 libslang/src/slmemset.c create mode 100644 libslang/src/slmisc.c create mode 100644 libslang/src/slnspace.c create mode 100644 libslang/src/slos2tty.c create mode 100644 libslang/src/slospath.c create mode 100644 libslang/src/slpack.c create mode 100644 libslang/src/slparse.c create mode 100644 libslang/src/slpath.c create mode 100644 libslang/src/slposdir.c create mode 100644 libslang/src/slposio.c create mode 100644 libslang/src/slprepr.c create mode 100644 libslang/src/slproc.c create mode 100644 libslang/src/slqsort.c create mode 100644 libslang/src/slregexp.c create mode 100644 libslang/src/slrline.c create mode 100644 libslang/src/slscanf.c create mode 100644 libslang/src/slscroll.c create mode 100644 libslang/src/slsearch.c create mode 100644 libslang/src/slsignal.c create mode 100644 libslang/src/slsmg.c create mode 100644 libslang/src/slstd.c create mode 100644 libslang/src/slstdio.c create mode 100644 libslang/src/slstring.c create mode 100644 libslang/src/slstrops.c create mode 100644 libslang/src/slstruct.c create mode 100644 libslang/src/sltermin.c create mode 100644 libslang/src/sltime.c create mode 100644 libslang/src/sltoken.c create mode 100644 libslang/src/sltypes.c create mode 100644 libslang/src/slutty.c create mode 100644 libslang/src/slvideo.c create mode 100644 libslang/src/slvmstty.c create mode 100644 libslang/src/slw32tty.c create mode 100644 libslang/src/slxstrng.c create mode 100644 libslang/src/test/Makefile create mode 100644 libslang/src/test/README create mode 100644 libslang/src/test/anytype.sl create mode 100644 libslang/src/test/arith.sl create mode 100644 libslang/src/test/array.sl create mode 100644 libslang/src/test/arrmult.sl create mode 100644 libslang/src/test/assoc.sl create mode 100644 libslang/src/test/bstring.sl create mode 100644 libslang/src/test/ifeval.sl create mode 100644 libslang/src/test/inc.sl create mode 100644 libslang/src/test/loops.sl create mode 100644 libslang/src/test/ns1.inc create mode 100644 libslang/src/test/ns2.inc create mode 100644 libslang/src/test/nspace.sl create mode 100644 libslang/src/test/nspace2.sl create mode 100644 libslang/src/test/ospath.sl create mode 100644 libslang/src/test/pack.sl create mode 100644 libslang/src/test/posixio.sl create mode 100644 libslang/src/test/prep.sl create mode 100644 libslang/src/test/selfload.sl create mode 100644 libslang/src/test/sltest.c create mode 100644 libslang/src/test/sscanf.sl create mode 100644 libslang/src/test/stdio.sl create mode 100644 libslang/src/test/strops.sl create mode 100644 libslang/src/test/struct.sl create mode 100644 libslang/src/test/syntax.sl create mode 100644 libslang/src/test/template.sl create mode 100644 libslang/src/untic.c create mode 100644 libslang/src/util/bcdump.c create mode 100644 libslang/src/util/chkproto.c create mode 100644 libslang/src/util/keywords.lis create mode 100644 libslang/src/util/perfhash.c diff --git a/Makefile b/Makefile index 233e742..0515444 100644 --- a/Makefile +++ b/Makefile @@ -6,7 +6,10 @@ export CFLAGS ?= -O2 export CPPFLAGS ?= export LDFLAGS ?= -all: +CONFIGURE_VARS := + +all : libslang/Makefile + $(MAKE) -C libslang $@ $(MAKE) -C c_src $@ $(ERL) -noinput -eval \ "case make:all() of up_to_date -> halt(0); error -> halt(1) end" @@ -14,6 +17,15 @@ all: install: $(MAKE) -C c_src $@ -clean: +clean : libslang/Makefile + $(MAKE) -C libslang $@ + $(RM) -f libslang/Makefile $(MAKE) -C c_src $@ - $(RM) -f {ebin,demo}/*.beam + $(RM) -f ebin/*.beam demo/*.beam + +libslang/Makefile : libslang/configure + ( \ + cd libslang; \ + CFLAGS="$(CFLAGS) -fpic" \ + ./configure $(CONFIGURE_ARGS) \ + ) diff --git a/c_src/Makefile b/c_src/Makefile index 8666699..ec53e71 100644 --- a/c_src/Makefile +++ b/c_src/Makefile @@ -1,14 +1,17 @@ -LIBS := -lslang +PRIV := ../priv +LIBSLANG := ../libslang +LIBS := $(LIBSLANG)/src/objs/libslang.a + ERL_CPPFLAGS := $(shell erl -noinput -eval \ 'io:format("-I~s/erts-~s/include", [code:root_dir(), erlang:system_info(version)]), halt(0)') override CFLAGS += -Wall -fpic -override CPPFLAGS += $(ERL_CPPFLAGS) +override CPPFLAGS += -I$(LIBSLANG)/src $(ERL_CPPFLAGS) -all : ../priv/slang_drv.so +all : $(PRIV)/slang_drv.so -../priv/slang_drv.so : slang_drv.o +$(PRIV)/slang_drv.so : slang_drv.o $(CC) -shared $(LDFLAGS) -o $@ $^ $(LIBS) clean: - $(RM) -f *.o ../priv/slang_drv.so + $(RM) -f *.o $(PRIV)/slang_drv.so diff --git a/libslang/COPYING b/libslang/COPYING new file mode 100644 index 0000000..681d0e3 --- /dev/null +++ b/libslang/COPYING @@ -0,0 +1,30 @@ +S-Lang is not public domain software --- it is copyrighted. However, +it may be used for any purpose without royalty or fees in accordance +with the terms of the copyright. + +It may distributed under either the GNU General public license or under the +Perl ``Artistic'' License. See COPYING.GPL and COPYING.ART for more details. +----------------------------------------------------------------------------- + Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + + You may distribute under the terms of either the GNU General Public + License or the Perl Artistic License. + + IN NO EVENT SHALL JOHN E. DAVIS BE LIABLE TO ANY PARTY FOR DIRECT, + INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF + THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF JOHN E. DAVIS + HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + JOHN E. DAVIS SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" + BASIS, AND JOHN E. DAVIS HAS NO OBLIGATION TO PROVIDE MAINTENANCE, + SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. +----------------------------------------------------------------------------- + + + + + + + diff --git a/libslang/COPYING.ART b/libslang/COPYING.ART new file mode 100644 index 0000000..c9465d4 --- /dev/null +++ b/libslang/COPYING.ART @@ -0,0 +1,129 @@ + + The "Artistic License" + + Preamble + +The intent of this document is to state the conditions under which a +Package may be copied, such that the Copyright Holder maintains some +semblance of artistic control over the development of the package, +while giving the users of the package the right to use and distribute +the Package in a more-or-less customary fashion, plus the right to make +reasonable modifications. + +Definitions: + + "Package" refers to the collection of files distributed by the + Copyright Holder, and derivatives of that collection of files + created through textual modification. + + "Standard Version" refers to such a Package if it has not been + modified, or has been modified in accordance with the wishes + of the Copyright Holder as specified below. + + "Copyright Holder" is whoever is named in the copyright or + copyrights for the package. + + "You" is you, if you're thinking about copying or distributing + this Package. + + "Reasonable copying fee" is whatever you can justify on the + basis of media cost, duplication charges, time of people involved, + and so on. (You will not be required to justify it to the + Copyright Holder, but only to the computing community at large + as a market that must bear the fee.) + + "Freely Available" means that no fee is charged for the item + itself, though there may be fees involved in handling the item. + It also means that recipients of the item may redistribute it + under the same conditions they received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications +derived from the Public Domain or from the Copyright Holder. A Package +modified in such a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided +that you insert a prominent notice in each changed file stating how and +when you changed that file, and provided that you do at least ONE of the +following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or + an equivalent medium, or placing the modifications on a major archive + site such as uunet.uu.net, or by allowing the Copyright Holder to include + your modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and provide + a separate manual page for each non-standard executable that clearly + documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or +executable form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where + to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), together + with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this +Package. You may not charge a fee for this Package itself. However, +you may distribute this Package in aggregate with other (possibly +commercial) programs as part of a larger (possibly commercial) software +distribution provided that you do not advertise this Package as a +product of your own. You may embed this Package's interpreter within +an executable of yours (by linking); this shall be construed as a mere +form of aggregation, provided that the complete Standard Version of the +interpreter is so embedded. + +6. The scripts and library files supplied as input to or produced as +output from the programs of this Package do not automatically fall +under the copyright of this Package, but belong to whomever generated +them, and may be sold commercially, and may be aggregated with this +Package. If such scripts or library files are aggregated with this +Package via the so-called "undump" or "unexec" methods of producing a +binary executable image, then distribution of such an image shall +neither be construed as a distribution of this Package nor shall it +fall under the restrictions of Paragraphs 3 and 4, provided that you do +not represent such an executable image as a Standard Version of this +Package. + +7. C subroutines (or comparably compiled subroutines in other +languages) supplied by you and linked into this Package in order to +emulate subroutines and variables of the language defined by this +Package shall not be considered part of this Package, but are the +equivalent of input as in Paragraph 6, provided these subroutines do +not change the language in any way that would cause it to fail the +regression tests for the language. + +8. Aggregation of this Package with a commercial distribution is always +permitted provided that the use of this Package is embedded; that is, +when no overt attempt is made to make this Package's interfaces visible +to the end user of the commercial distribution. Such use shall not be +construed as a distribution of this Package. + +9. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + + The End + diff --git a/libslang/COPYING.GPL b/libslang/COPYING.GPL new file mode 100644 index 0000000..dc63aac --- /dev/null +++ b/libslang/COPYING.GPL @@ -0,0 +1,340 @@ + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19yy name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/libslang/COPYRIGHT b/libslang/COPYRIGHT new file mode 100644 index 0000000..fccd43a --- /dev/null +++ b/libslang/COPYRIGHT @@ -0,0 +1,16 @@ + Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + + You may distribute under the terms of either the GNU General Public + License or the Perl Artistic License. + + IN NO EVENT SHALL JOHN E. DAVIS BE LIABLE TO ANY PARTY FOR DIRECT, + INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF + THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF JOHN E. DAVIS + HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + JOHN E. DAVIS SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" + BASIS, AND JOHN E. DAVIS HAS NO OBLIGATION TO PROVIDE MAINTENANCE, + SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + diff --git a/libslang/INSTALL.pc b/libslang/INSTALL.pc new file mode 100644 index 0000000..61bcf3c --- /dev/null +++ b/libslang/INSTALL.pc @@ -0,0 +1,8 @@ +-*- text -*- + +The slang library is available for OS/2, MSDOS, and WIN32 (windows +9x/NT) systems. This _includes_ the various GNU environments such as +DJGPP, and MING32. For CYGWIN, follow the UNIX instructions. + +There is one master makefile located in src/mkfiles. See the README +file in that directory for more information. diff --git a/libslang/INSTALL.unx b/libslang/INSTALL.unx new file mode 100644 index 0000000..e5f6795 --- /dev/null +++ b/libslang/INSTALL.unx @@ -0,0 +1,258 @@ +Note: You are looking in the wrong place if you intend to compile a unix + version using the MINGW32 or the DJGPP development + environments. As far as the S-Lang library is concerned, these are + do not constitute unix systems. Read INSTALL.pc. + +This distribution contains the slang library, a ``slang-shell'' +program called slsh, and dynamically loadable modules that may be +``imported'' into the interpreter. For installtion of slsh and the +modules, see slsh/README and modules/README. The rest of this +document describes the installation process for the library itself. + +--------------------------------------------------------------------- + +Under UNIX, the S-Lang library makes use of the GNU autoconf package. +The process may be as simple as: + + ./configure + make + make runtests + make install + make clean + +The first two steps: + + ./configure + make + +will place the library in src/objs. The 'runtests' step is designed +to test the interpeter. + + ***Note: If the ARCH environment variable is set, the library will be + placed in src/${ARCH}objs. For example, if ARCH is set to + `sun4', then libslang.a will appear in src/sun4objs. + + ***Note: This package does not support the --srcdir command line + option. This option is typically used to compile separate + versions of the library. If your intent is to do something + like: + + mkdir foo; cd foo; ../configure --srcdir=..; make + + then use (csh syntax) + + setenv ARCH foo; ./configure; make + + The reason that --srcdir is not supported is that it fails + in the presence of symbolic links, e.g., + + cd foo; cd .. + + does not bring you back where you started if foo is a + symbolic link. + +Prior to installing libslang.a and slang.h, which is what: + + make install + +does, you may want to edit src/Makefile to specify a destinaton +location. The default installation is to put slang.h in /usr/include +and libslang.a in /usr/lib. + +You may want to edit src/Makefile to specify a source located. The default +installation is to put slang.h in /usr/include and libslang.a in /usr/lib. + +On systems with ELF support, in addition to the above commands, use + + make elf + make install-elf + make install-links + +Do these after "make install" and before "make clean". The command +"install-links" is optional. To find out if you have ELF support, +ask your system administrator. + +Below, I have attached the generic INSTALL instructions included in the +autoconf distribution. +---------------------------------------------------------------------------- +Basic Installation +================== + + These are generic installation instructions. + + The `configure' shell script attempts to guess correct values for +various system-dependent variables used during compilation. It uses +those values to create a `Makefile' in each directory of the package. +It may also create one or more `.h' files containing system-dependent +definitions. Finally, it creates a shell script `config.status' that +you can run in the future to recreate the current configuration, a file +`config.cache' that saves the results of its tests to speed up +reconfiguring, and a file `config.log' containing compiler output +(useful mainly for debugging `configure'). + + If you need to do unusual things to compile the package, please try +to figure out how `configure' could check whether to do them, and mail +diffs or instructions to the address given in the `README' so they can +be considered for the next release. If at some point `config.cache' +contains results you don't want to keep, you may remove or edit it. + + The file `configure.in' is used to create `configure' by a program +called `autoconf'. You only need `configure.in' if you want to change +it or regenerate `configure' using a newer version of `autoconf'. + +The simplest way to compile this package is: + + 1. `cd' to the directory containing the package's source code and type + `./configure' to configure the package for your system. If you're + using `csh' on an old version of System V, you might need to type + `sh ./configure' instead to prevent `csh' from trying to execute + `configure' itself. + + Running `configure' takes awhile. While running, it prints some + messages telling which features it is checking for. + + 2. Type `make' to compile the package. + + 3. Optionally, type `make check' to run any self-tests that come with + the package. + + 4. Type `make install' to install the programs and any data files and + documentation. + + 5. You can remove the program binaries and object files from the + source code directory by typing `make clean'. To also remove the + files that `configure' created (so you can compile the package for + a different kind of computer), type `make distclean'. There is + also a `make maintainer-clean' target, but that is intended mainly + for the package's developers. If you use it, you may have to get + all sorts of other programs in order to regenerate files that came + with the distribution. + +Compilers and Options +===================== + + Some systems require unusual options for compilation or linking that +the `configure' script does not know about. You can give `configure' +initial values for variables by setting them in the environment. Using +a Bourne-compatible shell, you can do that on the command line like +this: + CC=c89 CFLAGS=-O2 LIBS=-lposix ./configure + +Or on systems that have the `env' program, you can do it like this: + env CPPFLAGS=-I/usr/local/include LDFLAGS=-s ./configure + +Compiling For Multiple Architectures +==================================== + + You can compile the package for more than one kind of computer at the +same time, by placing the object files for each architecture in their +own directory. To do this, you must use a version of `make' that +supports the `VPATH' variable, such as GNU `make'. `cd' to the +directory where you want the object files and executables to go and run +the `configure' script. `configure' automatically checks for the +source code in the directory that `configure' is in and in `..'. + + If you have to use a `make' that does not supports the `VPATH' +variable, you have to compile the package for one architecture at a time +in the source code directory. After you have installed the package for +one architecture, use `make distclean' before reconfiguring for another +architecture. + +Installation Names +================== + + By default, `make install' will install the package's files in +`/usr/local/bin', `/usr/local/man', etc. You can specify an +installation prefix other than `/usr/local' by giving `configure' the +option `--prefix=PATH'. + + You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If you +give `configure' the option `--exec-prefix=PATH', the package will use +PATH as the prefix for installing programs and libraries. +Documentation and other data files will still use the regular prefix. + + In addition, if you use an unusual directory layout you can give +options like `--bindir=PATH' to specify different values for particular +kinds of files. Run `configure --help' for a list of the directories +you can set and what kinds of files go in them. + + If the package supports it, you can cause programs to be installed +with an extra prefix or suffix on their names by giving `configure' the +option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. + +Optional Features +================= + + Some packages pay attention to `--enable-FEATURE' options to +`configure', where FEATURE indicates an optional part of the package. +They may also pay attention to `--with-PACKAGE' options, where PACKAGE +is something like `gnu-as' or `x' (for the X Window System). The +`README' should mention any `--enable-' and `--with-' options that the +package recognizes. + + For packages that use the X Window System, `configure' can usually +find the X include and library files automatically, but if it doesn't, +you can use the `configure' options `--x-includes=DIR' and +`--x-libraries=DIR' to specify their locations. + +Specifying the System Type +========================== + + There may be some features `configure' can not figure out +automatically, but needs to determine by the type of host the package +will run on. Usually `configure' can figure that out, but if it prints +a message saying it can not guess the host type, give it the +`--host=TYPE' option. TYPE can either be a short name for the system +type, such as `sun4', or a canonical name with three fields: + CPU-COMPANY-SYSTEM + +See the file `config.sub' for the possible values of each field. If +`config.sub' isn't included in this package, then this package doesn't +need to know the host type. + + If you are building compiler tools for cross-compiling, you can also +use the `--target=TYPE' option to select the type of system they will +produce code for and the `--build=TYPE' option to select the type of +system on which you are compiling the package. + +Sharing Defaults +================ + + If you want to set default values for `configure' scripts to share, +you can create a site shell script called `config.site' that gives +default values for variables like `CC', `cache_file', and `prefix'. +`configure' looks for `PREFIX/share/config.site' if it exists, then +`PREFIX/etc/config.site' if it exists. Or, you can set the +`CONFIG_SITE' environment variable to the location of the site script. +A warning: not all `configure' scripts look for a site script. + +Operation Controls +================== + + `configure' recognizes the following options to control how it +operates. + +`--cache-file=FILE' + Use and save the results of the tests in FILE instead of + `./config.cache'. Set FILE to `/dev/null' to disable caching, for + debugging `configure'. + +`--help' + Print a summary of the options to `configure', and exit. + +`--quiet' +`--silent' +`-q' + Do not print messages saying which checks are being made. + +`--srcdir=DIR' + Look for the package's source code in directory DIR. Usually + `configure' can determine that directory automatically. + +`--version' + Print the version of Autoconf used to generate the `configure' + script, and exit. + +`configure' also accepts some other, not widely useful, options. + diff --git a/libslang/INSTALL.vms b/libslang/INSTALL.vms new file mode 100644 index 0000000..fc5d2a7 --- /dev/null +++ b/libslang/INSTALL.vms @@ -0,0 +1,10 @@ +VMS Installation instructions: + +In the source directory, you will find the following files: + + vmsmake.com VMS DCL command procedure + +On VMS, just type `@vmsmake' or if you have gcc, type `@vmsmake gcc'. + +Note: Since I nolonger have access to VMS, I cannot guarantee that the +library will compile cleanly under VMS. diff --git a/libslang/NEWS b/libslang/NEWS new file mode 100644 index 0000000..0ea4db3 --- /dev/null +++ b/libslang/NEWS @@ -0,0 +1,21 @@ +-*- text -*- +Version 1.4 NEWS (See changes.txt for more details) + * A new home page: www.s-lang.org + + * Support for multiple namespaces (both public and private) + + * Dynamic linking of modules via 'import' (See modules/README). + + * The interpreter now supports all basic C integer and floating + point types. + + * Many more built-in intrinsic functions and improved documentation. + + * Associative Arrays + + * Binary Strings, i.e., the interpreter allows strings to contain + embedded \0 chracters. + + * A slang-shell program called slsh that can run slang scripts (See + slsh subdirectory). + diff --git a/libslang/README b/libslang/README new file mode 100644 index 0000000..7936435 --- /dev/null +++ b/libslang/README @@ -0,0 +1,21 @@ +-*- text -*- + +**** Note: If you are upgrading from previous 1.0 BETA versions, you + may need to recompile your applications if they are + dynamically linked to a BETA version. Failure to do so may + result in a core-dump of your application. + +**** Note: If you are upgrading from version 0.99-XX, read UPGRADE.txt + for important information. + +Installation instructions: + +S-Lang has been successfully compiled and tested on many platforms and OSs +(Unix/VMS/PC-MSDOS/OS2). Building the S-Lang library requires a C compiler +that understands function prototypes. On SunOS, you will need gcc. + + VMS: INSTALL.vms + OS/2, MSDOS, see: INSTALL.pc + Unix: see INSTALL.unx + +See doc/README for more information. diff --git a/libslang/UPGRADE.txt b/libslang/UPGRADE.txt new file mode 100644 index 0000000..9ab4e3e --- /dev/null +++ b/libslang/UPGRADE.txt @@ -0,0 +1,295 @@ +This document consists of two parts. The first part describes some +changes to the interpreter that may affect existing slang macros. The +second part describes changes that may affect applications that use +the library. + +Part 1: Interpreter Changes. +============================ + +Changes to the slang syntax. +--------------------------- + The syntax has not changed too much since version 0.99-XX. However + there are a few changes that you need to be aware of so that you can + modify your slang functions accordingly. See slang/doc/* for more + information about slang version 1.0. + + To help track areas where you code needs changed, add the following + line to the top of each file that you load into the interpreter: + + _debug_info = 1; + + This will cause extra debugging information to get generated. + + The important differences that you must be aware of are listed below: + + * The parser is more sensitive to missing semi-colons. For that + reason, you may experience some parse errors. Make sure each + statement is terminated by a semi-colon. + + * The switch statement has changed--- it is cleaner. In particular, + the `pop' in the default case should be removed. For example, in + 0.99-XX, the object was pushed onto the stack before each switch + case block was executed. In 1.0, the switch statement nolonger + works this way. So, if you currently have code that looks like: + + switch (x) + { case 1: do_something () } + { case 2 or case (x, 3): do_something_else () } + { () > 7: do_big_thing (); + { pop (); do_default () } + + + You must change it to: + + switch (x) + { case 1: do_something (); } + { case 2 or case 3: do_something_else (); } + { x > 7: do_big_thing (); } + { do_default (); } + + Note that this example also illustrates that you may need to insert + some semi-colons to terminate statements. In any event, it is a + good idea to study your switch statements very carefully. + + * The `create_array' function has been eliminated in favor of a new, + cleaner mechanism. For example, instead of using + + a = create_array ('s', 10, 20, 2); + + to create a 10x20 array of strings, you must now use + + a = String_Type [10, 20]; + + Similarly, use `Integer_Type [10, 20]' to create a 10x20 array of + integers. [Note for JED users: See jed/lib/compat.sl for an + implementation of create_array] + + * The semantics of the ``alias'' operator `&' has changed in a much + more useful way. Briefly, if you have code that looks like: + + define exec_function (f) + { + variable x = 1.0; + return f(x); + } + + variable y = exec_function (&sin); + + Then you must change it to: + + define exec_function (f) + { + variable x = 1.0; + return @f(x); + } + + variable y = exec_function (&sin); + + where `@' is a ``dereference'' operator. + + * Several intrinsic functions have changed and a few have been + removed, or renamed. See the documentation in slang/doc/ for more + detailed information about each function. + + Functions ones that have been removed or renamed include: + + create_array + Use simpler syntax, e.g., x = Integer_Type [10]; + + _obj_info + Use the new `typeof' function. See documentation for more + information. + + print_stack has been renamed to _print_stack + + `slapropos' has been renamed to `_apropos'. It also takes an + additional argument. + + `float' has been renamed to `double'. See also `atof'. + + `slang_trace_function' renamed to `_trace_function' + + `pop_n' has been renamed to `_pop_n' + + The semantics of the following functions have changed: + + `fopen': + It now returns NULL upon failure. Change code such as + + fp = fopen (file, "r"); + if (fp == -1) error (...); + + to: + + fp = fopen (file, "r"); + if (fp == NULL) error (...); + + `getenv', `extract_element': + These return NULL upon failure instead of "". This means code + that looks like: + + n = 0; + while (elem = extract_element (list, n, ','), strlen(elem)) + { + n++; + . + . + } + + should be changed to: + + n = 0; + while (elem = extract_element (list, n, ','), elem != NULL) + { + n++; + . + . + } + + `fclose': It now returns -1 upon failure and sets errno, or 0 if + successful. Previously, it returned 0 upon failure and 1 + upon success. + + `fgets': It now returns just 1 value but takes a reference as an + argument. That is, replace code such as: + + while (fgets (fp) > 0) + { + buf = (); + . + . + } + + with: + + while (-1 != fgets (&buf, fp)) + { + . + . + } + + +Part 2: C interface changes +============================ + +[Please review slang/doc/text/cslang.txt for information regarding + embedding the interpreter] + +There have been many, many changes since 0.99-XX. Most of the changes +concern the interpreter and the interpreter interface. Other aspects +of the library, e.g., SLsmg, etc have not changed too much. I made +every attempt to maintain as much backward compatibility as possible, +weighing the pros and cons of every change. I think that I arrived at +a reasonable compromise, and, hopefully, you will agree. + +When recompiling your application, make sure that you compile it with +warnings turned on so that prototype changes may be detected. + +----------------------------------------------------------------------- +The way objects are accessed internally by the interpreter has changed +dramatically. This has important ramifications for an any application +embedding the interpreter. In particular, the way intrinsic objects +are made available to the interpreter has changed. + +In 0.99-XX, the standard procedure was to use the MAKE_INTRINSIC macro +inside an array of SLang_Name_Type, e.g., + + void c_fname (void) { ... } + char *String_Variable; + int Int_Variable; + char String_Buf[256]; + + static SLang_Name_Type My_Intrinsics [] = + { + MAKE_INTRINSIC(".fname", c_fname, VOID_TYPE, 0), + MAKE_VARIABLE(".string_vname", String_Variable, STRING_TYPE, 1), + MAKE_VARIABLE(".string_buf_vname", String_Buf, STRING_TYPE, 1), + MAKE_VARIABLE(".int_vname", &Int_Variable, INT_TYPE, 0), + SLANG_END_TABLE + }; + +In the new version, variables and intrinsics cannot be grouped in the +same table. Instead two tables must be used: + + static SLang_Intrin_Fun_Type My_Intrinsic_Funs [] = + { + MAKE_INTRINSIC("fname", c_fname, VOID_TYPE, 0), + SLANG_END_TABLE + }; + + char *String_Buf_Ptr = String_Buf; + static SLang_Intrin_Var_Type My_Intrinsic_Funs [] = + { + MAKE_VARIABLE("string_vname", &String_Variable, STRING_TYPE, 1), + MAKE_VARIABLE("int_vname", &Int_Variable, INT_TYPE, 0), + MAKE_VARIABLE(".string_buf_vname", &String_Buf_Ptr, STRING_TYPE, 1), + SLANG_END_TABLE + }; + +Note that the `.' is no longer required to be the first character in +the name. Also, the `&' address operator must be used for all +variables in the MAKE_VARIABLE macro. Finally, intrinsic STRING_TYPE +variables must be pointers and not arrays. This is the reason +String_Buf_Ptr was introduced. + +You are encouraged to read the documentation about embedding the +interpreter because it is now possible to ensure that variables passed +to an intrinsic are type checked. See slang/slstd.c for examples. + +------------------------------------------------------------------------ +0.99-XX had a very inconsistent interface. For example, while some +functions returned 0 upon success, others returned 0 to indicate +failure. One of the major changes to the library was to provide a +consistent return value to indicate error. In this version, -1 +indicates an error and 0 indicates success. In particular, the +following functions were affected: + + SLdefine_for_ifdef + SLang_execute_function + SLexecute_function + SLang_run_hooks + SLang_load_object + SLang_pop_* + SLang_push_* + SLsmg_resume_smg + SLsmg_suspend_smg + SLtt_init_video + SLtt_reset_video + +Another change involved the name space. All external symbols now +start with `SL'. To this end, the following functions have been +renamed: + + init_SLmath --> SLang_init_slmath + init_SLunix --> SLang_init_slunix + init_SLang --> SLang_init_slang + init_SLfiles --> SLang_init_slfile + slang_add_array --> SLang_add_intrinsic_array + +Some other functions were renamed when the interface changed: + + SLang_extract_list_element --> SLextract_list_element + SLang_Error_Routine --> SLang_Error_Hook + +Some functions were not renamed but do have different prototypes: + + int SLang_run_hooks(char *, unsigned int, ...); + +Some functions are nolonger available or have been replaced by newer, +more flexible versions: + + SLadd_name --> SLadd_intrinsic_variable, SLadd_intrinsic_function + SLang_pop/push_float --> SLang_pop/push_double + + +Typedef Modifications +--------------------- +SLang_Load_Type: The interface has been completely rewritten. See + the documentation. + +Preprocessor defines: +-------------------- + __SLMATH__ if math functions available (SLang_init_slmath) + __SLUNIX__ if unix functions available (SLang_init_slunix) + __SLFILE__ if file I/O functions available (SLang_init_slfile) + diff --git a/libslang/autoconf/Makefile.in b/libslang/autoconf/Makefile.in new file mode 100644 index 0000000..4b487fe --- /dev/null +++ b/libslang/autoconf/Makefile.in @@ -0,0 +1,37 @@ +# -*- sh -*- + +#This is a UNIX-only makefile. For other systems, get a makefile from +#src/mkfiles/ + +@SET_MAKE@ +SHELL = /bin/sh + +all: + cd src; $(MAKE) all +elf: + cd src; $(MAKE) elf + @echo Use make install-elf to install it. +runtests: + cd src; $(MAKE) runtests +demos: + cd demo; $(MAKE) +clean: + /bin/rm -f *~ + cd src; $(MAKE) clean + cd demo; $(MAKE) clean +install: + cd src; $(MAKE) install +install-elf: + cd src; $(MAKE) install-elf + @echo "" + @echo "On some systems, e.g., linux, you may also have to run ldconfig." + @echo "" +install-links: + cd src; $(MAKE) install-links +# +distclean: + /bin/rm -f *~ Makefile config.status config.log config.cache files.pck + cd src; $(MAKE) distclean + cd demo; $(MAKE) distclean +# + diff --git a/libslang/autoconf/aclocal.m4 b/libslang/autoconf/aclocal.m4 new file mode 100644 index 0000000..bb0fe25 --- /dev/null +++ b/libslang/autoconf/aclocal.m4 @@ -0,0 +1,621 @@ +dnl -*- sh -*- +dnl Here are some global variables that need initialized. + +#AC_DEFUN(JD_PREFIX_DEFAULT, +#[AC_DIVERT_PUSH(AC_DIVERSION_NOTICE)dnl +#$1 +#AC_DIVERT_POP()]) + +AC_DEFUN(JD_INIT, +[ +#These variable are initialized by JD init function +CONFIG_DIR=`pwd` +cd $srcdir +if test "`pwd`" != "$CONFIG_DIR" +then + AC_MSG_ERROR("This software does not support configuring from another directory. See the INSTALL file") +fi +dnl# if test "X$PWD" != "X" +dnl# then +dnl# CONFIG_DIR="$PWD" +dnl# fi +AC_SUBST(CONFIG_DIR)dnl +# Note: these will differ if one is a symbolic link +if test -f /usr/bin/dirname; then + JD_Above_Dir=`dirname $CONFIG_DIR` +else +# system is a loser + JD_Above_Dir=`cd ..;pwd` +fi +JD_Above_Dir2=`cd ..;pwd` +]) + +dnl------------------------------------------------------------------------- + +AC_DEFUN(JD_SET_OBJ_SRC_DIR, +[ +#--------------------------------------------------------------------------- +# Set the source directory and object directory. The makefile assumes an +# abcolute path name. This is because src/Makefile cds to OBJDIR and compiles +# the src file which is in SRCDIR +#--------------------------------------------------------------------------- +SRCDIR=$CONFIG_DIR +if test "$1" != "." +then + if test -z "$1" + then + SRCDIR=$SRCDIR/src + else + SRCDIR=$SRCDIR/$1 + fi +fi + +OBJDIR=$SRCDIR/"$ARCH"objs +ELFDIR=$SRCDIR/elf"$ARCH"objs +AC_SUBST(SRCDIR)dnl +AC_SUBST(OBJDIR)dnl +AC_SUBST(ELFDIR)dnl +]) + +dnl#------------------------------------------------------------------------- +dnl# Rpath handling +dnl#------------------------------------------------------------------------- + +RPATH="" +AC_SUBST(RPATH)dnl + +dnl# determine whether or not -R or -rpath can be used +AC_DEFUN(JD_INIT_RPATH, +[ +case "$host_os" in + *linux*|*solaris* ) + if test "X$GCC" = Xyes + then + if test "X$ac_R_nospace" = "Xno" + then + RPATH="-Wl,-R," + else + RPATH="-Wl,-R" + fi + else + if test "X$ac_R_nospace" = "Xno" + then + RPATH="-R " + else + RPATH="-R" + fi + fi + ;; + *osf*) + if test "X$GCC" = Xyes + then + RPATH="-Wl,-rpath," + else + RPATH="-rpath " + fi + ;; +esac +]) + +AC_DEFUN(JD_SET_RPATH, +[ +if test "X$1" != "X" +then + if test "X$RPATH" = "X" + then + JD_INIT_RPATH + if test "X$RPATH" != "X" + then + RPATH="$RPATH$1" + fi + else + RPATH="$RPATH:$1" + fi +fi +]) + +dnl------------------------------------------------------------------------- + +AC_DEFUN(JD_SIMPLE_LIB_DIR, +[ +changequote(<<, >>)dnl +define(<>, translit($1, [a-z], [A-Z]))dnl +changequote([, ])dnl +JD_UP_NAME[]_LIB_DIR=$JD_Above_Dir/$1/libsrc/"$ARCH"objs +JD_UP_NAME[]_INCLUDE=$JD_Above_Dir/$1/libsrc + +if test ! -d "[$]JD_UP_NAME[]_INCLUDE" +then + JD_UP_NAME[]_LIB_DIR=$JD_Above_Dir/$1/src/"$ARCH"objs + JD_UP_NAME[]_INCLUDE=$JD_Above_Dir/$1/src + if test ! -d "[$]JD_UP_NAME[]_INCLUDE" + then + echo "" + echo WARNING------Unable to find the JD_UP_NAME directory + echo You may have to edit $CONFIG_DIR/src/Makefile. + echo "" + fi +fi + +AC_SUBST(JD_UP_NAME[]_LIB_DIR)dnl +AC_SUBST(JD_UP_NAME[]_INCLUDE)dnl +undefine([JD_UP_NAME])dnl +]) + +dnl------------------------------------------------------------------------- + +AC_DEFUN(JD_FIND_GENERIC, +[ +changequote(<<, >>)dnl +define(<>, translit($1, [a-z], [A-Z]))dnl +changequote([, ])dnl +# Look for the JD_UP_NAME package +#JD_UP_NAME[]_INCLUDE="" +#JD_UP_NAME[]_LIB_DIR="" + +# This list consists of "include,lib include,lib ..." +JD_Search_Dirs="$JD_Above_Dir2/$1/libsrc,$JD_Above_Dir2/$1/libsrc/"$ARCH"objs \ + $JD_Above_Dir/$1/libsrc,$JD_Above_Dir/$1/libsrc/"$ARCH"objs \ + $JD_Above_Dir2/$1/src,$JD_Above_Dir2/$1/src/"$ARCH"objs \ + $JD_Above_Dir/$1/src,$JD_Above_Dir/$1/src/"$ARCH"objs" + +test "x$exec" = "xNONE" && exec="$ac_default_prefix" +test "x$exec_prefix" = "xNONE" && exec_prefix="$prefix" +JD_Search_Dirs="$JD_Search_Dirs \ + $includedir,$libdir \ + $prefix/include,$exec_prefix/lib \ + $HOME/include,$HOME/lib" + +if test -n "$ARCH" +then + JD_Search_Dirs="$JD_Search_Dirs $HOME/include,$HOME/$ARCH/lib" + JD_Search_Dirs="$JD_Search_Dirs $HOME/include,$HOME/sys/$ARCH/lib" +fi + +# Now add the standard system includes. The reason for doing this is that +# the other directories may have a better chance of containing a more recent +# version. + +test "x$exec" = "xNONE" && exec="$ac_default_prefix" +test "x$exec_prefix" = "xNONE" && exec_prefix="$prefix" +JD_Search_Dirs="$JD_Search_Dirs \ + /usr/local/include,/usr/local/lib \ + /usr/include,/usr/lib \ + /usr/include/$1,/usr/lib \ + /usr/include/$1,/usr/lib/$1" + +echo looking for the JD_UP_NAME library + +for include_and_lib in $JD_Search_Dirs +do + # Yuk. Is there a better way to set these variables?? + generic_include=`echo $include_and_lib | tr ',' ' ' | awk '{print [$]1}'` + generic_lib=`echo $include_and_lib | tr ',' ' ' | awk '{print [$]2}'` + echo Looking for $1.h in $generic_include + echo and lib$1.a in $generic_lib + if test -r $generic_include/$1.h && test -r $generic_lib/lib$1.a + then + echo Found it. + JD_UP_NAME[]_LIB_DIR="$generic_lib" + JD_UP_NAME[]_INCLUDE="$generic_include" + break + else + if test -r $generic_include/$1.h && test -r $generic_lib/lib$1.so + then + echo Found it. + JD_UP_NAME[]_LIB_DIR="$generic_lib" + JD_UP_NAME[]_INCLUDE="$generic_include" + break + fi + fi +done + +if test -n "[$]JD_UP_NAME[]_LIB_DIR" +then + jd_have_$1="yes" +else + echo Unable to find the $JD_UP_NAME library. + echo You may have to edit $CONFIG_DIR/src/Makefile. + JD_UP_NAME[]_INCLUDE=$JD_Above_Dir/$1/src + JD_UP_NAME[]_LIB_DIR=$JD_Above_Dir/$1/src/"$ARCH"objs + jd_have_$1="no" +fi + +JD_UP_NAME[]_INC="-I[$]JD_UP_NAME[]_INCLUDE" +JD_UP_NAME[]_LIB="-L[$]JD_UP_NAME[]_LIB_DIR" +JD_SET_RPATH([$]JD_UP_NAME[]_LIB_DIR) +dnl if test "X$GCC" = Xyes +dnl then +dnl RPATH_[]JD_UP_NAME="-Wl,-R[$]JD_UP_NAME[]_LIB_DIR" +dnl else +dnl RPATH_[]JD_UP_NAME="-R[$]JD_UP_NAME[]_LIB_DIR" +dnl fi + +# gcc under solaris is often not installed correctly. Avoid specifying +# -I/usr/include. +if test "[$]JD_UP_NAME[]_INC" = "-I/usr/include" +then + JD_UP_NAME[]_INC="" +fi + +if test "[$]JD_UP_NAME[]_LIB" = "-L/usr/lib" +then + JD_UP_NAME[]_LIB="" + RPATH_[]JD_UP_NAME="" +fi + +AC_SUBST(JD_UP_NAME[]_LIB)dnl +AC_SUBST(JD_UP_NAME[]_INC)dnl +AC_SUBST(JD_UP_NAME[]_LIB_DIR)dnl +AC_SUBST(JD_UP_NAME[]_INCLUDE)dnl +dnl AC_SUBST(RPATH_[]JD_UP_NAME)dnl +undefine([JD_UP_NAME])dnl +]) + +dnl------------------------------------------------------------------------- + +AC_DEFUN(JD_FIND_SLANG, +[ +JD_FIND_GENERIC(slang) +]) + +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_GCC_WARNINGS, +[ +AC_ARG_ENABLE(warnings, + [ --enable-warnings turn on GCC compiler warnings], + [gcc_warnings=$enableval]) +if test -n "$GCC" +then + CFLAGS="$CFLAGS -fno-strength-reduce" + if test -n "$gcc_warnings" + then + CFLAGS="$CFLAGS -Wall -W -pedantic -Winline -Wmissing-prototypes \ + -Wnested-externs -Wpointer-arith -Wcast-align -Wshadow -Wstrict-prototypes" + # Now trim excess whitespace + CFLAGS=`echo $CFLAGS` + fi +fi +]) + +IEEE_CFLAGS="" +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_IEEE_CFLAGS, +[ +case "$host_cpu" in + *alpha* ) + if test "$GCC" = yes + then + IEEE_CFLAGS="-mieee" + else + IEEE_CFLAGS="-ieee_with_no_inexact" + fi + ;; + * ) + IEEE_CFLAGS="" +esac +]) + +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_CREATE_ORULE, +[ +PROGRAM_OBJECT_RULES="$PROGRAM_OBJECT_RULES +\$(OBJDIR)/$1.o : \$(SRCDIR)/$1.c \$(DOT_O_DEPS) \$("$1"_O_DEP) + cd \$(OBJDIR); \$(COMPILE_CMD) \$("$1"_C_FLAGS) \$(SRCDIR)/$1.c +" +]) +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_CREATE_ELFORULE, +[ +PROGRAM_ELF_ORULES="$PROGRAM_ELF_ORULES +\$(ELFDIR)/$1.o : \$(SRCDIR)/$1.c \$(DOT_O_DEPS) \$("$1"_O_DEP) + cd \$(ELFDIR); \$(ELFCOMPILE_CMD) \$("$1"_C_FLAGS) \$(SRCDIR)/$1.c +" +]) + +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_CREATE_EXEC_RULE, +[ +PROGRAM_OBJECT_RULES="$PROGRAM_OBJECT_RULES +$1 : \$(OBJDIR)/$1 + @echo $1 created in \$(OBJDIR) +\$(OBJDIR)/$1 : \$(OBJDIR)/$1.o \$("$1"_DEPS) \$(EXECDEPS) + \$(CC) -o \$(OBJDIR)/$1 \$(LDFLAGS) \$(OBJDIR)/$1.o \$("$1"_LIBS) \$(EXECLIBS) +\$(OBJDIR)/$1.o : \$(SRCDIR)/$1.c \$(DOT_O_DEPS) \$("$1"_O_DEP) + cd \$(OBJDIR); \$(COMPILE_CMD) \$("$1"_INC) \$(EXECINC) \$(SRCDIR)/$1.c +" +]) +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_CREATE_MODULE_ORULES, +[ + for program_module in $Program_Modules; do + JD_CREATE_ORULE($program_module) + JD_CREATE_ELFORULE($program_module) + done +]) + +dnl------------------------------------------------------------------------- + +AC_DEFUN(JD_GET_MODULES, +[ + PROGRAM_HFILES="" + PROGRAM_OFILES="" + PROGRAM_CFILES="" + PROGRAM_OBJECTS="" + PROGRAM_ELFOBJECTS="" + PROGRAM_OBJECT_RULES="" + PROGRAM_ELF_ORULES="" + if test -z "$1" + then + Program_Modules="" + else + comment_re="^#" + Program_Modules=`grep -v '$comment_re' $1 | awk '{print [$]1}'` + Program_H_Modules=`grep -v '$comment_re' $1 | awk '{print [$]2}'` + for program_module in $Program_H_Modules; do + PROGRAM_HFILES="$PROGRAM_HFILES $program_module" + done + fi + for program_module in $Program_Modules; do + PROGRAM_OFILES="$PROGRAM_OFILES $program_module.o" + PROGRAM_CFILES="$PROGRAM_CFILES $program_module.c" + PROGRAM_OBJECTS="$PROGRAM_OBJECTS \$(OBJDIR)/$program_module.o" + PROGRAM_ELFOBJECTS="$PROGRAM_ELFOBJECTS \$(ELFDIR)/$program_module.o" + done +dnl echo $PROGRAM_OFILES +dnl echo $PROGRAM_HFILES +AC_SUBST(PROGRAM_OFILES)dnl +AC_SUBST(PROGRAM_CFILES)dnl +AC_SUBST(PROGRAM_HFILES)dnl +AC_SUBST(PROGRAM_OBJECTS)dnl +AC_SUBST(PROGRAM_ELFOBJECTS)dnl +]) + +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_APPEND_RULES, +[ + echo "$PROGRAM_OBJECT_RULES" >> $1 +]) +dnl------------------------------------------------------------------------- + +AC_DEFUN(JD_APPEND_ELFRULES, +[ + echo "$PROGRAM_ELF_ORULES" >> $1 +]) + +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_CREATE_MODULE_EXEC_RULES, +[ + for program_module in $Program_Modules; do + JD_CREATE_EXEC_RULE($program_module) + done +]) +dnl------------------------------------------------------------------------- + +AC_DEFUN(JD_TERMCAP, +[ +AC_MSG_CHECKING(for Terminfo) +MISC_TERMINFO_DIRS="$FINKPREFIX/share/terminfo" +if test ! -d $MISC_TERMINFO_DIRS +then + MISC_TERMINFO_DIRS="" +fi + +JD_Terminfo_Dirs="/usr/lib/terminfo \ + /usr/share/terminfo \ + /usr/share/lib/terminfo \ + /usr/local/lib/terminfo \ + $MISC_TERMINFO_DIRS" + +TERMCAP=-ltermcap + +for terminfo_dir in $JD_Terminfo_Dirs +do + if test -d $terminfo_dir + then + AC_MSG_RESULT(yes) + TERMCAP="" + break + fi +done +if test "$TERMCAP"; then + AC_MSG_RESULT(no) + AC_DEFINE(USE_TERMCAP) +fi +AC_SUBST(TERMCAP)dnl +AC_SUBST(MISC_TERMINFO_DIRS)dnl +]) + +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_ANSI_CC, +[ +AC_PROG_CC +AC_PROG_CPP +AC_PROG_GCC_TRADITIONAL +AC_ISC_POSIX +AC_AIX + +dnl #This stuff came from Yorick config script +dnl +dnl # HPUX needs special stuff +dnl +AC_EGREP_CPP(yes, +[#ifdef hpux + yes +#endif +], [ +AC_DEFINE(_HPUX_SOURCE) +if test "$CC" = cc; then CC="cc -Ae"; fi +])dnl +dnl +dnl #Be sure we've found compiler that understands prototypes +dnl +AC_MSG_CHECKING(C compiler that understands ANSI prototypes) +AC_TRY_COMPILE([ ],[ + extern int silly (int);], [ + AC_MSG_RESULT($CC looks ok. Good.)], [ + AC_MSG_RESULT($CC is not a good enough compiler) + AC_MSG_ERROR(Set env variable CC to your ANSI compiler and rerun configure.) + ])dnl +])dnl +dnl #---------------------------------------------------------------------- + + +AC_DEFUN(JD_ELF_COMPILER, +[ +dnl #------------------------------------------------------------------------- +dnl # Check for dynamic linker +dnl #------------------------------------------------------------------------- +DYNAMIC_LINK_LIB="" +AC_CHECK_HEADER(dlfcn.h,[ + AC_DEFINE(HAVE_DLFCN_H) + AC_CHECK_LIB(dl,dlopen,[ + DYNAMIC_LINK_LIB="-ldl" + AC_DEFINE(HAVE_DLOPEN) + ],[ + AC_CHECK_FUNC(dlopen,AC_DEFINE(HAVE_DLOPEN)) + if test "$ac_cv_func_dlopen" != yes + then + AC_MSG_WARN(cannot perform dynamic linking) + fi + ])]) +AC_SUBST(DYNAMIC_LINK_LIB) + +ELFLIB="lib\$(THIS_LIB).so" +ELFLIB_MAJOR="\$(ELFLIB).\$(ELF_MAJOR_VERSION)" +ELFLIB_MAJOR_MINOR="\$(ELFLIB).\$(ELF_MAJOR_VERSION).\$(ELF_MINOR_VERSION)" + +case "$host_os" in + *linux* ) + DYNAMIC_LINK_FLAGS="-Wl,-export-dynamic" + ELF_CC="gcc" + ELF_CFLAGS="-O2 -fno-strength-reduce -fPIC" + ELF_LINK="gcc -shared -Wl,-soname#" + ELF_LINK_CMD="\$(ELF_LINK),\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS="\$(DL_LIB) -lm -lc" + CC_SHARED="gcc \$(CFLAGS) -shared -fPIC" + ;; + *solaris* ) + if test "$GCC" = yes + then + DYNAMIC_LINK_FLAGS="" + ELF_CC="gcc" + ELF_CFLAGS="-O2 -fno-strength-reduce -fPIC" + ELF_LINK="gcc -shared -Wl,-ztext -Wl,-h#" + ELF_LINK_CMD="\$(ELF_LINK),\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS="\$(DL_LIB) -lm -lc" + CC_SHARED="gcc \$(CFLAGS) -G -fPIC" + else + DYNAMIC_LINK_FLAGS="" + ELF_CC="cc" + ELF_CFLAGS="-K pic" + ELF_LINK="cc -G -h#" + ELF_LINK_CMD="\$(ELF_LINK)\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS="\$(DL_LIB) -lm -lc" + CC_SHARED="cc \$(CFLAGS) -G -K pic" + fi + ;; + # osr5 or unixware7 with current or late autoconf + *sco3.2v5* | *unixware-5* | *sco-sysv5uw7*) + if test "$GCC" = yes + then + DYNAMIC_LINK_FLAGS="" + ELF_CC="gcc" + ELF_CFLAGS="-O2 -fno-strength-reduce -fPIC" + ELF_LINK="gcc -shared -Wl,-h#" + ELF_LINK_CMD="\$(ELF_LINK),\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS= + CC_SHARED="gcc \$(CFLAGS) -G -fPIC" + else + DYNAMIC_LINK_FLAGS="" + ELF_CC="cc" + ELF_CFLAGS="-K pic" + # ELF_LINK="ld -G -z text -h#" + ELF_LINK="cc -G -z text -h#" + ELF_LINK_CMD="\$(ELF_LINK)\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS= + CC_SHARED="cc \$(CFLAGS) -G -K pic" + fi + ;; + *irix6.5* ) + echo "Note: ELF compiler for host_os=$host_os may not be correct" + echo "double-check: 'mode_t', 'pid_t' may be wrong!" + if test "$GCC" = yes + then + # not tested + DYNAMIC_LINK_FLAGS="" + ELF_CC="gcc" + ELF_CFLAGS="-O2 -fno-strength-reduce -fPIC" + ELF_LINK="gcc -shared -Wl,-h#" + ELF_LINK_CMD="\$(ELF_LINK),\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS= + CC_SHARED="gcc \$(CFLAGS) -shared -fPIC" + else + DYNAMIC_LINK_FLAGS="" + ELF_CC="cc" + ELF_CFLAGS="-K pic" # default anyhow + ELF_LINK="cc -shared -o #" + ELF_LINK_CMD="\$(ELF_LINK)\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS= + CC_SHARED="cc \$(CFLAGS) -shared -K pic" + fi + ;; + *darwin* ) + DYNAMIC_LINK_FLAGS="" + ELF_CC="cc" + ELF_CFLAGS="$CFLAGS -O2 -fno-strength-reduce -fno-common" + ELF_LINK="cc -dynamiclib" + ELF_LINK_CMD="\$(ELF_LINK) -install_name \$(install_lib_dir)/\$(ELFLIB_MAJOR) -compatibility_version \$(ELF_MAJOR_VERSION) -current_version \$(ELF_MAJOR_VERSION).\$(ELF_MINOR_VERSION)" + ELF_DEP_LIBS="$LDFLAGS \$(DL_LIB)" + CC_SHARED="cc -bundle -flat_namespace -undefined suppress \$(CFLAGS) -fno-common" + ELFLIB="lib\$(THIS_LIB).dylib" + ELFLIB_MAJOR="lib\$(THIS_LIB).\$(ELF_MAJOR_VERSION).dylib" + ELFLIB_MAJOR_MINOR="lib\$(THIS_LIB).\$(ELF_MAJOR_VERSION).\$(ELF_MINOR_VERSION).dylib" + ;; + * ) + echo "Note: ELF compiler for host_os=$host_os may be wrong" + ELF_CC="$CC" + ELF_CFLAGS="$CFLAGS -fPIC" + ELF_LINK="$CC -shared" + ELF_LINK_CMD="\$(ELF_LINK)" + ELF_DEP_LIBS="\$(DL_LIB) -lm -lc" + CC_SHARED="$CC $CFLAGS -shared -fPIC" +esac + +AC_SUBST(ELF_CC) +AC_SUBST(ELF_CFLAGS) +AC_SUBST(ELF_LINK) +AC_SUBST(ELF_LINK_CMD) +AC_SUBST(ELF_DEP_LIBS) +AC_SUBST(DYNAMIC_LINK_FLAGS) +AC_SUBST(CC_SHARED) +AC_SUBST(ELFLIB) +AC_SUBST(ELFLIB_MAJOR) +AC_SUBST(ELFLIB_MAJOR_MINOR) +]) + +dnl------------------------------------------------------------------------- +AC_DEFUN(JD_F77_COMPILER, +[ +case "$host_os" in + *linux* ) + F77="g77" + F77_LIBS="-lg2c" + ;; + *solaris*) + F77=f77 + #F77_LIBS="-lF77 -lM77 -L/opt/SUNWspro/SC4.0/lib -lsunmath" + F77_LIBS="-lF77 -lM77 -lsunmath" + ;; + *) + echo "" + echo "WARNING: Assuming f77 as your FORTRAN compiler" + echo "" + F77=f77 + F77_LIBS="" +esac +AC_SUBST(F77) +AC_SUBST(F77_LIBS) +]) + + diff --git a/libslang/autoconf/config.guess b/libslang/autoconf/config.guess new file mode 100755 index 0000000..ed2e03b --- /dev/null +++ b/libslang/autoconf/config.guess @@ -0,0 +1,1321 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002 Free Software Foundation, Inc. + +timestamp='2002-03-20' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Originally written by Per Bothner . +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# This script attempts to guess a canonical system name similar to +# config.sub. If it succeeds, it prints the system name on stdout, and +# exits with 0. Otherwise, it exits with 1. +# +# The plan is that this can be called by configure scripts if you +# don't specify an explicit build system type. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit 0 ;; + --version | -v ) + echo "$version" ; exit 0 ;; + --help | --h* | -h ) + echo "$usage"; exit 0 ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + + +dummy=dummy-$$ +trap 'rm -f $dummy.c $dummy.o $dummy.rel $dummy; exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +set_cc_for_build='case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int dummy(){}" > $dummy.c ; + for c in cc gcc c89 c99 ; do + ($c $dummy.c -c -o $dummy.o) >/dev/null 2>&1 ; + if test $? = 0 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + rm -f $dummy.c $dummy.o $dummy.rel ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently, or will in the future. + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep __ELF__ >/dev/null + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # The OS release + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}" + exit 0 ;; + amiga:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + arc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + hp300:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mac68k:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + macppc:OpenBSD:*:*) + echo powerpc-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvme68k:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvme88k:OpenBSD:*:*) + echo m88k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvmeppc:OpenBSD:*:*) + echo powerpc-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + pmax:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sgi:OpenBSD:*:*) + echo mipseb-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sun3:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + wgrisc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + *:OpenBSD:*:*) + echo ${UNAME_MACHINE}-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + alpha:OSF1:*:*) + if test $UNAME_RELEASE = "V4.0"; then + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + fi + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + cat <$dummy.s + .data +\$Lformat: + .byte 37,100,45,37,120,10,0 # "%d-%x\n" + + .text + .globl main + .align 4 + .ent main +main: + .frame \$30,16,\$26,0 + ldgp \$29,0(\$27) + .prologue 1 + .long 0x47e03d80 # implver \$0 + lda \$2,-1 + .long 0x47e20c21 # amask \$2,\$1 + lda \$16,\$Lformat + mov \$0,\$17 + not \$1,\$18 + jsr \$26,printf + ldgp \$29,0(\$26) + mov 0,\$16 + jsr \$26,exit + .end main +EOF + eval $set_cc_for_build + $CC_FOR_BUILD $dummy.s -o $dummy 2>/dev/null + if test "$?" = 0 ; then + case `./$dummy` in + 0-0) + UNAME_MACHINE="alpha" + ;; + 1-0) + UNAME_MACHINE="alphaev5" + ;; + 1-1) + UNAME_MACHINE="alphaev56" + ;; + 1-101) + UNAME_MACHINE="alphapca56" + ;; + 2-303) + UNAME_MACHINE="alphaev6" + ;; + 2-307) + UNAME_MACHINE="alphaev67" + ;; + 2-1307) + UNAME_MACHINE="alphaev68" + ;; + esac + fi + rm -f $dummy.s $dummy + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + exit 0 ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit 0 ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit 0 ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit 0;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit 0 ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit 0 ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit 0 ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit 0;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit 0;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit 0 ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit 0 ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + i86pc:SunOS:5.*:*) + echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit 0 ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit 0 ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit 0 ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit 0 ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit 0 ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit 0 ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit 0 ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit 0 ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit 0 ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit 0 ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit 0 ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit 0 ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit 0 ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD $dummy.c -o $dummy \ + && ./$dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \ + && rm -f $dummy.c $dummy && exit 0 + rm -f $dummy.c $dummy + echo mips-mips-riscos${UNAME_RELEASE} + exit 0 ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit 0 ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit 0 ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit 0 ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit 0 ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit 0 ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit 0 ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit 0 ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit 0 ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit 0 ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit 0 ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit 0 ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit 0 ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit 0 ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + $CC_FOR_BUILD $dummy.c -o $dummy && ./$dummy && rm -f $dummy.c $dummy && exit 0 + rm -f $dummy.c $dummy + echo rs6000-ibm-aix3.2.5 + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit 0 ;; + *:AIX:*:[45]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit 0 ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit 0 ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit 0 ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit 0 ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit 0 ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit 0 ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit 0 ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit 0 ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS= $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null) && HP_ARCH=`./$dummy` + if test -z "$HP_ARCH"; then HP_ARCH=hppa; fi + rm -f $dummy.c $dummy + fi ;; + esac + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit 0 ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit 0 ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD $dummy.c -o $dummy && ./$dummy && rm -f $dummy.c $dummy && exit 0 + rm -f $dummy.c $dummy + echo unknown-hitachi-hiuxwe2 + exit 0 ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit 0 ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit 0 ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit 0 ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit 0 ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit 0 ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit 0 ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit 0 ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit 0 ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit 0 ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit 0 ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit 0 ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*T3D:*:*:*) + echo alpha-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit 0 ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit 0 ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; + *:FreeBSD:*:*) + echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit 0 ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit 0 ;; + i*:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit 0 ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit 0 ;; + x86:Interix*:3*) + echo i386-pc-interix3 + exit 0 ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i386-pc-interix + exit 0 ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit 0 ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit 0 ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + *:GNU:*:*) + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit 0 ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit 0 ;; + arm*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + mips:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef mips + #undef mipsel + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=mipsel + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=mips + #else + CPU= + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` + rm -f $dummy.c + test x"${CPU}" != x && echo "${CPU}-pc-linux-gnu" && exit 0 + ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-gnu + exit 0 ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-gnu + exit 0 ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null + if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi + echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} + exit 0 ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-gnu ;; + PA8*) echo hppa2.0-unknown-linux-gnu ;; + *) echo hppa-unknown-linux-gnu ;; + esac + exit 0 ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-gnu + exit 0 ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux + exit 0 ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + x86_64:Linux:*:*) + echo x86_64-unknown-linux-gnu + exit 0 ;; + i*86:Linux:*:*) + # The BFD linker knows what the default object file format is, so + # first see if it will tell us. cd to the root directory to prevent + # problems with other programs or directories called `ld' in the path. + # Set LC_ALL=C to ensure ld outputs messages in English. + ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ + | sed -ne '/supported targets:/!d + s/[ ][ ]*/ /g + s/.*supported targets: *// + s/ .*// + p'` + case "$ld_supported_targets" in + elf32-i386) + TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" + ;; + a.out-i386-linux) + echo "${UNAME_MACHINE}-pc-linux-gnuaout" + exit 0 ;; + coff-i386) + echo "${UNAME_MACHINE}-pc-linux-gnucoff" + exit 0 ;; + "") + # Either a pre-BFD a.out linker (linux-gnuoldld) or + # one that does not give us useful --help. + echo "${UNAME_MACHINE}-pc-linux-gnuoldld" + exit 0 ;; + esac + # Determine whether the default compiler is a.out or elf + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + #ifdef __ELF__ + # ifdef __GLIBC__ + # if __GLIBC__ >= 2 + LIBC=gnu + # else + LIBC=gnulibc1 + # endif + # else + LIBC=gnulibc1 + # endif + #else + #ifdef __INTEL_COMPILER + LIBC=gnu + #else + LIBC=gnuaout + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` + rm -f $dummy.c + test x"${LIBC}" != x && echo "${UNAME_MACHINE}-pc-linux-${LIBC}" && exit 0 + test x"${TENTATIVE}" != x && echo "${TENTATIVE}" && exit 0 + ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit 0 ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit 0 ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit 0 ;; + i*86:*:5:[78]*) + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit 0 ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')` + (/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|egrep '^Machine.*Pent ?II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|egrep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit 0 ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit 0 ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i386. + echo i386-pc-msdosdjgpp + exit 0 ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit 0 ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit 0 ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit 0 ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit 0 ;; + M68*:*:R3V[567]*:*) + test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; + 3[34]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4.3${OS_REL} && exit 0 + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4 && exit 0 ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit 0 ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit 0 ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit 0 ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit 0 ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit 0 ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit 0 ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit 0 ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit 0 ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit 0 ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit 0 ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit 0 ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit 0 ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit 0 ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit 0 ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit 0 ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit 0 ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit 0 ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit 0 ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit 0 ;; + *:Darwin:*:*) + echo `uname -p`-apple-darwin${UNAME_RELEASE} + exit 0 ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit 0 ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit 0 ;; + NSR-[GKLNPTVW]:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit 0 ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit 0 ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit 0 ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit 0 ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = "386"; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit 0 ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit 0 ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit 0 ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit 0 ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit 0 ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit 0 ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit 0 ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit 0 ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit 0 ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit 0 ;; +esac + +#echo '(No uname command or uname output not recognized.)' 1>&2 +#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 + +eval $set_cc_for_build +cat >$dummy.c < +# include +#endif +main () +{ +#if defined (sony) +#if defined (MIPSEB) + /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, + I don't know.... */ + printf ("mips-sony-bsd\n"); exit (0); +#else +#include + printf ("m68k-sony-newsos%s\n", +#ifdef NEWSOS4 + "4" +#else + "" +#endif + ); exit (0); +#endif +#endif + +#if defined (__arm) && defined (__acorn) && defined (__unix) + printf ("arm-acorn-riscix"); exit (0); +#endif + +#if defined (hp300) && !defined (hpux) + printf ("m68k-hp-bsd\n"); exit (0); +#endif + +#if defined (NeXT) +#if !defined (__ARCHITECTURE__) +#define __ARCHITECTURE__ "m68k" +#endif + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; + if (version < 4) + printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); + else + printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); + exit (0); +#endif + +#if defined (MULTIMAX) || defined (n16) +#if defined (UMAXV) + printf ("ns32k-encore-sysv\n"); exit (0); +#else +#if defined (CMU) + printf ("ns32k-encore-mach\n"); exit (0); +#else + printf ("ns32k-encore-bsd\n"); exit (0); +#endif +#endif +#endif + +#if defined (__386BSD__) + printf ("i386-pc-bsd\n"); exit (0); +#endif + +#if defined (sequent) +#if defined (i386) + printf ("i386-sequent-dynix\n"); exit (0); +#endif +#if defined (ns32000) + printf ("ns32k-sequent-dynix\n"); exit (0); +#endif +#endif + +#if defined (_SEQUENT_) + struct utsname un; + + uname(&un); + + if (strncmp(un.version, "V2", 2) == 0) { + printf ("i386-sequent-ptx2\n"); exit (0); + } + if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ + printf ("i386-sequent-ptx1\n"); exit (0); + } + printf ("i386-sequent-ptx\n"); exit (0); + +#endif + +#if defined (vax) +# if !defined (ultrix) +# include +# if defined (BSD) +# if BSD == 43 + printf ("vax-dec-bsd4.3\n"); exit (0); +# else +# if BSD == 199006 + printf ("vax-dec-bsd4.3reno\n"); exit (0); +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# endif +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# else + printf ("vax-dec-ultrix\n"); exit (0); +# endif +#endif + +#if defined (alliant) && defined (i860) + printf ("i860-alliant-bsd\n"); exit (0); +#endif + + exit (1); +} +EOF + +$CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && ./$dummy && rm -f $dummy.c $dummy && exit 0 +rm -f $dummy.c $dummy + +# Apollos put the system type in the environment. + +test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } + +# Convex versions that predate uname can use getsysinfo(1) + +if [ -x /usr/convex/getsysinfo ] +then + case `getsysinfo -f cpu_type` in + c1*) + echo c1-convex-bsd + exit 0 ;; + c2*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + c34*) + echo c34-convex-bsd + exit 0 ;; + c38*) + echo c38-convex-bsd + exit 0 ;; + c4*) + echo c4-convex-bsd + exit 0 ;; + esac +fi + +cat >&2 < in order to provide the needed +information to handle your system. + +config.guess timestamp = $timestamp + +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/libslang/autoconf/config.sub b/libslang/autoconf/config.sub new file mode 100755 index 0000000..f365797 --- /dev/null +++ b/libslang/autoconf/config.sub @@ -0,0 +1,1443 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002 Free Software Foundation, Inc. + +timestamp='2002-03-07' + +# This file is (in principle) common to ALL GNU software. +# The presence of a machine in this file suggests that SOME GNU software +# can handle that machine. It does not imply ALL GNU software can. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS + $0 [OPTION] ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit 0 ;; + --version | -v ) + echo "$version" ; exit 0 ;; + --help | --h* | -h ) + echo "$usage"; exit 0 ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit 0;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | storm-chaos* | os2-emx* | windows32-* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis) + os= + basic_machine=$1 + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ + | c4x | clipper \ + | d10v | d30v | dsp16xx \ + | fr30 \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | i370 | i860 | i960 | ia64 \ + | m32r | m68000 | m68k | m88k | mcore \ + | mips | mips16 | mips64 | mips64el | mips64orion | mips64orionel \ + | mips64vr4100 | mips64vr4100el | mips64vr4300 \ + | mips64vr4300el | mips64vr5000 | mips64vr5000el \ + | mipsbe | mipseb | mipsel | mipsle | mipstx39 | mipstx39el \ + | mipsisa32 | mipsisa64 \ + | mn10200 | mn10300 \ + | ns16k | ns32k \ + | openrisc | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ + | pyramid \ + | sh | sh[34] | sh[34]eb | shbe | shle | sh64 \ + | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \ + | strongarm \ + | tahoe | thumb | tic80 | tron \ + | v850 | v850e \ + | we32k \ + | x86 | xscale | xstormy16 | xtensa \ + | z8k) + basic_machine=$basic_machine-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12) + # Motorola 68HC11/12. + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ + | arm-* | armbe-* | armle-* | armv*-* \ + | avr-* \ + | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c54x-* \ + | clipper-* | cydra-* \ + | d10v-* | d30v-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fr30-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | m32r-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | mcore-* \ + | mips-* | mips16-* | mips64-* | mips64el-* | mips64orion-* \ + | mips64orionel-* | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* | mipsbe-* | mipseb-* \ + | mipsle-* | mipsel-* | mipstx39-* | mipstx39el-* \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ + | pyramid-* \ + | romp-* | rs6000-* \ + | sh-* | sh[34]-* | sh[34]eb-* | shbe-* | shle-* | sh64-* \ + | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \ + | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ + | tahoe-* | thumb-* | tic30-* | tic54x-* | tic80-* | tron-* \ + | v850-* | v850e-* | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \ + | xtensa-* \ + | ymp-* \ + | z8k-*) + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + crds | unos) + basic_machine=m68k-crds + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; +# I'm not sure what "Sysv32" means. Should this be sysv3.2? + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + mingw32) + basic_machine=i386-pc + os=-mingw32 + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + mmix*) + basic_machine=mmix-knuth + os=-mmixware + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + or32 | or32-*) + basic_machine=or32-unknown + os=-coff + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon) + basic_machine=i686-pc + ;; + pentiumii | pentium2) + basic_machine=i686-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc) basic_machine=powerpc-unknown + ;; + ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3d) + basic_machine=alpha-cray + os=-unicos + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tic54x | c54x*) + basic_machine=tic54x-unknown + os=-coff + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + windows32) + basic_machine=i386-pc + os=-windows32-msvcrt + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh3 | sh4 | sh3eb | sh4eb) + basic_machine=sh-unknown + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparc | sparcv9 | sparcv9b) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + c4x*) + basic_machine=c4x-none + os=-coff + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \ + | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* \ + | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto*) + os=-nto-qnx + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + # This also exists in the configure program, but was not the + # default. + # os=-sunos4 + ;; + m68*-cisco) + os=-aout + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) + os=-beos + ;; + *-ibm) + os=-aix + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -vxsim* | -vxworks*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit 0 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/libslang/autoconf/configure.in b/libslang/autoconf/configure.in new file mode 100644 index 0000000..cdfdfbf --- /dev/null +++ b/libslang/autoconf/configure.in @@ -0,0 +1,146 @@ +dnl -*- sh -*- +dnl +dnl This file requires m4 macros that I define in my acsite.m4 file. +dnl A copy is in the autoconf directory. +dnl + +AC_INIT(src/slang.c) +#AC_PREFIX_DEFAULT($MY_PREFIX_DEAULT) + +# Installation location +AC_PREFIX_DEFAULT("/usr/local" +if test -f "/usr/include/slang.h"; then +ac_default_prefix="/usr" +fi +) + +AC_CONFIG_AUX_DIR(autoconf) +AC_CANONICAL_HOST + +JD_INIT +JD_ANSI_CC + +AC_PROG_MAKE_SET +AC_PROG_RANLIB +AC_PROG_INSTALL + +#Check these header since they cause trouble +AC_CHECK_HEADERS( \ +stdlib.h \ +unistd.h \ +memory.h \ +termios.h \ +malloc.h \ +locale.h \ +fcntl.h \ +sys/fcntl.h \ +sys/types.h \ +sys/wait.h \ +sys/utsname.h \ +sys/times.h \ +) + +AC_TYPE_MODE_T +AC_TYPE_PID_T +AC_TYPE_UID_T + +AC_HEADER_DIRENT + +AC_CHECK_FUNCS(\ +memset \ +memcpy \ +putenv \ +getcwd \ +setlocale \ +tcgetattr \ +tcsetattr \ +cfgetospeed \ +sigaction \ +sigemptyset \ +sigprocmask \ +sigaddset \ +vfscanf \ +lstat readlink \ +kill \ +snprintf vsnprintf \ +getppid getegid geteuid getuid getgid setgid setpgid setuid \ +chown popen mkfifo \ +atexit on_exit umask uname \ +times gmtime \ +strtod \ +issetugid \ +) + +AC_CHECK_LIB(m, acosh, [AC_DEFINE(HAVE_ACOSH)]) +AC_CHECK_LIB(m, asinh, [AC_DEFINE(HAVE_ASINH)]) +AC_CHECK_LIB(m, atanh, [AC_DEFINE(HAVE_ATANH)]) + +JD_ELF_COMPILER +JD_IEEE_CFLAGS + +ELF_CFLAGS="$ELF_CFLAGS $IEEE_CFLAGS" +CFLAGS="$CFLAGS $IEEE_CFLAGS" + +JD_SET_RPATH($libdir) + +AC_CHECK_SIZEOF(short, 2) +AC_CHECK_SIZEOF(int, 4) +AC_CHECK_SIZEOF(long, 4) +AC_CHECK_SIZEOF(float, 4) +AC_CHECK_SIZEOF(double, 8) + +JD_TERMCAP +JD_GCC_WARNINGS + +JD_SET_OBJ_SRC_DIR(src) + +JD_GET_MODULES(src/modules.unx) +JD_CREATE_MODULE_ORULES + +AC_MSG_CHECKING(SLANG_VERSION) +slang_version=`grep "^#define *SLANG_VERSION " $srcdir/src/slang.h | + awk '{ print [$]3 }'` +slang_major_version=`echo $slang_version | + awk '{ print int([$]1/10000) }'` +slang_minor_version=`echo $slang_version $slang_major_version | + awk '{ print int(([$]1 - [$]2*10000)/100) }'` +slang_mminor_version=`echo $slang_version $slang_major_version $slang_minor_version | + awk '{ print ([$]1 - [$]2*10000 - [$]3*100) }'` + +slang_minor_version="$slang_minor_version.$slang_mminor_version" +slang_version="$slang_major_version.$slang_minor_version" +AC_MSG_RESULT($slang_version) +AC_SUBST(slang_major_version) +AC_SUBST(slang_minor_version) +AC_SUBST(slang_version) + +AC_CONFIG_HEADER(src/sysconf.h:src/config.hin) + +AC_CONFIG_SUBDIRS(demo) + +AC_OUTPUT(Makefile:autoconf/Makefile.in src/Makefile slsh/Makefile modules/Makefile) + +JD_CREATE_EXEC_RULE(calc) +JD_CREATE_EXEC_RULE(untic) +JD_APPEND_RULES(src/Makefile) +JD_APPEND_ELFRULES(src/Makefile) + +echo "" +echo "Configuration complete. You may need to edit src/Makefile." +echo "You are compiling SLANG with the following compiler configuration:" +echo " CC =" "$CC" +echo " CFLAGS =" "$CFLAGS" +echo " LDFLAGS =" "$LDFLAGS $DYNAMIC_LINK_FLAGS" +echo "" +echo " ELF_CC =" "$ELF_CC" +echo " ELF_LINK =" "$ELF_LINK" +echo "ELF_CFLAGS=" "$ELF_CFLAGS" +echo "" +echo " prefix:" "$prefix" +echo " exec_prefix:" "$exec_prefix" +echo " Installation Lib Dir:" "$libdir" +echo "Installation Include Dir:" "$includedir" +echo "" +echo "See also src/sl-feat.h for various features." +echo "Type 'make' to build normal library." +echo "On ELF systems, type 'make elf' to create ELF shared library." diff --git a/libslang/autoconf/install.sh b/libslang/autoconf/install.sh new file mode 100755 index 0000000..e9de238 --- /dev/null +++ b/libslang/autoconf/install.sh @@ -0,0 +1,251 @@ +#!/bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5 (mit/util/scripts/install.sh). +# +# Copyright 1991 by the Massachusetts Institute of Technology +# +# Permission to use, copy, modify, distribute, and sell this software and its +# documentation for any purpose is hereby granted without fee, provided that +# the above copyright notice appear in all copies and that both that +# copyright notice and this permission notice appear in supporting +# documentation, and that the name of M.I.T. not be used in advertising or +# publicity pertaining to distribution of the software without specific, +# written prior permission. M.I.T. makes no representations about the +# suitability of this software for any purpose. It is provided "as is" +# without express or implied warranty. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. It can only install one file at a time, a restriction +# shared with many OS's install programs. + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +transformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + chmodcmd="" + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 diff --git a/libslang/autoconf/mkinsdir.sh b/libslang/autoconf/mkinsdir.sh new file mode 100755 index 0000000..cd1fe0a --- /dev/null +++ b/libslang/autoconf/mkinsdir.sh @@ -0,0 +1,32 @@ +#! /bin/sh +# mkinstalldirs --- make directory hierarchy +# Author: Noah Friedman +# Created: 1993-05-16 +# Public domain + +errstatus=0 + +for file +do + set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'` + shift + + pathcomp= + for d in ${1+"$@"} ; do + pathcomp="$pathcomp$d" + case "$pathcomp" in + -* ) pathcomp=./$pathcomp ;; + esac + + if test ! -d "$pathcomp"; then + echo "mkdir $pathcomp" 1>&2 + mkdir "$pathcomp" || errstatus=$? + fi + + pathcomp="$pathcomp/" + done +done + +exit $errstatus + +# mkinstalldirs ends here diff --git a/libslang/changes.txt b/libslang/changes.txt new file mode 100644 index 0000000..574356a --- /dev/null +++ b/libslang/changes.txt @@ -0,0 +1,1505 @@ +Changes since 1.4.8 +1. src/slarray.c: superfluous call to SLclass_add_math_op removed + (Michael Noble ) +2. src/slang.c: foreach (NULL) using("next"){} foo (); caused _NARGS=1 + in foo. +3. src/slarrfunc.c: Fix to prevent sum(NULL) from causing a core-dump. +4. src/slimport.c: import (module, "") made equivalent to + import(module,"Global"); This way, import(module, current_namespace()) + will work when the current namespace is anonymous. +5. src/slospath.c: Several users have requested that I add the ability + to define a load path and use that path when loading interpreter + files. To this end, several new functions were added to the API: + + char *SLpath_get_load_path (void); + int SLpath_set_load_path (char *path); + /* Get and Set the path to be searched for files */ + int SLpath_get_path_delimiter (void); + SLpath_set_path_delimiter (int delimiter); + /* Get and set the character delimiter for search paths */ + int SLang_load_file_verbose (int verbose); + /* if non-zero, display file loading messages */ + + New intrinsics include: + + set_slang_load_path + get_slang_load_path + path_get_delimiter + + These functions, nor the intrinsics have an effect on applications + that use SLang_load_file_hook or SLns_load_file_hook for loading + files. The change should be transparant to applications that use + the stock load file mechanism. The main difference is that if one + attempts to load a file with no extension, e.g., "foo", but the + file does not exist, then the interpreter will try to load the more + recent of "foo.sl" and "foo.slc". + + See src/slsh.c for how the functions may be used. + +6. slsh/slsh.c: Updated to use the new search path code outlined + above. Also, slsh is distributed with a collection of general + purpose slang functions, including jed's provide/require functions. + See slsh/README for more information. +7. doc/tm/cslang.tm: Modified the section describing the implemetation + of intrinsic functions in an effort to clarify the discussion. +8. src/slang.c: tiny memory leak resulting from peephole optimzations + added earlier found and fixed. +9. src/slarrmisc.c: new intrinsic: cumsum computes the cumulative sum + of an array via the new SLarray_map_array function. + +Changes since 1.4.7 +1. src/sldisply.c: make sure SLtt_erase_line leaves the cursor at the + beginning of a line in all cases. Previously, this happened only + for terminals able to delete to the end of line _and_, when + writing to the last line, the ability to insert a character. +2. doc/tm/cslang.tm: In the discussion of the MAKE_CSTRUCT_FIELD + macro, SLANG_STRING_TYPE was used instead of SLANG_INT_TYPE + (mnoble@space.mit.edu). Similarly, in the discussion of intrinsic + structures, My_Window was used instead of My_Win + dburke@head-cfa.cfa.harvard.edu. +3. src/slang.c: peephole optimizations of 1.4.7 were conflicting with __tmp + optimizations. This was causing something as simple as + + define f() + { + variable a = [1.0:10.0:1]; + variable b = a * 0.0; + return a; + } + + to fail. +4. src/slarray.c Allow ranges to index higher dimensional array. +5. slsh/slsh.c: Updated to allow a user specified search path. See + slsh/README for more info. + +Changes since 1.4.6 +1. src/slclass.c: Change "-??-" to "- ?? -" to avoid its + interpretation as a trigraph. Miquel Garriga +2. src/mkfiles/makefile.all: If compiling with mingw32, use "cp" + instead of "copy". Miquel Garriga +3. src/sllimits.h: Increased the size of the local variable and + recursion stacks on 32 bit systems. +4. src/slarrfun.c: "sum", "min", and "max" intrinsic functions added. + Since these may conflict with application defined function, they + have been placed in their own module. To get them, use + SLang_init_array_extra --- SLang_init_all will not pick up this + module. Version 2 of the library will add these functions to the + main array function module. +5. src/sltermin.c: Work around a bug in the solaris 7+8 tset program + which improperly sets the TERMCAP environment variable + (Paananen Mikko ). +6. src/slprep.c: Added support for "#stop" and a few other useful + or convenient features. See comments at the top of slprep.c for + more details. (Mark Olesen ). +7. src/.c: "const" qualifier added to several places to put + constant variables in rdata/text segment to be shared between + other processes. ("Andrew V. Samoilov" ) +8. src/sldisply.c: If colors were defined using the "Sf" capability + instead of the "AF" capability, then assume those are specified in + BGR format instead of RGB. (Pavel Roskin ) +9. slsh/slsh.c: "status" was not declared if compiled with + SLSH_LIB_DIR defined. (mnoble@space.mit.edu) +10. slsh/Makefile.g32: new file to allow slsh to be compiled with + mingw32. +11. src/sldisply.c,sltermin.c: if running as setuid/setgid, then limit + access to the environment for such a process. . +12. src/slstd.c: New intrinsic function _get_namespaces may be used to + get a list of currently defined namespaces. +13. src/slstruct.c: better support for pushing and popping structures + from C via the SLang_push/pop_cstruct. See doc/text/cslang.txt + for details. +14. slsh/Makefile.in: install target added +15. src/slang.c: additional peep-hole optimizations added +16. src/*.c: fixes it enable the library to be compiled without floating + support support. + +Changes since 1.4.5 +1. doc/tm/rtl/struct.tm: Typos in documentation for set_struct_fields + corrected by Douglas Burke . +2. src/sldisply.c: VMS specific problem: SLang_TT_Write_FD was not + getting initialized (Hartmut Becker ). +3. src/slarith.c: On a 64 bit system, it was possible that Int_Type + objects were not getting properly converted to Double_Type. +4. src/sltoken.c: A unitialized memory reference fixed in the + error handling of an empty character declaration (''). +5. src/slstd.c: call to _SLinit_slcomplex moved to slmath.c. This + means that one does not get complex number support unless math + support is also enabled. (suggested by Michael Noble + ) +6. src/slclass.c: Make sure that when registering a class using + SLANG_VOID_TYPE, the reserved class ids are not used. +7. src/slmisc.c, src/sltoken.c: moved SLatoi and friends from sltoken + to slmisc.c. This avoids linking in the interpreter when it is not + needed. +8. doc/tm/rtl/array.tm: Documentation for the "where" function + corrected by . +9. src/slkeypad.c: support added for F11 and F12 keys +10. src/slimport.c: Better handling of dlopen errors as suggested by + Michael Noble ) +17. src/slarray.c: Allow setting elements of pointer type arrays to + NULL, e.g., a[10] = NULL. +18. src/slsignal.c: If CYGWIN, then assume posix signal handling works. +19. src/slang.c: Do not allow an intrinsic function, variable, etc + table to be added twice. +20. src/slarray.c: Added _isnull intrinsic for checking for NULL values of + array elements. This is useful since something like + "where(a==NULL)" does not check the individual elements, whereas + "where(_isnull(a))" does. +21. src/sldisply.c: typo involving the initialization of Del_Eol_Str + for terminals that do not have such capability. + (Pavel Roskin ) + +Changes since 1.4.4 +1. Added QNX specific patches and fixed some typos that prevented it + from compiling when _SLANG_OPTIMIZE_FOR_SPEED is 0. (Tijs Michels + ). +2. Make sure '#ifeval expr' evaluates up to the end of a line and no + further. +3. src/sldisply.c: Do not look for pad info in the graphic charset + pairs string. Also, when comparing space characters, be sure to + take into account ACS. (Marek Paliwoda ) +4. Trivial code cleanups to avoid BCC 5.x warnings. +5. src/mkfiles/makefile.all: BCC-specific tweaks (John Skilleter + ) +6. SLang_push/pop_datatype made public +7. src/slutty.c: if tty is not initialized and an attempt is made to + read from the tty, set errno to EBADF. +8. src/slkeypad.c: New function SLkp_set_getkey_function. This may be + used to specify a different function to read keys. +9. src/slcurses.c: If an invalid keysequence is entered, simply return the + characters of the sequence on successive getkey calls. +10. src/slarray.c: Inline arrays of the form [1f, 0] were not working. +11. src/sldisply.c: Make sure SLtt_get_screen size gets called by + SLtt_initialize. +12. doc/tm/rtl/struct.tm: typeof in example for get_struct_field_names + corrected by Chris Baluta. +13. modules/varray.c: example showing how a memory mapped array may be + created. It also illustrates the free_fun callback for arrays. +14. examples/life.sl: a S-Lang implementation of Conway's life. +15. src/slclass.c: SLclass_dup_object function added. Although + push/pop can be used to achieve a duplicated object, this function + makes it a little easier. +16. src/slang.h: Prototyes involving "unsigned char" to represent data + types have been modified to use SLtype, which is typedefed to be + an unsigned char. V2 will use a different size for data types. +17. Misc tweaks to aclocal.m4, src/Makefile.in, etc to support MacOSX. + I have not tested it on that system. +18. The library may now be compiled under CYGWIN using the same + procedure as under Unix. +19. src/slkeypad.c: Some xterm-specific escape sequences added by + Denis Zaitsev . + +Changes since 1.4.3 +1. Fixed a bug that shows up on 64 bit BigEndian machines--- it + affected no others. +2. Fixed potential problem in pre-parsing binary strings. +3. Bug a fixed affecting only pure termcap-based systems. It has + been around a while, I am surprised that it took so long to be + discovered. + +Changes since 1.4.2 +1. If init_NAME_module_ns does not exist in a module, then try to + load init_NAME_module as long as the module is to be imported into + the Global namespace. +2. src/sldisply.c: allow more than 200 rows and 250 columns. Who + uses such windows? +3. Allow Void_Type to be specified for the data-type in array_map if the + function returns nothing. +4. src/slarray.c: A statement such as [1:-1][[1:-1]] = [1:-1]; was + causing a core dump. +5. src/sldisply.c: (Unix/VMS) SLsmg/SLtt routines will write using the file + descriptor SLang_TT_Write_FD, which, by default, is initialized to + fileno(stdout). +6. src/slposio.c: New C API functions: + SLfile_get_fd returns the file descriptor associated with the + SLFile object. + SLfile_dup_fd: duplicate an SLFile object +7. src/slposio.c: New intrinsics: dup_fd (dup a file descriptor) +8. SLerrno.c: C API Function: SLerrno_set_errno. +9. SLerrno.c: More errno values added. +10. Raising complex types to powers supported. +11. slang.c: current_namespace was returning "global" instead of + "Global" for the global namespace. +12. slang.c: `use_namespace("X");define f();' was not placing `f' into + `X'. +13. path_is_absolute fixed to return integer +14. src/slarray.c: generate an error when an empty array is passed to + array_map. +15. src/slarray.c: a=3; a[*] should return an array. +16. Make sure setlocale(LC_NUMERIC,"C") gets called. +17. slvideo.c: SLtt_set_cursor_visibility implemented for win32. +18. slvideo.c: SLtt_get_screen_size corrected for win32 by Zusha P. +19. configure: modified to not automatically assume that -ldl is + required for dlopen. In addition, molesen@zeunastaerker.de sent + patches for building dynamically linked library under irix. +20. slsh/Makefile: generated by configure. +21. modules/Makefile: generated by configure +22. src/slimport.c: If no module path has been set, fall back on + $(prefix)/lib/slang/modules +23. src/Makefile.in: DESTDIR support added by Brad . +24. src/Makefile.in: documentation is installed in $(prefix)/doc/slang + and no longer in $(prefix)/doc/slang/$(slang_version) +25. sleep intrinsic can take a floating point number to sleep + fractional seconds. +26. src/slang.c: fix SLang_run_hooks to accept a namespace qualifier. +27. New modules added to the module directory: fcntl, select, termios. + +Changes since 1.4.1 +1. slang.c: Under certain conditions, the continue statement was not + properly handled in do..while statements. src/test/loops.sl added + for testing. +2. slparse.c: avoid potential (rare?) infinite loop when slang error occurs + (Stanis³a Bartkowski ). +3. slsmg.c: When SLsmg_init_smg is called, mark the display as trashed. +4. It is now possible to add intrinsics to their own namespace via + new SLns_add* functions. Moreover, the import function now takes + an optional additional argument that specifies a namespace. +5. New namespace intrinsics: use_namespace, current_namespace +6. Changed inner-product algorithm to minimize the number of cache + misses. +7. sldisply.c: Kanji specific patch from Jim Chen + . +8. sldisply.c: Assume that Eterm and rxvt are xterm-like (Michael + Jennings ). +9. sldostty.c: mouse support added by Gisle Vanem . +10. slsearch.c: avoid infinite loop if search string has no length. +11. SCO elf support added by Mike Hopkirk . +12. slregexp.c: regexp \d+ was not working properly +13. keyhash.c: typos involving USER_BLOCK keywords corrected. + (the use of USER_BLOCKs is discouraged). +14. New intrinsic variable: _slang_doc_dir. This specifies the + installation location of the doc files. +15. Make sure it can compile with SLTT_HAS_NON_BCE_SUPPORT set to 0. + +Changes since 1.4.0 +1. slw32tty.c: `v' key was not being handled on win32 systems. Also, + Shift-TAB will now generate ^@-TAB. +2. New intrinsic function: strreplace. This is more flexible than + str_replace. +3. VMSMAKE.COM: slstring added to list of files to get compiled. +4. slsh/Makefile, modules/Makefile: added patch from Jim Knoble + to create elf versions (make ELF=elf). +5. AIX IBMC patches from Andy Igoshin . +6. autoconf/config.sub: tweaked to properly handle recent alpha + systems. +7. If compiling on an alpha, add -mieee compiler flags. +8. SLang_roll_stack and SLang_reverse_stack functions made public. +9. SLang_free_function added. If you call SLang_pop_function, then when + finished, call SLang_free_function. This does nothing in 1.X but + may do something in 2.x. +10. src/slrline.c: Keybindings for ESC O A, etc added. +11. src/slsmg.c: SLsmg_write_nstring: avoid many loops if an extremely + large value is passed (> 0x7FFFFFFF). +12. src/slregexp.c made thread safe +13. src/slsmg.c: Cursor was not always properly positioned when + after SLsmg_touch_lines called. +14. If terminal does not have erase to eol capability, then use spaces. +15. doc/tm/strops.sl: doc for strcat updated to reflect its ability to + concatenate N strings. +16. Documentation updated to indicate that floating point range arrays + are open intervals such that [a:b] does not include b. slarray.c + was modified to enforce this specification. Previously, whether + or not b was included in the interval was indeterminate. +17. src/slsmg.c: bug involving SLsmg_set_screen_start fixed. +18. src/slparse.c: parser was failing to catch misplaced `}'. + +Changes since 1.3.10 +1. If a floating point exception occurs and the OS allows the library + to handle it without forcing a longjmp, then SL_FLOATING_EXCEPTION + will get generated instead of SL_INTRINSIC_ERROR. Note: Linux + provides no way to handle floating point exceptions without + forcing a longjmp. In my opinion, this is a flaw. +2. SLang_pop_double was returning the wrong value for short and + character types. +3. New intrinsic: is_struct_type(X) ==> non-zero is X is a struct. +4. typecast operation from user defined type to Struct_Type added. +5. slkeypad.c: DOS/Windows DELETE_KEY definition added (Doug Kaufman + ) +6. slposdir.c: Do not depend upon the existence of rmdir on VMS + systems. +7. slang.c: abs, sign, mul2, chs, sqr were not being treated as + function calls. +8. sldisply.c:SLtt_cls: If the terminal is a color terminal but + being used as a black and white terminal, then reset colors before + clearing. +9. path_sans_extname intrinsic added. +10. slimport.c: If module defines deinit_NAME, will be be called prior + to unloading the module. (Ulrich Dessauer ) + +Changes since 1.3.9 +0. typedef unsigned short SLsmg_Char_Type added to slang.h. + Applications that access SLsmg functions read/write_raw and + SLsmg_char_at should use SLsmg_Char_Type unstead of unsigned short + because this will be changed to unsigned long in version 2.0. + +1. Documentation patches from Vlad Harchev added. +2. slstring.c: offsetof(SLstring,bytes) --> + offsetof(SLstring,bytes[0]) to avoid compiler warning on some + systems. +3. slcmplex.c: an int was used where a double should have beed used. +4. egcs g++ was optimizing slang.c:SLclass_push_ptr_obj away because + it was declared as inline. In my opinion, this is another g++ bug. +5. sscanf intrinsic added. See docs. +6. SLmake_lut rewritten to correct incorrect handling of ranges with a + hyphen at the end. +7. Small bug involving non-BCE terminals in SLsmg_set_color_in_region + fixed. +8. Functions SLcomplex_asinh/acosh/atanh implemented. +9. install-elf will nolonger install .h files twice. +10. @Struct_Type may be used to create a struct. +12. X[i]++, X[i]-=Y, etc implemented. +13. Much of slw32tty.c rewritten to fix several bugs in the win32 tty + support. In addition, if SLgetkey_map_to_ansi(1) has been called, + then function and arrow keys will produce escape sequences that + allow one to distinguish alt, ctrl, and shift function keys. +14. OS/2 specific typo in slposdir.c corrected (Eddie Penninkhof + ). +15. slang.c:add_slang_function: On the very rare occasion that this + function failed, memory would get freed twice. + +Changes since 1.3.8 +1. Color was not enabled on VMS. +2. If MAKE_INTRINSIC was used to declare a function which takes + arguments, then a typecast error would result when the function was + called. New programs should not use MAKE_INTRINSIC since it + bypasses argument type-checking. +3. src/sl-feat.h: SLTT_XTERM_ALWAYS_BCE variable added to force the + assumption of the bce (background-color-erase) capability of xterm. + The default is 0, which means to accept the terminfo setting. + To force it to 1 during run-time, set the COLORTERM_BCE environment + variable. This is useful when using, e.g., rxvt to login to a + solaris system where the terminfo file will probably not indicate + bce. +4. SLw32tty.c:SLang_init_tty: Open CONIN$ instead of using + GetStdHandle. This is necessary if stdin has been redirected. +5. SLposdir.c: Stat structure contains new field `st_opt_attrs' that + may be used to contain system specific information that `struct + stat' does not provide. In particular, under win32, this field + contains the file attributes, e.g., whether or not a file is + hidden. +6. Appropriate typecasts added to avoid warnings on systems that do not + support `void *'. +7. Characters in the range 128-255 are allowed in identifiers. +8. Correction to the documentation for SLang_init_tty (Ricard Sierra + ). +9. SLANG_END_*_TABLE macros added to quiet silly egcs compiler warnings. +10. typo in sltime.c caused it not to compile under Ultrix. +11. Speed improvement of binary operations involving arrays, + particularly when used in conjunction with the __tmp function. +12. traceback messages include the filename containing the function +13. File local intrinsic variable `_auto_declare' added. If non-zero, + any undefined global variable will be given static scope. +14. __uninitialize intrinsic function added. +15. listdir was returning NULL on empty directories. It has been + changed to return String_Type[0]. It will return NULL upon error. +16. slang.h: if __unix is defined, then also define __unix__ (Albert + Chin-A-Young ). +17. foreach using extended to File_Type objects. See documentation. +18. Tweak to the inner-product operator such that if A is a vector, + and B is a 2-d matrix, then A will be regarded as a 2-d matrix + with 1 column. + +Changes since 1.3.7 +0. configure script updated to autoconf 2.13. If /usr/include/slang.h + exists, then the default prefix will be set to /usr. +1. Compile error fixed if _SLANG_HAS_DEBUG_CODE is 0. +2. Bug fix involving typecast(Array_Type, Any_Type). +3. __IBMC__ patches from Eddie Penninkhof . +4. If A = Assoc_Type[] (Any_Type array), then A[x] automatically + dereferences the Any_Type object. +5. Bug fixed involving Assoc_Type optimization cache. +6. Tweaks to SLtt_smart_puts for improved performace. +7. array_map modifed such that the first array in its argument list + controls the number of elements in the output array. This is a + backward compatible change and makes the function more flexible. +8. Additional tweaks to speedup array inary functions if + _SLANG_OPTIMIZE_FOR_SPEED > 1. +9. Patch from Thomas Henlich fixing + a problem with the `SLang_define_case' function, which allows + customization of the upper/lower case tables. +10. strtrans and str_delete_chars intrinsic functions added. +11. tweaks to interpreter for some additional speed. + +Changes since 1.3.6 +1. Added a modified version of a patch from Martynas Kunigelis + to allow writes to the lower left + corner. +2. SIZEOF_LONG changed to 4 for VMS alpha systems (Jouk Jansen + ). +3. MSC patches from gustav@morpheus.demon.co.uk (Paul Moore). He also + contributed code for listdir with MSC. +4. SLsmg.c: Background color erase tweaks for terminals that lack this + capability. +5. Fixed a NULL pointer dereference when doing Struct_Type[2][0]. +6. Added slsh/scripts/ls and slsh/scripts/badlinks. `ls' is designed + for non-Unix systems and `badlinks' finds all symbolic links in + specified directories that point to non-existent files. +7. SLang_Version_String and intrinsic variable _slang_version_string + added. +8. stat_file modified under win32 such that a trailing `\' is stripped + if present. +9. stat_is intrinsic modified to return a character instead of an + integer. +10. The matrix-multiplication operator `#' now performs inner-products + on arrays, e.g., if A and B arrays: + A = A_i..jk + B = B_kl..m + Then, (A#B)_i..jl..m = A_i..jk B_kl..m where k is summed over. + This means that `#' is a matrix multiplication operator for 2-d + arrays, and acts as a dot-product operator for 1-d arrays. + In the process, it has been extended to complex numbers. + +11. _reshape intrinsic function added. Unlike `reshape', this + function creates a new array and returns it. +12. Array indexing via characters works again, e.g., A['a']. + +Changes since 1.2.2 +0. New assignment operators: *= /= &= |= + The addition of these operators meant that some of the internal + byte-codes had to be modified. This change should only cause + problems with byte-compiled or preprocessed .sl files. As far as I + know, only the JED editors uses this feature. So, after upgrading + the library, and before running JED, do the equivalent of + + rm $JED_ROOT/lib/*.slc + + That is, delete the byte-compiled .slc files. + +1. Now the language supports `!if ... else' statements. +2. New intrinsics: + + __is_initialized: This may be used to see whether or + not a variable is initialized, e.g, __is_initialized (&variable); + __get_reference: Returns a reference to an object with a + specified name. + rmdir, rename, remove (slfile.c): these return 0 upon success, -1 upon + failure and set errno + getpid, getgid, getppid (slunix.c) + _typeof: This is similar to `typeof' except in the case of + arrays where it returns the data type of the array + __pop_args, __push_args: see documentation + fseek, ftell, and symbolic constants SEEK_END, SEEK_CUR, SEEK_SET + sleep + usage + +3. `Conj' function added to get the complex conjugate +4. New array module that implementes additional array functions, e.g., + transpose, matrix multiplication, etc... Use `SLang_init_array' to + initialize. +5. An array such as [[1,2,3],[4,5,6]] is interpreted as a 2-row + 3-column array. +6. Amiga patches from Jörg Strohmayer . +7. New table types: + + SLang_IConstant_Type + SLang_DConstant_Type + + These are useful for defining symbolic constants. See slmath.c and + slfile.c for examples of their use. + +8. A new pseudo-function: __tmp + This `function' takes a single argument, a variable, and returns + the value of the variable, and then undefines the variable. For + example, + + variable x = 3; + variable y; + y = __tmp(x); + + will result in `y' having a value of `3' and `x' will be undefined. + The purpose of this pseudo-function is to free any memory + associated with a variable if that variable is going to be + re-assigned. For example, consider: + + variable x = [1:10:0.1]; + x = 3*x^2 + 2; + + At the time of the re-assignment of `x' in the last statement, two + arrays will exist. However, + + x = 3*__tmp(x)^2 + 2; + + results in only one array at the time of the assignment, because + the original array associated with `x' will have been deleted. This + function is a pseudo-function because a syntax error results if + used like + + __tmp (sin(x)); + +9. New low-level push/pop functions that are designed specifically + for use in constructing the push/pop methods of application + defined data types. These functions have names of the form: + + SLclass_push_*_obj + SLclass_pop_*_obj + + where * represents int, long, char, short, ptr, double, float. + See sltypes.c to see how they are used by, e.g., SLANG_INT_TYPE. + +10. New module import facility. See modules subdirectory for + examples. To enable this, use + + SLang_init_module + + in you application. Modules will be searched in the following order + + 1. Along the path specified by the `set_import_module_path' + function, or by the C functiion SLang_set_module_load_path. + 2. Along the path given by the SLANG_MODULE_PATH environment + variable. + 3. Along a system dependent path, e.g., LD_LIBRARY_PATH + 4. In the current directory. + + New interpreter intrinsics include: + + import (String_Type MODULE_NAME); + set_import_module_path (String_Type PATH); + String_Type get_import_module_path (); + +11. New integer and floating point types added to the language. Now + all basic C signed and unsigned integer types are supported: + + C bindings S-Lang bindings + --------------------------------------- + SLANG_CHAR_TYPE Char_Type + SLANG_UCHAR_TYPE UChar_Type + SLANG_SHORT_TYPE Short_Type + SLANG_USHORT_TYPE UShort_Type + SLANG_INT_TYPE Int_Type + SLANG_UINT_TYPE UInt_Type + SLANG_LONG_TYPE Long_Type + SLANG_ULONG_TYPE ULong_Type + SLANG_FLOAT_TYPE Float_Type + SLANG_DOUBLE_TYPE Double_Type + + For example, `Long_Type[10]' creates an array of 10 longs. + +12. New intrinsic: set_struct_field. See function reference for more + info. + +----- snapshot slang1.3_981030 made available ----- + +13. Type synonyms added: + + Int16_Type, UInt16_Type (16 bit (un)signed integer) + Int32_Type, UInt32_Type (32 bit (un)signed integer) + Int64_Type, UInt64_Type (64 bit (un)signed integer) + Float32_Type (32 bit float) + Float64_Type (64 bit float) + + Not all systems support 64 bit integers. These synonyms are + useful when one needs integers and floats of a definite size. + +14. array_sort changed to use qsort. The main reason for this is that + the previous sorting method was derived from a numerical recipes + merge sort. + +15. New namespace manipulation functions available. When a function + or variable is declared as `static', it is placed in the private + namespace associated with the object being parsed (a file). By + default, there is no way of getting at that function or variable + from outside the the file. However, the private namespace may be + given a name via the `implements' function: + + implements ("A"); + + Then the private variables and functions of the namespace A may be + accessed via A->variable_name or A->function_name. The default + global namespace is called `Global'. For example, the intrinsic + function `message' is defined in the global namespace. One may + use either of the following forms to access it: + + message ("hello"); + Global->message ("hello"); + +----- snapshot slang1.3_981104 made available ----- + +16. New intrinsics: + + strtok (See documentation) + length (Get the length of an object) + +17. New data type added: Any_Type. An array of such a type is capable + of holding any object, e.g., + + a = Any_Type [3]; + a[0] = 1; a[1] = "string"; a[2] = (1 + 2i); + + Dereferencing an Any_Type object returns the actual object. That + is, @a[1] produces "string". + +18. Associative arrays added. See documentation. +19. New `foreach' statement. See the section on `foreach' in + doc/text/slang.txt as well as the examples in examples/assoc.sl + and src/calc.sl. +20. Oops. sign function was broken. +21. array_sort modified to also accept &function_name. + +----- snapshot slang1.3_981116 made available (1.3.4) ----- + +22. Before, it was necessary for the aplication to to call + SLang_init_slassoc to enable associative array support. This is + nolonger necessary if associative array support is enabled in + sl-feat.h. + +23. Examples in the documentation modified to use foreach whenever a + simplification occurred. + +24. Max screen size for 32 bit systems inclreased to 256 rows. + +25. `private' keyword added to prevent access to an object via the + namespace. This works exactly like `static' except that `static' + objects may be accessed via the namespace. + +26. structure access methods now available for application defined + types (cl_sput, cl_sget). Also, note that array access methods + are also available. See slassoc.c for examples. + +27. If x is a string, then x[[a:b]] produces a string composed of the + characters x[a], ... x[b]. + +29. New intrinsics: + + listdir: This returns the filenames in a specified + directory as an array of strings. + +30. Source code for intrinsic functions reorganized in a more coherent + fashion. In particular, SLang_init_slfile and SLang_init_slunix + are obsolete (though still available) and applications should call + a combination of the new functions: + + SLang_init_stdio() /* fgets, fopen, ... */ + SLang_init_posix_process () /* getpid, kill, ... */ + SLang_init_posix_dir () /* mkdir, stat, ... */ + + Note that `unix_kill' has been replaced by `kill'. So, if you use + unix_kill in your application, change it to `kill'. + +31. It is now safe to redefine an object while executing the object, + e.g., this is now ok: + + define f(x) { eval ("define f(x) { return x; }"); } + +32. Binary strings added. This means that it is now possible to use + strings with embedded null characters. Too fully exploit this new + feature, `fread' and `fwrite' functions were added to the stdio + module. In addition `pack', `unpack', `sizeof_pack', + `pad_pack_format' were added for converting between binary strings + and other data types. See Stdio chapter of the documentation for + more information. + +33. New structure intrinsic: set_struct_fields. This is useful for + setting the fields of a structure without doing each one + individually. + +34. Interpreter now understands __FILE__ and __LINE__ as referring to + the file name and line number of the object being parsed. + +35. New intrinsic: array_map. This applies a function to each element + of an array and returns the result as an array. + +36. The documentation for the intrinsic functions has been updated and + organized into a more coherent form. + +37. New interface to C structures. See the documentation. + +38. Modifications to the interpreter integer types so that short and + int are equivalent whenever sizeof(short)==sizeof(int). Ditto for + int and long. This reduces the code size. + +39. NULL is equivalent to 0 in while and if statements, e.g., + + x = NULL; + if (x) { never_executed (); } + while (x) { never_executed (); } + +40. `public' made a keyword to for symmetry with `private' and + `static', e.g., + + public define a_public_function (); + public variable a_public_variable; + +41. semantics of `implements' modified such that the default variable + and function declarations are `static', i.e., + + define xxx (); % ==> public function + implements ("foo"); + define yyy (); % ==> static function + +42. Patch from Martynas Kunigelis adding more + line and symbol drawing characters. Also a patch from + k-yosino@inatori.netsweb.ne.jp forcing a flush when disabling + use of the terminal's status line. + +--- Version 1.3.5 released --- + +43. Corrected the name of SLang_(sg)et_array_element to be consistent + with the documentation. + +44. Fixed a bug involving orelse and andelse statements when + _debug_info is non-zero. + +45. The _apropos intrinsic modified to work with namespaces. In fact, + it now returns an array of matches, or if called with out a + namespace argument, it returns values to the stack for backward + compatibility. + +46. strchop and strchopr functions modified to return arrays. (this + changes was actually made in 1.3.5). + +47. Semantics of strcompress modified to be more useful. The new + semantics are probably more natural and should pose no + compatibility problems. + +48. The `*' operator may be used in array index expressions and is + equivalent to `[:]', e.g., a[*,1] means all elements in column 1 + of the 2d array. + +49. New intrinsics to convert bstrings <--> arrays: + + bstring_to_array + array_to_bstring + +50. New timing intrinsics: tic(); toc(); times (); Also, unix_ctime + renamed to ctime (This change occurred in 1.3.5). + +51. strcat modified to accept more than 2 arguments: + + strcat ("a", "b", ..., "c") ==> "ab...c"; + +52. %S in format specifiers will convert the object to its string + representation and use it as %s. + +53. strtok defaults to using " \t\r\n\f" if called with one argument. + +54. fgetslines takes optional second argument that specifies the + number of lines to read. + +55. If typeof(A) is IStruct_Type, and the corresponding C pointer is + NULL, then pushing A will result in pushing NULL. This allows A + to be compared to NULL. + +56. More optimization of arithmetic operations to improve speed. My + tests indicate that the resulting code involving arithmetic + operations are about twice as fast as python (1.5) and about 20% + faster than perl 5. + +57. Patches from Andreas Kraft disabling the + listdir intrinsic function if compiled with MSC. Apparantly, the + MSC compiler does not support posix functions such as opendir + (although other vendors, e.g, Borland, have no problem with this). + +58. `array_sort' intrinsic may be used without a comparison function. + See docs. + +59. Spelling errors in slang.tm corrected by Uichi Katsuta + (Thanks!). + +60. Default install prefix changed from /usr to /usr/local + +61. Changes made to SLtt/SLsmg code so that when a color definition is + made via, e.g., SLtt_set_color, then the SLsmg interface will be + get automatcally notified so that the next SLsmg_refresh will + produce the correct colors. In addition, SLsmg_touch_screen added. + +62. It is now possible to evaluate S-Lang expressions with the + S-Lang preprocessor e.g., + + #ifeval (_slang_version > 9900) || (x == 1) + +63. sl-feat.h: Patch from Jörg Strohmayer to define + _SLANG_MAP_VTXX_8BIT=1 for AMIGA. + +64. New intrinsics: + strjoin. This joins elements of a string array. + localtime, gmtime + +65. New SLsmg function: SLsmg_reinit_smg. Instead of calling + SLsmg_reset_smg followed immediately by SLsmg_init_smg when + processing SIGWINCH signals, call SLsmg_init_smg instead. This + will allow SLsmg based code to properly redraw themselves when + running in a SunOS cmdtool window by working around a bug in + cmdtool. + +=========================================================================== + +Changes since 1.2.1 + 1. slcmd.c was not parsing characters in single quotes correctly, + e.g., 'a'. + +Changes since 1.2.0 + 1. Oops. A NULL pointer could be referenced in slcmd.c. + +Changes since 1.0.3 beta + +-1. The SLKeyMap_List_Type structure has been modified to allow the + name of the keymap be be an arbitrary length. Unfortunately, this + change breaks backward compatibility. So, if you have programs + ^^^^^^^^^^^^^^^^^^^^ + that are dynamically linked to previous BETA versions of 1.0, you + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + will have to recompile those applications!!! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +0. The variable SLsmg_Newline_Moves has been renamed to + SLsmg_Newline_Behavior with the following interpretation: +#define SLSMG_NEWLINE_IGNORED 0 /* default */ +#define SLSMG_NEWLINE_MOVES 1 /* moves to next line, column 0 */ +#define SLSMG_NEWLINE_SCROLLS 2 /* moves but scrolls at bottom of screen */ +#define SLSMG_NEWLINE_PRINTABLE 3 /* prints as ^J */ + +1. Added patches from Joao Luis Fonseca + to src/mkfiles/makefile.all and a necessary OS/2 specific + declaration to slvideo.c. I also added the Watcom patches from + Bill McCarthy to makefile.all. +2. The terminfo code is now aware of the complete set of terminfo + definitions. However, the screen management routines support a + small subset. (Eric W. Biederman ). +3. Improvements to the SLsmg scrolling alogorithm. +4. SLang_process_keystring and SLang_make_keystring now return NULL upon + failure. +5. SLcomplex_sqrt branch cut modifed to be consistent with FORTRAN. +6. If the system supports vsnprintf and snprintf, they are used. The + assumption is that they return EOF upon failure. My linux man page + for these functions have conflicting statements regarding this. + +7. Simplified handling of memory managed types. Now it is possible to + pass the managed object directly to the intrinsic function. See + slfile.c for an explicit example of this technique. Similarly, + references may also be passed and the function SLang_assign_to_ref + may be used to assign values to the referenced object. This is + also illustrated in slfile.c. + +8. QNX specific tweak to slfile.c from Pavanas Abludo Incusus + . + +9. Fixed a problem where, e.g., + + x = Double_Type [7,8,9]; + y = x[0,[:],[:]]; + + returned y = Double_Type[8*9] instead of the more intuitive result + Double_Type[8,9]; + +10. SLcmd_Cmd_Table_Type structure changed to permit an unlimited + number of arguments. The changed should be backward compatible + except that a recompilation of the application will be necessary. +11. New SLsmg function: SLsmg_set_color_in_region may be used to set + the color of a specified region. See demo/smgtest.c for an + example of how this is used. Another use would be to draw shadows + around a box. +12. OS2 ICC patches from Eddie Penninkhof . +13. Grammar tweaked to make the pow (^) operator postfix-unary. This + makes more sense mathematically so that: + + a^b^c ==> a^(b^c); + -(a)^b ==> -(a^b); + +14. New struct specific intrinsics: + + get_struct_field_names + get_struct_field_value + _push_struct_field_values + + See function reference for more information on these. + +Changes since 1.0.2 beta +0. SLtt_init_video, SLtt_reset_video, SLsmg_resume_smg, + SLsmg_suspend_smg have been modifed to return 0 upon success, or -1 + upon error. +1. Configure script modified to report slang version as 1.0.x instead + of 1.0.0x. +2. Bug fix involving automatic detection of color (Unix) +3. slvideo.c bug fixed (WIN32, Thanks Chin Huang ) +4. Slsignal modified so that fork is not used for CYGWIN32, suggested + by vischne@ibm.net. +5. Solaris ELF patches integrated into configure.in. Now ELF support + is available for Linux and Solaris. Thanks Jan Hlavacek + . +6. The library now works with MING32 and should work with CYGWIN as + well. See INSTALL.pc and src/mkfiles/README for more information. + Do NOT use the configure script under these environments. +7. A new IBMPC_SYSTEM function added that affects WIN32, MSDOS, and + OS/2 systems: + + SLang_getkey_map_to_ansi (int enable); + + If `enable' is non-zero, arrow and function keys will be mapped to + the ansi equivalents. +8. The WIN32 terminal support has been modified to be more consistent with + the other platforms. In particular, mouse button press reporting + has been added (SLtt_set_mouse_mode), and bright color support + appears to have been fixed. Note: For MINGW32 and CYGWIN32, use + src/mkfiles/makefile.all. Do not use the Unix configure script + because WIN32 is NOT Unix. +9. Several changes to slvideo.c that deals with the proper use of the + scroll region for DOS/Windows type systems. +10. demo/smgtest.c has been enhanced. +11. Some cleanup performed to src/slprepr.c +12. WIN32 and WIN16 preprocessing symbols are defined when appropriate. + + +Changes since 1.0.1 beta +1. More VMS patches. Thanks Andy. + +Changes since 1.0.0 beta +1. Fixed a bug in the automatic detection of color terminal +2. Patches to get it to compile on OS2 and VMS +3. Replaced \r\n in slarray.c with \n + +Changes since 0.99-38 +0. Many, many changes to the interpreter. See documentation. + +1. SLang_free_intrinsic_user_object shortened via define on VMS. +2. Make sure slang.h does not defined REAL_UNIX_SYSTEM on OS/2. +3. New search paths for termin directories include $HOME/.terminfo and + /usr/share/terminfo. +4. SLsystem function added. This is a replacement for `system'. It + implements POSIX semantics for POSIX systems. Although Linux + claims to be a POSIX system, it's `system' routine is broken. +5. color names color0 ... color7, brightcolor0, ... brightcolor7 + added for Unix and VMS systems. + +Changes since 0.99-37 +1. SLang_input_pending returns -1 if Ctrl-Break pressed (DOS specific). +2. SLtty_VMS_Ctrl_Y_Hook added for Ctrl-Y trapping. Keep in mind that + this is called from an AST. +3. Documentation updates +4. Fixed bug dealing with keymaps with escape sequences involving + characters with the high bit set. +5. slkeypad code ported to DOS +6. SLsmg_write_raw and SLsmg_read_raw functions added. +7. Compilation error under QNX fixed. +9. Small change involving SLang_flush_input. + + +Changes since 0.99-36 +1. Oops fixed a bug in alternate character set handling when + SLtt_Use_Blink_For_ACS is set. This bug only affected DOSEMU. +2. slvideo.c modification that affects DJGPP version of library. Now + the screen is saved and restored. +3. Updates to slcurses.c by Michael Elkins. +4. If a color called `default' is specified, the escape sequence to + set the default color will be sent. Be careful, not all terminals + support this feature. If your terminal supports it, e.g., rxvt, + then using + + setenv COLORFGBG default + + is a good choice. + +Changes since 0.99-35 +1. Fixed alt char set bug introduced in 0.99-35. +2. New intrinsic: _stk_reverse +3. New demos: keypad, smgtest, pager +4. The environment variable COLORFGBG may be used to specify default + foreground background colors, e.g., in csh use: + + setenv COLORFGBG "white;black" + + to specify white on black as the default colors. This also means + that a color name of NULL or the empty string "" will get mapped to + the default color. +5. Improved curses emulation provided by Michael Elkins + (me@muddcs.cs.hmc.edu). +6. Small bug fix to SLang_flush_output provided by Balakrishnan k + . +7. Updated some documentation in doc/cslang.tex (Gasp). +8. Update vmsmake.com file provided by Martin P.J. Zinser + (m.zinser@gsi.de). + +Changes since 0.99-34 +0. OS/2 video problem solved by Rob Biggar (rb14@cornell.edu). + +1. The way the interpreter internally handles strings has changed. + This should not affect programs which utilize the library. Now all + strings returned by the function SLang_pop_string should be freed + after use. The SLang_pop_string function will always set the value + of the second parameter passed to it to a non-zero value. For this + reason, programs should use the new function SLpop_string and + always free the string returned by it after use. + +2. If SL_RLINE_NO_ECHO bit is set in the readline structure, the + user response will not be echoed. + +3. If terminal is xterm, the TERMCAP environment variable will be + ignored. This change was necessary because of the braindead + TERMCAP setting created by the latest version xterm. + +4. Some of the keymap routines were re-coded. Now it is possible to + have lowercase characters as part of the prefix character sequence. + +5. New modules. See demo/pager.c for information. See also the slrn + source code for a more sophisticated use. + + SLscroll: may be useful for routines that deal with displaying + linked lists of lines. + SLsignal: POSIX signal interface for programs that use SLsmg and + SLtt modules. doc/signal.txt may also prove useful. + SLkeypad: Simplified interface to SLang keymaps. + SLerrno: System independ errno routines + +Changes since 0.99-33 +1. A couple of interpreter bug fixes. + +2. Some macros, e.g., MEMSET, removed from slang.h. I do not feel + that they belong there and it is unlikely that they are used by + others. I made them avalable in the file src/jdmacros.h for anyone + whose code depends on them. + +3. The functions jed_mem??? have been renamed to SLmem???. + +4. New intrinsic: _obj_type returns type information about object on top + of stack. + +Changes since 0.99-32 +1. appropriate header files added for VMS +2. Oops. 0.99-32 introduced a bug positioning cursor. :( + +Changes since 0.99-31 +1. Simple minded curses emulation added. This should help those migrating + from curses. See slang/src/curses/*.c for sample curses demo programs + that the SLsmg routines can handle. See also slang/src/slcurses.c for + some wrapper functions. +2. Changed to "config.h" in all source files. +3. If system lacks terminfo directories, it is compiled with termcap + support. This generalizes and replaces the test for NeXT. +4. New functions for slang/src/sldisply.c: + + void SLtt_get_screen_size (void); + SLtt_Char_Type SLtt_get_color_object (int); + void SLtt_set_color_fgbg (int, SLtt_Char_Type, SLtt_Char_Type); + + The first function attempts to deduce the correct values of + SLtt_Screen_Rows and SLtt_Screen_Cols. This function is called by + sltt_get_terminfo. + + New constants such as SLSMG_COLOR_BLACK, SLSMG_COLOR_RED, ... have been + added to slang.h to facilitate the use of SLtt_set_color_fgbg. + +5. Improved error messages +6. ELF support. Do: make elf; make install-elf + +Changes since 0.99.30 + +1. Small bug fixed that affects 64 bit machines with a certain byte + ordering. +2. slutty.c: _POSIX_VDISABLE is used if defined. + +Changes since 0.99.29 + +0. BIG change in handling keymaps. Specifically, this change effects the + change of the `f' field of the SLang_Key_Type structure. Before, this + was VOID_STAR, now it is a union. The new change is much more portable. + In addition, the function `SLang_define_key1' has been removed and + replaced by `SLkm_define_key'. See src/slrline.c for the use of this new + interface. For a short time, the old interface will be available if the + preprocessor symbol `SLKEYMAP_OBSOLETE' is defined when slang is compiled. + See jed and slrn source for more examples. + +1. SLang_getkey now reads from /dev/tty (unix). +2. If the first argument to SLang_init_tty is -1, the current value of the + interrupt character will not be changed (unix). +3. New intrinsic: time +Changes since 0.99.28 +1. Oops! Horrible bug in src/slmemcmp fixed. +2. slvideo: init_video modified to be more consistent with VMS/Unix routine. + +Changes since 0.99.27 +1. More changes to the configure script +2. It looks like hpterm support is in place. This terminal has a glitch + that prevents efficient screen updating. +3. New SLsmg function: + + void SLsmg_write_color_chars (unsigned short *s, unsigned int len) + + This function may be used to write a string of characters with + attributes. + +Changes since 0.99.26 +1. Slang now uses a configure script under Unix to configure itself. +2. New intrinsic functions include _stk_roll, strchop, strchopr. +3. Terminals which require an escape sequence to make their arrow keys work + are now sent the escape sequence. + +Changes since 0.99.25 +1. New SLsmg variables: + SLsmg_Newline_Moves + SLsmg_Backspace_Moves + These variables control the interpretation of newline and backspace + characters in smg. + +Changes since 0.99.24 +1. SLSMG_RTEE_CHAR, etc... added to OS/2 part of slang.h +2. Small fix for aix-term + +Changes since 0.99.23 +0. The makefile for unix has been completely re-written. +1. Some problems dealing with certain color terminals have been resolved. +2. `g' generic type added to SLcmd. + +Changes since 0.99.22 +0. The Macro `VOID' has been removed. The whole point of this macro was to + mimick `void *' declarations for compilers that did not support such a + construct. Instead of `VOID *', slang.h now defines `VOID_STAR' and all + `VOID *' declarations have been renamed to `VOID_STAR'. + + If you use the VOID macro in your application, you have two choices: + + 1. Rename all occurances of VOID * to VOID_STAR + 2. Add: #define VOID void somewhere appropriate. + +1. \< and \> regular expressions added. + +Changes since 0.99.21 +1. Oops. I added too much linux stuff (see 3 below). Some of it backed + out to Linux only. + +Changes since 0.99.20 +1. Problem on some VMS systems which lack prototype for atof fixed. +2. New function: SLtt_set_mouse_mode. This is used to turn on/off mouse + reporting on Unix and VMS systems. +3. The terminal type `linux' is now recognized by the SLtt interface--- + even if there is no termcap/terminfo entry for it. + +Changes since 0.99.19 +1. User definable types must now have object identification numbers larger + than 127. The lower limit used to be 100 but this comflicts with many + applications (as well as slang itself) using lower case letters as the + object number, e.g., create_array ('s', 10, 1); which creates an array + of 10 strings (object number 's' = 115). + +2. New intrinsic: array_info available. +3. regular expression matching bug involving \{m,n\} expressions fixed. +4. New module: slprepr.c. This gives programs the ability to use the slang + preprocessor. +5. News slsmg functions: SLsmg_suspend_smg () and SLsmg_resume_smg (). + These are designed to be used before and after suspension. The SLsmg + state is remembered and a redraw is performed by the resume_smg function. +6. The function `sltty_set_suspend_state' is now available for Unix + systems. It may be used to turn on/off processing of the suspend + character by the terminal driver. +7. If SLtt_Try_Termcap is 0, the TERMCAP variable will not be parsed. +8. SLang_TT_Read_FD variable is now available for unix. This is the file + descriptor used by SLang_getkey. +9. New preprocessor symbols available: + SLMATH : If math functions are available + SLUNIX : If unix system calls are available + SLFILES : Stdio functions available + FLOAT_TYPE : Floating point version + +Changes since 0.99.18 +1. New intrinsic function: strcompress. This collapses a string by removing + repeated characters. For example, + + define collapse (f) + { + while (str_replace (f, " ", ",")) f = (); + return strcompress (f, ","); + } + + collapse (", ,a b c ,,,d e,f "); + + returns: "a,b,c,d,e,f" + +2. QNX support added. +3. New Functions (unix only): SLtt_tgetstr, SLtt_tgetnum, SLtt_tgetflag. +4. Fixed parsing of Octal and Hex numbers so that incorrect values are + flagged as errors. Also, both lower and uppercase values may be used in + HEX numbers, e.g., 0xa == 0XA == 0Xa == 0xA. +5. MS-Windows support added. Compile using makefile.msw. This creates + `wslang.lib'. +6. New SLsmg functions: SLsmg_get_row, SLsmg_get_column. These return the + current position. + +Changes since 0.99.17 +1. I have added limited termcap support although slang is still a terminfo + based system. The support is provided via the TERMCAP environment + variable. If this variable exists and contains a termcap entry for which + there is no reference to another entry (via tc field), it will be used + to setup the terminal. If the TERMCAP variable does not exist, or it + refers to a file, terminfo is used instead. This is not really a + limitation since one can set this variable in a way that slang likes by + using `tset -s'. + + The motivation for this support is two-fold: + a. Slang programs can now run inside the screen program which sets + the TERMCAP variable appropriately. + b. A user can now correct defective termcap entries (e.g., for Linux), + and have those corrections made available to slang via the `tset' + command, e.g., by putting something analogous to: + + setenv TERMCAP /corrected/termcap/file/absolute/path/name + eval `tset -s terminal-name` + + in the .login file. + c. This also means that I can distribute corrected termcap entries for + common terminals. + +Changes since 0.99.16 +1. Inadequate terminfo entries for `linux' terminal are compensated for. +2. Terminals with the ``Magic cookie glitch'' are flagged as having an + unusable highlighting mode. + +changes since 0.99.15 +1. Better checking of parameters passed to search routines. +2. Problem with line drawing characters fixed. + +changes since 0.99.14 +1. Ran code through purify. Fixed one problem reported in slkeymap.c +2. Fixed a bug in sldisply.c regarding mono-attributes. +3. Code ready for ELF +changes since 0.99.13 +1. SLtt_Has_Alt_Charset variable added to xterm.c. This is motivated by the + sad, pathetic fact that although some termcap/terminfo databases suggest + that the terminal can do line drawing characters, the terminal cannot. +2. SLsmg_write_nstring function added. This function may be used to write + only n characters of a string padding wit hblanks if necessary. +3. If the environment variable COLORTERM exist, SLtt_get_terminfo will set + SLtt_Use_Ansi_Colors to 1. +4. Sltt_set_cursor_visibility function added. If passed a zero integer value, + the cursor is hidden; otherwise, it is made visible. + +changes since 0.99.12 +1. SLsmg now uses the `te' and `ti' termcap entries if present. Apparantly + some terminals need to be put in cursor addressing mode. This also has + the effect of restoring the screen of the xterm to what it was before + the program was executed. +2. For some types of code, slang is 20% faster! This is especially + noticeable for branching constructs inside tight loops or recursive + functions. + +changes since 0.99.10 +1. New version control added: + + A new preprocessor symbol was added: SLANG_VERSION + This is a 6 digit integer of the form: abcdef + This corresponds to version number ab.cd.ef. So for version 0.99.11: + #define SLANG_VERSION 9911 + + In addition, the intrinsic variable `SLang_Version' was changed from a + string to an integer that has the value SLANG_VERSION. This also implies + that the interpreter variable _slang_version is now an integer. + +changes since 0.99.9 +1. The terminfo code failed to recognize the automatic margin flag. This + has been corrected. In addition, the display code nolonger resets the + character set upon initialization. This is considered to be a good thing. + +2. There is a new program in slang/doc called `texconv' that will produce a + nicely formatted ascii document from the tex formatted ones. In + addition, new documentation has been added: slang.tex which describes the + syntax of the slang programming language and cslang.tex which describes + the C interface to the library. The latter document is far from complete + but it is a start. + +3. A new variable declaration keyword has beed added: global_variable + This keyword is useful for declaring global variables from within + functions. Such a feature simplifies some scripts. + +4. The SLsmg line drawing functions are now in place. + +changes since 0.99.8 +1. \d may now be used in regular expressions to specify a digit. In addition, + \e specifies an escape character. So for example, `\e\[\d;\dH' matches + an ANSI cursor position escape sequence. +2. Small bug in dealing with terminals that have automatic margins has been + fixed. +3. When compiled with -DSLANG_TERMINFO will use terminfo. This means that + there is no need to link to termcap. + +changes since 0.99.7 +1. New function added to the readline package: + int SLang_rline_insert (char *s); + this may be used to stuff strings into the rline buffer. SLSC exploits + this feature. + +changes since 0.99.6 + +1. ALL macros beginning with LANG have been changed to use SLANG as the + prefix. For example, the macro LANG_IVARIABLE has been renamed to + SLANG_IVARIABLE. If you have used one of these macros, please make the + change. + +2. Application defined types. See demo/complex.c for an example that + defines complex numbers and overloads the binary and unary operators to + work with them. + +changes since 0.99.5 + + +1. New interface for application defined objects. Functions include: + + extern SLuser_Object_Type *SLang_pop_user_object (unsigned char); + extern void SLang_free_user_object (SLuser_Object_Type *); + extern void SLang_push_user_object (SLuser_Object_Type *); + extern SLuser_Object_Type *SLang_create_user_object (unsigned char type); + + + This means that S-Lang scripts do not have to worry about freeing + structures, arrays, etc... A consequence of this fact is that the + intrinsic function `free_array' has been removed. See examples of this + exciting new feature in slang/demo. + +2. Better documentation and examples. See slang/doc/*.* as well as examples + in slang/demo. + +3. Memory allocation macros have changed from MALLOC to SLMALLOC, etc... + Applications are encouraged to use these rather than `malloc' because by + compiling your application AND the slang library with the -DMALLOC_DEBUG + will link in code that checks if you have corrupted memory, freed + something twice, etc... Use the function `SLmalloc_dump_statistics' for + a report of memory consumption by your program. + +changes since 0.99.4 +1. cleaned up the source some and I changed the names of the hooks + user_whatever to `SLang_User_Whatever'. This makes them more consistent + with other external functions and variables and helps avoid name space + pollution. +changes since 0.99.3 +* added screen management stuff +* added a new help file reader (see help directory) +* DOUBLE precision is now the default. I think that this makes more sense + for an interpreted langauge. +* searching routines added. +changes since 0.99.2 +* added low level tty support for VMS, DOS, and Unix +* slang readline added +* keymap support +* files restructured so that programs can link, say, the readline library + and not get the whole interpreter linked in. + +changes since 0.99.1 +* obscure bug in regular expression fixed +* optimizing performed for 10% speed increase in speed for some language + constructs + +changes since 0.99.0 +* semantics of the `switch' statement changed to be more C-like with the + addition of the `case' keyword. For example, one can write: + + switch (ch) + { case 'A': + something (); + } + { + case 'B': + something_else (); + } + { case 3.14: + print ("Almost PI"); + } + { case "hello": + print ("hi"); + } + + Note that one may mix data types without the possibility of a type + mismatch error. + +changes since 0.98: +* matrix package added. Currently only matrix multiplication and addition + is supported. More functions will be added (determinants, inverse, etc..) + This support is provided by the `init_SLmatrix ()' call. This support + provides the following S-Lang intrinsics: + + matrix_multiply, matrix_add + + +* New S-Lang core intrinsic: + + copy_array : copys the contents of one array to another + +changes since 0.97: + +* Double precision floating point supported. + Use the -DFLOAT_TYPE -DUSE_DOUBLE compiler flags to enable this. + Note that S-Lang does not support single precision and double precision + floating point number SIMULTANEOUSLY. You must choose one or the other + and stick with it! + +* Byte compiling is now more than simple preprocessing. This results in + about a 20% decrease in loading time. This also means that if you + rebuild your application, you MUST re-bytecompile. + +* New syntax added: Consider a function f that returns multiple values. + Then to assign these values to, say var_1, and var_2, simply write: + + (var_1, var_2) = f (); + + This is an alternative to: + + f (); =var_2; =var_1; + +Changes since 0.96: + + It is now possible to use short circuit boolean evaluation of logical + expressions is the `orelse' and `andelse' constructs. Previously, these + constructs were only available at the infix level. The new syntax looks + like (example taken from JED's rmail.sl): + + if (orelse + {re_bsearch("^\\CFrom:.*<\\(.+\\)>");} + {re_bsearch("^\\CReply-To: *\\([^ ]+\\) *");} + {re_bsearch("^\\CFrom:.*<\\(.+\\)>");} + {re_bsearch("^\\CFrom: *\\([^ ]+\\) *");} + {re_bsearch("^\\cFrom +\\([^ ]+\\) *");} + ) + { + from = rmail_complex_get_from(from); + } + + + Modified some of the array code to use handles to arrays instead of actual + arrays. This adds alot more protection for the use of arrays. The + downside is that there is a limit on the number of active arrays. This + limit has been set to a default value ot 256. An ``active'' array is an + array that has been created but not freed. + + Fixed a parse error that occurred when an `if' statement imediately follow + the `:' in a switch statement. + + putenv intrinsic added. + + EXIT_BLOCK: if an exit block is declared, it is called just before the + function returns to its caller. + +It is now possible to perform assignments in variable declaration +statements, e.g., + +variable i = 0, imax = 10, n = strlen (name); + +Condition compilation of S-Lang source possible. See .sl files in the jed +distribution. + +A bug which prevent assignment to a global C floating point variable was +fixed. + +Changes to `calc': + + `apropos' function added to calc.sl. For example, `apropos("str")' + creates a list of all intrinsic functions that contain the substring + "str" (strcmp, strcat, etc...) + + Command line arguments are now loaded as S-Lang source files. This makes + it possible to create a Unix executable such as: + + #! /usr/local/bin/calc + + define hello_world () { print ("hello world"); } + loop (10) hello_world (); + quit (); diff --git a/libslang/configure b/libslang/configure new file mode 100755 index 0000000..c2ea7b1 --- /dev/null +++ b/libslang/configure @@ -0,0 +1,2997 @@ +#! /bin/sh + + + + + + + + + + + + + + + + + +IEEE_CFLAGS="" + + + + + + + + + + + + + + + + + + + + + + + + + + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.13 +# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: +ac_default_prefix="/usr/local" +if test -f "/usr/include/slang.h"; then +ac_default_prefix="/usr" +fi + +ac_help="$ac_help + --enable-warnings turn on GCC compiler warnings" + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +# Initialize some other variables. +subdirs= +MFLAGS= MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} +# Maximum number of lines to put in a shell here document. +ac_max_here_lines=12 + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir="$ac_optarg" ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [same as prefix] + --bindir=DIR user executables in DIR [EPREFIX/bin] + --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] + --libexecdir=DIR program executables in DIR [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data in DIR + [PREFIX/share] + --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data in DIR + [PREFIX/com] + --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] + --libdir=DIR object code libraries in DIR [EPREFIX/lib] + --includedir=DIR C header files in DIR [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] + --infodir=DIR info documentation in DIR [PREFIX/info] + --mandir=DIR man documentation in DIR [PREFIX/man] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM + run sed PROGRAM on installed program names +EOF + cat << EOF +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +EOF + if test -n "$ac_help"; then + echo "--enable and --with options recognized:$ac_help" + fi + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir="$ac_optarg" ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir="$ac_optarg" ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir="$ac_optarg" ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir="$ac_optarg" ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir="$ac_optarg" ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir="$ac_optarg" ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir="$ac_optarg" ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir="$ac_optarg" ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.13" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +done + +# NLS nuisances. +# Only set these to C if already set. These must not be set unconditionally +# because not all systems understand e.g. LANG=C (notably SCO). +# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! +# Non-C LC_CTYPE values break the ctype check. +if test "${LANG+set}" = set; then LANG=C; export LANG; fi +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi +if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +ac_unique_file=src/slang.c + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +ac_exeext= +ac_objext=o +if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + +#AC_PREFIX_DEFAULT($MY_PREFIX_DEAULT) + +# Installation location + + +ac_aux_dir= +for ac_dir in autoconf $srcdir/autoconf; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { echo "configure: error: can not find install-sh or install.sh in autoconf $srcdir/autoconf" 1>&2; exit 1; } +fi +ac_config_guess=$ac_aux_dir/config.guess +ac_config_sub=$ac_aux_dir/config.sub +ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. + + +# Make sure we can run config.sub. +if ${CONFIG_SHELL-/bin/sh} $ac_config_sub sun4 >/dev/null 2>&1; then : +else { echo "configure: error: can not run $ac_config_sub" 1>&2; exit 1; } +fi + +echo $ac_n "checking host system type""... $ac_c" 1>&6 +echo "configure:606: checking host system type" >&5 + +host_alias=$host +case "$host_alias" in +NONE) + case $nonopt in + NONE) + if host_alias=`${CONFIG_SHELL-/bin/sh} $ac_config_guess`; then : + else { echo "configure: error: can not guess host type; you must specify one" 1>&2; exit 1; } + fi ;; + *) host_alias=$nonopt ;; + esac ;; +esac + +host=`${CONFIG_SHELL-/bin/sh} $ac_config_sub $host_alias` +host_cpu=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` +host_vendor=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` +host_os=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` +echo "$ac_t""$host" 1>&6 + + + +#These variable are initialized by JD init function +CONFIG_DIR=`pwd` +cd $srcdir +if test "`pwd`" != "$CONFIG_DIR" +then + { echo "configure: error: "This software does not support configuring from another directory. See the INSTALL file"" 1>&2; exit 1; } +fi +# Note: these will differ if one is a symbolic link +if test -f /usr/bin/dirname; then + JD_Above_Dir=`dirname $CONFIG_DIR` +else +# system is a loser + JD_Above_Dir=`cd ..;pwd` +fi +JD_Above_Dir2=`cd ..;pwd` + + +# Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:648: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="gcc" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:678: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_prog_rejected=no + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + break + fi + done + IFS="$ac_save_ifs" +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# -gt 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + set dummy "$ac_dir/$ac_word" "$@" + shift + ac_cv_prog_CC="$@" + fi +fi +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + if test -z "$CC"; then + case "`uname -s`" in + *win32* | *WIN32*) + # Extract the first word of "cl", so it can be a program name with args. +set dummy cl; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:729: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="cl" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + ;; + esac + fi + test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; } +fi + +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 +echo "configure:761: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +cat > conftest.$ac_ext << EOF + +#line 772 "configure" +#include "confdefs.h" + +main(){return(0);} +EOF +if { (eval echo configure:777: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + ac_cv_prog_cc_works=yes + # If we can't run a trivial program, we are probably using a cross compiler. + if (./conftest; exit) 2>/dev/null; then + ac_cv_prog_cc_cross=no + else + ac_cv_prog_cc_cross=yes + fi +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + ac_cv_prog_cc_works=no +fi +rm -fr conftest* +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +echo "$ac_t""$ac_cv_prog_cc_works" 1>&6 +if test $ac_cv_prog_cc_works = no; then + { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } +fi +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 +echo "configure:803: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 +cross_compiling=$ac_cv_prog_cc_cross + +echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 +echo "configure:808: checking whether we are using GNU C" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then + ac_cv_prog_gcc=yes +else + ac_cv_prog_gcc=no +fi +fi + +echo "$ac_t""$ac_cv_prog_gcc" 1>&6 + +if test $ac_cv_prog_gcc = yes; then + GCC=yes +else + GCC= +fi + +ac_test_CFLAGS="${CFLAGS+set}" +ac_save_CFLAGS="$CFLAGS" +CFLAGS= +echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 +echo "configure:836: checking whether ${CC-cc} accepts -g" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + echo 'void f(){}' > conftest.c +if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then + ac_cv_prog_cc_g=yes +else + ac_cv_prog_cc_g=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$ac_cv_prog_cc_g" 1>&6 +if test "$ac_test_CFLAGS" = set; then + CFLAGS="$ac_save_CFLAGS" +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi + +echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 +echo "configure:868: checking how to run the C preprocessor" >&5 +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then +if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + # This must be in double quotes, not single quotes, because CPP may get + # substituted into the Makefile and "${CC-cc}" will confuse make. + CPP="${CC-cc} -E" + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:889: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP="${CC-cc} -E -traditional-cpp" + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:906: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP="${CC-cc} -nologo -E" + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:923: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP=/lib/cpp +fi +rm -f conftest* +fi +rm -f conftest* +fi +rm -f conftest* + ac_cv_prog_CPP="$CPP" +fi + CPP="$ac_cv_prog_CPP" +else + ac_cv_prog_CPP="$CPP" +fi +echo "$ac_t""$CPP" 1>&6 + +if test $ac_cv_prog_gcc = yes; then + echo $ac_n "checking whether ${CC-cc} needs -traditional""... $ac_c" 1>&6 +echo "configure:949: checking whether ${CC-cc} needs -traditional" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_gcc_traditional'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_pattern="Autoconf.*'x'" + cat > conftest.$ac_ext < +Autoconf TIOCGETP +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "$ac_pattern" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_prog_gcc_traditional=yes +else + rm -rf conftest* + ac_cv_prog_gcc_traditional=no +fi +rm -f conftest* + + + if test $ac_cv_prog_gcc_traditional = no; then + cat > conftest.$ac_ext < +Autoconf TCGETA +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "$ac_pattern" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_prog_gcc_traditional=yes +fi +rm -f conftest* + + fi +fi + +echo "$ac_t""$ac_cv_prog_gcc_traditional" 1>&6 + if test $ac_cv_prog_gcc_traditional = yes; then + CC="$CC -traditional" + fi +fi + +echo $ac_n "checking for POSIXized ISC""... $ac_c" 1>&6 +echo "configure:995: checking for POSIXized ISC" >&5 +if test -d /etc/conf/kconfig.d && + grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1 +then + echo "$ac_t""yes" 1>&6 + ISC=yes # If later tests want to check for ISC. + cat >> confdefs.h <<\EOF +#define _POSIX_SOURCE 1 +EOF + + if test "$GCC" = yes; then + CC="$CC -posix" + else + CC="$CC -Xp" + fi +else + echo "$ac_t""no" 1>&6 + ISC= +fi + +echo $ac_n "checking for AIX""... $ac_c" 1>&6 +echo "configure:1016: checking for AIX" >&5 +cat > conftest.$ac_ext <&5 | + egrep "yes" >/dev/null 2>&1; then + rm -rf conftest* + echo "$ac_t""yes" 1>&6; cat >> confdefs.h <<\EOF +#define _ALL_SOURCE 1 +EOF + +else + rm -rf conftest* + echo "$ac_t""no" 1>&6 +fi +rm -f conftest* + + + +cat > conftest.$ac_ext <&5 | + egrep "yes" >/dev/null 2>&1; then + rm -rf conftest* + +cat >> confdefs.h <<\EOF +#define _HPUX_SOURCE 1 +EOF + +if test "$CC" = cc; then CC="cc -Ae"; fi + +fi +rm -f conftest* +echo $ac_n "checking C compiler that understands ANSI prototypes""... $ac_c" 1>&6 +echo "configure:1061: checking C compiler that understands ANSI prototypes" >&5 +cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + + echo "$ac_t""$CC looks ok. Good." 1>&6 +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + + echo "$ac_t""$CC is not a good enough compiler" 1>&6 + { echo "configure: error: Set env variable CC to your ANSI compiler and rerun configure." 1>&2; exit 1; } + +fi +rm -f conftest* + +echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 +echo "configure:1087: checking whether ${MAKE-make} sets \${MAKE}" >&5 +set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftestmake <<\EOF +all: + @echo 'ac_maketemp="${MAKE}"' +EOF +# GNU make sometimes prints "make[1]: Entering...", which would confuse us. +eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=` +if test -n "$ac_maketemp"; then + eval ac_cv_prog_make_${ac_make}_set=yes +else + eval ac_cv_prog_make_${ac_make}_set=no +fi +rm -f conftestmake +fi +if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then + echo "$ac_t""yes" 1>&6 + SET_MAKE= +else + echo "$ac_t""no" 1>&6 + SET_MAKE="MAKE=${MAKE-make}" +fi + +# Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1116: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_RANLIB="ranlib" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" +fi +fi +RANLIB="$ac_cv_prog_RANLIB" +if test -n "$RANLIB"; then + echo "$ac_t""$RANLIB" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# ./install, which can be erroneously created by make from ./install.sh. +echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 +echo "configure:1155: checking for a BSD compatible install" >&5 +if test -z "$INSTALL"; then +if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS=":" + for ac_dir in $PATH; do + # Account for people who put trailing slashes in PATH elements. + case "$ac_dir/" in + /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + # Don't use installbsd from OSF since it installs stuff as root + # by default. + for ac_prog in ginstall scoinst install; do + if test -f $ac_dir/$ac_prog; then + if test $ac_prog = install && + grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + : + else + ac_cv_path_install="$ac_dir/$ac_prog -c" + break 2 + fi + fi + done + ;; + esac + done + IFS="$ac_save_IFS" + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL="$ac_cv_path_install" + else + # As a last resort, use the slow shell script. We don't cache a + # path for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the path is relative. + INSTALL="$ac_install_sh" + fi +fi +echo "$ac_t""$INSTALL" 1>&6 + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + + +#Check these header since they cause trouble +for ac_hdr in \ +stdlib.h \ +unistd.h \ +memory.h \ +termios.h \ +malloc.h \ +locale.h \ +fcntl.h \ +sys/fcntl.h \ +sys/types.h \ +sys/wait.h \ +sys/utsname.h \ +sys/times.h \ + +do +ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +echo "configure:1226: checking for $ac_hdr" >&5 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:1236: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` + cat >> confdefs.h <&6 +fi +done + + +echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 +echo "configure:1264: checking for ANSI C header files" >&5 +if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +#include +#include +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:1277: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + rm -rf conftest* + ac_cv_header_stdc=yes +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "memchr" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "free" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. +if test "$cross_compiling" = yes; then + : +else + cat > conftest.$ac_ext < +#define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int main () { int i; for (i = 0; i < 256; i++) +if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); +exit (0); } + +EOF +if { (eval echo configure:1344: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +then + : +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_header_stdc=no +fi +rm -fr conftest* +fi + +fi +fi + +echo "$ac_t""$ac_cv_header_stdc" 1>&6 +if test $ac_cv_header_stdc = yes; then + cat >> confdefs.h <<\EOF +#define STDC_HEADERS 1 +EOF + +fi + +echo $ac_n "checking for mode_t""... $ac_c" 1>&6 +echo "configure:1368: checking for mode_t" >&5 +if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "(^|[^a-zA-Z_0-9])mode_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_mode_t=yes +else + rm -rf conftest* + ac_cv_type_mode_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_mode_t" 1>&6 +if test $ac_cv_type_mode_t = no; then + cat >> confdefs.h <<\EOF +#define mode_t int +EOF + +fi + +echo $ac_n "checking for pid_t""... $ac_c" 1>&6 +echo "configure:1401: checking for pid_t" >&5 +if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "(^|[^a-zA-Z_0-9])pid_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_pid_t=yes +else + rm -rf conftest* + ac_cv_type_pid_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_pid_t" 1>&6 +if test $ac_cv_type_pid_t = no; then + cat >> confdefs.h <<\EOF +#define pid_t int +EOF + +fi + +echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 +echo "configure:1434: checking for uid_t in sys/types.h" >&5 +if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "uid_t" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_uid_t=yes +else + rm -rf conftest* + ac_cv_type_uid_t=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$ac_cv_type_uid_t" 1>&6 +if test $ac_cv_type_uid_t = no; then + cat >> confdefs.h <<\EOF +#define uid_t int +EOF + + cat >> confdefs.h <<\EOF +#define gid_t int +EOF + +fi + + +ac_header_dirent=no +for ac_hdr in dirent.h sys/ndir.h sys/dir.h ndir.h +do +ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for $ac_hdr that defines DIR""... $ac_c" 1>&6 +echo "configure:1473: checking for $ac_hdr that defines DIR" >&5 +if eval "test \"`echo '$''{'ac_cv_header_dirent_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include <$ac_hdr> +int main() { +DIR *dirp = 0; +; return 0; } +EOF +if { (eval echo configure:1486: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + eval "ac_cv_header_dirent_$ac_safe=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_header_dirent_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_dirent_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` + cat >> confdefs.h <&6 +fi +done +# Two versions of opendir et al. are in -ldir and -lx on SCO Xenix. +if test $ac_header_dirent = dirent.h; then +echo $ac_n "checking for opendir in -ldir""... $ac_c" 1>&6 +echo "configure:1511: checking for opendir in -ldir" >&5 +ac_lib_var=`echo dir'_'opendir | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-ldir $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + LIBS="$LIBS -ldir" +else + echo "$ac_t""no" 1>&6 +fi + +else +echo $ac_n "checking for opendir in -lx""... $ac_c" 1>&6 +echo "configure:1552: checking for opendir in -lx" >&5 +ac_lib_var=`echo x'_'opendir | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lx $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + LIBS="$LIBS -lx" +else + echo "$ac_t""no" 1>&6 +fi + +fi + + +for ac_func in \ +memset \ +memcpy \ +putenv \ +getcwd \ +setlocale \ +tcgetattr \ +tcsetattr \ +cfgetospeed \ +sigaction \ +sigemptyset \ +sigprocmask \ +sigaddset \ +vfscanf \ +lstat readlink \ +kill \ +snprintf vsnprintf \ +getppid getegid geteuid getuid getgid setgid setpgid setuid \ +chown popen mkfifo \ +atexit on_exit umask uname \ +times gmtime \ +strtod \ +issetugid \ + +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +echo "configure:1620: checking for $ac_func" >&5 +if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +$ac_func(); +#endif + +; return 0; } +EOF +if { (eval echo configure:1648: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_$ac_func=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` + cat >> confdefs.h <&6 +fi +done + + +echo $ac_n "checking for acosh in -lm""... $ac_c" 1>&6 +echo "configure:1674: checking for acosh in -lm" >&5 +ac_lib_var=`echo m'_'acosh | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lm $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define HAVE_ACOSH 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi + +echo $ac_n "checking for asinh in -lm""... $ac_c" 1>&6 +echo "configure:1717: checking for asinh in -lm" >&5 +ac_lib_var=`echo m'_'asinh | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lm $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define HAVE_ASINH 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi + +echo $ac_n "checking for atanh in -lm""... $ac_c" 1>&6 +echo "configure:1760: checking for atanh in -lm" >&5 +ac_lib_var=`echo m'_'atanh | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lm $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define HAVE_ATANH 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi + + + +DYNAMIC_LINK_LIB="" +ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6 +echo "configure:1807: checking for dlfcn.h" >&5 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:1817: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + + cat >> confdefs.h <<\EOF +#define HAVE_DLFCN_H 1 +EOF + + echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6 +echo "configure:1839: checking for dlopen in -ldl" >&5 +ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-ldl $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + + DYNAMIC_LINK_LIB="-ldl" + cat >> confdefs.h <<\EOF +#define HAVE_DLOPEN 1 +EOF + + +else + echo "$ac_t""no" 1>&6 + + echo $ac_n "checking for dlopen""... $ac_c" 1>&6 +echo "configure:1884: checking for dlopen" >&5 +if eval "test \"`echo '$''{'ac_cv_func_dlopen'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char dlopen(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_dlopen) || defined (__stub___dlopen) +choke me +#else +dlopen(); +#endif + +; return 0; } +EOF +if { (eval echo configure:1912: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_func_dlopen=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_dlopen=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'dlopen`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define HAVE_DLOPEN 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi + + if test "$ac_cv_func_dlopen" != yes + then + echo "configure: warning: cannot perform dynamic linking" 1>&2 + fi + +fi + +else + echo "$ac_t""no" 1>&6 +fi + + + +ELFLIB="lib\$(THIS_LIB).so" +ELFLIB_MAJOR="\$(ELFLIB).\$(ELF_MAJOR_VERSION)" +ELFLIB_MAJOR_MINOR="\$(ELFLIB).\$(ELF_MAJOR_VERSION).\$(ELF_MINOR_VERSION)" + +case "$host_os" in + *linux* ) + DYNAMIC_LINK_FLAGS="-Wl,-export-dynamic" + ELF_CC="gcc" + ELF_CFLAGS="-O2 -fno-strength-reduce -fPIC" + ELF_LINK="gcc -shared -Wl,-soname#" + ELF_LINK_CMD="\$(ELF_LINK),\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS="\$(DL_LIB) -lm -lc" + CC_SHARED="gcc \$(CFLAGS) -shared -fPIC" + ;; + *solaris* ) + if test "$GCC" = yes + then + DYNAMIC_LINK_FLAGS="" + ELF_CC="gcc" + ELF_CFLAGS="-O2 -fno-strength-reduce -fPIC" + ELF_LINK="gcc -shared -Wl,-ztext -Wl,-h#" + ELF_LINK_CMD="\$(ELF_LINK),\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS="\$(DL_LIB) -lm -lc" + CC_SHARED="gcc \$(CFLAGS) -G -fPIC" + else + DYNAMIC_LINK_FLAGS="" + ELF_CC="cc" + ELF_CFLAGS="-K pic" + ELF_LINK="cc -G -h#" + ELF_LINK_CMD="\$(ELF_LINK)\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS="\$(DL_LIB) -lm -lc" + CC_SHARED="cc \$(CFLAGS) -G -K pic" + fi + ;; + # osr5 or unixware7 with current or late autoconf + *sco3.2v5* | *unixware-5* | *sco-sysv5uw7*) + if test "$GCC" = yes + then + DYNAMIC_LINK_FLAGS="" + ELF_CC="gcc" + ELF_CFLAGS="-O2 -fno-strength-reduce -fPIC" + ELF_LINK="gcc -shared -Wl,-h#" + ELF_LINK_CMD="\$(ELF_LINK),\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS= + CC_SHARED="gcc \$(CFLAGS) -G -fPIC" + else + DYNAMIC_LINK_FLAGS="" + ELF_CC="cc" + ELF_CFLAGS="-K pic" + # ELF_LINK="ld -G -z text -h#" + ELF_LINK="cc -G -z text -h#" + ELF_LINK_CMD="\$(ELF_LINK)\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS= + CC_SHARED="cc \$(CFLAGS) -G -K pic" + fi + ;; + *irix6.5* ) + echo "Note: ELF compiler for host_os=$host_os may not be correct" + echo "double-check: 'mode_t', 'pid_t' may be wrong!" + if test "$GCC" = yes + then + # not tested + DYNAMIC_LINK_FLAGS="" + ELF_CC="gcc" + ELF_CFLAGS="-O2 -fno-strength-reduce -fPIC" + ELF_LINK="gcc -shared -Wl,-h#" + ELF_LINK_CMD="\$(ELF_LINK),\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS= + CC_SHARED="gcc \$(CFLAGS) -shared -fPIC" + else + DYNAMIC_LINK_FLAGS="" + ELF_CC="cc" + ELF_CFLAGS="-K pic" # default anyhow + ELF_LINK="cc -shared -o #" + ELF_LINK_CMD="\$(ELF_LINK)\$(ELFLIB_MAJOR)" + ELF_DEP_LIBS= + CC_SHARED="cc \$(CFLAGS) -shared -K pic" + fi + ;; + *darwin* ) + DYNAMIC_LINK_FLAGS="" + ELF_CC="cc" + ELF_CFLAGS="$CFLAGS -O2 -fno-strength-reduce -fno-common" + ELF_LINK="cc -dynamiclib" + ELF_LINK_CMD="\$(ELF_LINK) -install_name \$(install_lib_dir)/\$(ELFLIB_MAJOR) -compatibility_version \$(ELF_MAJOR_VERSION) -current_version \$(ELF_MAJOR_VERSION).\$(ELF_MINOR_VERSION)" + ELF_DEP_LIBS="$LDFLAGS \$(DL_LIB)" + CC_SHARED="cc -bundle -flat_namespace -undefined suppress \$(CFLAGS) -fno-common" + ELFLIB="lib\$(THIS_LIB).dylib" + ELFLIB_MAJOR="lib\$(THIS_LIB).\$(ELF_MAJOR_VERSION).dylib" + ELFLIB_MAJOR_MINOR="lib\$(THIS_LIB).\$(ELF_MAJOR_VERSION).\$(ELF_MINOR_VERSION).dylib" + ;; + * ) + echo "Note: ELF compiler for host_os=$host_os may be wrong" + ELF_CC="$CC" + ELF_CFLAGS="$CFLAGS -fPIC" + ELF_LINK="$CC -shared" + ELF_LINK_CMD="\$(ELF_LINK)" + ELF_DEP_LIBS="\$(DL_LIB) -lm -lc" + CC_SHARED="$CC $CFLAGS -shared -fPIC" +esac + + + + + + + + + + + + + +case "$host_cpu" in + *alpha* ) + if test "$GCC" = yes + then + IEEE_CFLAGS="-mieee" + else + IEEE_CFLAGS="-ieee_with_no_inexact" + fi + ;; + * ) + IEEE_CFLAGS="" +esac + + +ELF_CFLAGS="$ELF_CFLAGS $IEEE_CFLAGS" +CFLAGS="$CFLAGS $IEEE_CFLAGS" + + +if test "X$libdir" != "X" +then + if test "X$RPATH" = "X" + then + +case "$host_os" in + *linux*|*solaris* ) + if test "X$GCC" = Xyes + then + if test "X$ac_R_nospace" = "Xno" + then + RPATH="-Wl,-R," + else + RPATH="-Wl,-R" + fi + else + if test "X$ac_R_nospace" = "Xno" + then + RPATH="-R " + else + RPATH="-R" + fi + fi + ;; + *osf*) + if test "X$GCC" = Xyes + then + RPATH="-Wl,-rpath," + else + RPATH="-rpath " + fi + ;; +esac + + if test "X$RPATH" != "X" + then + RPATH="$RPATH$libdir" + fi + else + RPATH="$RPATH:$libdir" + fi +fi + + +echo $ac_n "checking size of short""... $ac_c" 1>&6 +echo "configure:2123: checking size of short" >&5 +if eval "test \"`echo '$''{'ac_cv_sizeof_short'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_sizeof_short=2 +else + cat > conftest.$ac_ext < +#include +main() +{ + FILE *f=fopen("conftestval", "w"); + if (!f) exit(1); + fprintf(f, "%d\n", sizeof(short)); + exit(0); +} +EOF +if { (eval echo configure:2143: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +then + ac_cv_sizeof_short=`cat conftestval` +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_sizeof_short=0 +fi +rm -fr conftest* +fi + +fi +echo "$ac_t""$ac_cv_sizeof_short" 1>&6 +cat >> confdefs.h <&6 +echo "configure:2163: checking size of int" >&5 +if eval "test \"`echo '$''{'ac_cv_sizeof_int'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_sizeof_int=4 +else + cat > conftest.$ac_ext < +#include +main() +{ + FILE *f=fopen("conftestval", "w"); + if (!f) exit(1); + fprintf(f, "%d\n", sizeof(int)); + exit(0); +} +EOF +if { (eval echo configure:2183: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +then + ac_cv_sizeof_int=`cat conftestval` +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_sizeof_int=0 +fi +rm -fr conftest* +fi + +fi +echo "$ac_t""$ac_cv_sizeof_int" 1>&6 +cat >> confdefs.h <&6 +echo "configure:2203: checking size of long" >&5 +if eval "test \"`echo '$''{'ac_cv_sizeof_long'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_sizeof_long=4 +else + cat > conftest.$ac_ext < +#include +main() +{ + FILE *f=fopen("conftestval", "w"); + if (!f) exit(1); + fprintf(f, "%d\n", sizeof(long)); + exit(0); +} +EOF +if { (eval echo configure:2223: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +then + ac_cv_sizeof_long=`cat conftestval` +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_sizeof_long=0 +fi +rm -fr conftest* +fi + +fi +echo "$ac_t""$ac_cv_sizeof_long" 1>&6 +cat >> confdefs.h <&6 +echo "configure:2243: checking size of float" >&5 +if eval "test \"`echo '$''{'ac_cv_sizeof_float'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_sizeof_float=4 +else + cat > conftest.$ac_ext < +#include +main() +{ + FILE *f=fopen("conftestval", "w"); + if (!f) exit(1); + fprintf(f, "%d\n", sizeof(float)); + exit(0); +} +EOF +if { (eval echo configure:2263: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +then + ac_cv_sizeof_float=`cat conftestval` +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_sizeof_float=0 +fi +rm -fr conftest* +fi + +fi +echo "$ac_t""$ac_cv_sizeof_float" 1>&6 +cat >> confdefs.h <&6 +echo "configure:2283: checking size of double" >&5 +if eval "test \"`echo '$''{'ac_cv_sizeof_double'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_sizeof_double=8 +else + cat > conftest.$ac_ext < +#include +main() +{ + FILE *f=fopen("conftestval", "w"); + if (!f) exit(1); + fprintf(f, "%d\n", sizeof(double)); + exit(0); +} +EOF +if { (eval echo configure:2303: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +then + ac_cv_sizeof_double=`cat conftestval` +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_sizeof_double=0 +fi +rm -fr conftest* +fi + +fi +echo "$ac_t""$ac_cv_sizeof_double" 1>&6 +cat >> confdefs.h <&6 +echo "configure:2325: checking for Terminfo" >&5 +MISC_TERMINFO_DIRS="$FINKPREFIX/share/terminfo" +if test ! -d $MISC_TERMINFO_DIRS +then + MISC_TERMINFO_DIRS="" +fi + +JD_Terminfo_Dirs="/usr/lib/terminfo \ + /usr/share/terminfo \ + /usr/share/lib/terminfo \ + /usr/local/lib/terminfo \ + $MISC_TERMINFO_DIRS" + +TERMCAP=-ltermcap + +for terminfo_dir in $JD_Terminfo_Dirs +do + if test -d $terminfo_dir + then + echo "$ac_t""yes" 1>&6 + TERMCAP="" + break + fi +done +if test "$TERMCAP"; then + echo "$ac_t""no" 1>&6 + cat >> confdefs.h <<\EOF +#define USE_TERMCAP 1 +EOF + +fi + + +# Check whether --enable-warnings or --disable-warnings was given. +if test "${enable_warnings+set}" = set; then + enableval="$enable_warnings" + gcc_warnings=$enableval +fi + +if test -n "$GCC" +then + CFLAGS="$CFLAGS -fno-strength-reduce" + if test -n "$gcc_warnings" + then + CFLAGS="$CFLAGS -Wall -W -pedantic -Winline -Wmissing-prototypes \ + -Wnested-externs -Wpointer-arith -Wcast-align -Wshadow -Wstrict-prototypes" + # Now trim excess whitespace + CFLAGS=`echo $CFLAGS` + fi +fi + + + +#--------------------------------------------------------------------------- +# Set the source directory and object directory. The makefile assumes an +# abcolute path name. This is because src/Makefile cds to OBJDIR and compiles +# the src file which is in SRCDIR +#--------------------------------------------------------------------------- +SRCDIR=$CONFIG_DIR +if test "src" != "." +then + if test -z "src" + then + SRCDIR=$SRCDIR/src + else + SRCDIR=$SRCDIR/src + fi +fi + +OBJDIR=$SRCDIR/"$ARCH"objs +ELFDIR=$SRCDIR/elf"$ARCH"objs + + + + PROGRAM_HFILES="" + PROGRAM_OFILES="" + PROGRAM_CFILES="" + PROGRAM_OBJECTS="" + PROGRAM_ELFOBJECTS="" + PROGRAM_OBJECT_RULES="" + PROGRAM_ELF_ORULES="" + if test -z "src/modules.unx" + then + Program_Modules="" + else + comment_re="^#" + Program_Modules=`grep -v '$comment_re' src/modules.unx | awk '{print $1}'` + Program_H_Modules=`grep -v '$comment_re' src/modules.unx | awk '{print $2}'` + for program_module in $Program_H_Modules; do + PROGRAM_HFILES="$PROGRAM_HFILES $program_module" + done + fi + for program_module in $Program_Modules; do + PROGRAM_OFILES="$PROGRAM_OFILES $program_module.o" + PROGRAM_CFILES="$PROGRAM_CFILES $program_module.c" + PROGRAM_OBJECTS="$PROGRAM_OBJECTS \$(OBJDIR)/$program_module.o" + PROGRAM_ELFOBJECTS="$PROGRAM_ELFOBJECTS \$(ELFDIR)/$program_module.o" + done + + + for program_module in $Program_Modules; do + +PROGRAM_OBJECT_RULES="$PROGRAM_OBJECT_RULES +\$(OBJDIR)/$program_module.o : \$(SRCDIR)/$program_module.c \$(DOT_O_DEPS) \$("$program_module"_O_DEP) + cd \$(OBJDIR); \$(COMPILE_CMD) \$("$program_module"_C_FLAGS) \$(SRCDIR)/$program_module.c +" + + +PROGRAM_ELF_ORULES="$PROGRAM_ELF_ORULES +\$(ELFDIR)/$program_module.o : \$(SRCDIR)/$program_module.c \$(DOT_O_DEPS) \$("$program_module"_O_DEP) + cd \$(ELFDIR); \$(ELFCOMPILE_CMD) \$("$program_module"_C_FLAGS) \$(SRCDIR)/$program_module.c +" + + done + + +echo $ac_n "checking SLANG_VERSION""... $ac_c" 1>&6 +echo "configure:2442: checking SLANG_VERSION" >&5 +slang_version=`grep "^#define *SLANG_VERSION " $srcdir/src/slang.h | + awk '{ print $3 }'` +slang_major_version=`echo $slang_version | + awk '{ print int($1/10000) }'` +slang_minor_version=`echo $slang_version $slang_major_version | + awk '{ print int(($1 - $2*10000)/100) }'` +slang_mminor_version=`echo $slang_version $slang_major_version $slang_minor_version | + awk '{ print ($1 - $2*10000 - $3*100) }'` + +slang_minor_version="$slang_minor_version.$slang_mminor_version" +slang_version="$slang_major_version.$slang_minor_version" +echo "$ac_t""$slang_version" 1>&6 + + + + + + +subdirs="demo" + + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +(set) 2>&1 | + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote substitution + # turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + -e "s/'/'\\\\''/g" \ + -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' + ;; + esac >> confcache +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +DEFS=-DHAVE_CONFIG_H + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS </dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" + exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; + -version | --version | --versio | --versi | --vers | --ver | --ve | --v) + echo "$CONFIG_STATUS generated by autoconf version 2.13" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir +ac_given_INSTALL="$INSTALL" + +trap 'rm -fr `echo "Makefile:autoconf/Makefile.in src/Makefile slsh/Makefile modules/Makefile src/sysconf.h:src/config.hin" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +EOF +cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF +$ac_vpsub +$extrasub +s%@RPATH@%$RPATH%g +s%@SHELL@%$SHELL%g +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@FFLAGS@%$FFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@bindir@%$bindir%g +s%@sbindir@%$sbindir%g +s%@libexecdir@%$libexecdir%g +s%@datadir@%$datadir%g +s%@sysconfdir@%$sysconfdir%g +s%@sharedstatedir@%$sharedstatedir%g +s%@localstatedir@%$localstatedir%g +s%@libdir@%$libdir%g +s%@includedir@%$includedir%g +s%@oldincludedir@%$oldincludedir%g +s%@infodir@%$infodir%g +s%@mandir@%$mandir%g +s%@host@%$host%g +s%@host_alias@%$host_alias%g +s%@host_cpu@%$host_cpu%g +s%@host_vendor@%$host_vendor%g +s%@host_os@%$host_os%g +s%@CONFIG_DIR@%$CONFIG_DIR%g +s%@CC@%$CC%g +s%@CPP@%$CPP%g +s%@SET_MAKE@%$SET_MAKE%g +s%@RANLIB@%$RANLIB%g +s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g +s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g +s%@INSTALL_DATA@%$INSTALL_DATA%g +s%@DYNAMIC_LINK_LIB@%$DYNAMIC_LINK_LIB%g +s%@ELF_CC@%$ELF_CC%g +s%@ELF_CFLAGS@%$ELF_CFLAGS%g +s%@ELF_LINK@%$ELF_LINK%g +s%@ELF_LINK_CMD@%$ELF_LINK_CMD%g +s%@ELF_DEP_LIBS@%$ELF_DEP_LIBS%g +s%@DYNAMIC_LINK_FLAGS@%$DYNAMIC_LINK_FLAGS%g +s%@CC_SHARED@%$CC_SHARED%g +s%@ELFLIB@%$ELFLIB%g +s%@ELFLIB_MAJOR@%$ELFLIB_MAJOR%g +s%@ELFLIB_MAJOR_MINOR@%$ELFLIB_MAJOR_MINOR%g +s%@TERMCAP@%$TERMCAP%g +s%@MISC_TERMINFO_DIRS@%$MISC_TERMINFO_DIRS%g +s%@SRCDIR@%$SRCDIR%g +s%@OBJDIR@%$OBJDIR%g +s%@ELFDIR@%$ELFDIR%g +s%@PROGRAM_OFILES@%$PROGRAM_OFILES%g +s%@PROGRAM_CFILES@%$PROGRAM_CFILES%g +s%@PROGRAM_HFILES@%$PROGRAM_HFILES%g +s%@PROGRAM_OBJECTS@%$PROGRAM_OBJECTS%g +s%@PROGRAM_ELFOBJECTS@%$PROGRAM_ELFOBJECTS%g +s%@slang_major_version@%$slang_major_version%g +s%@slang_minor_version@%$slang_minor_version%g +s%@slang_version@%$slang_version%g +s%@subdirs@%$subdirs%g + +CEOF +EOF + +cat >> $CONFIG_STATUS <<\EOF + +# Split the substitutions into bite-sized pieces for seds with +# small command number limits, like on Digital OSF/1 and HP-UX. +ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. +ac_file=1 # Number of current file. +ac_beg=1 # First line for current file. +ac_end=$ac_max_sed_cmds # Line after last line for current file. +ac_more_lines=: +ac_sed_cmds="" +while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file + else + sed "${ac_end}q" conftest.subs > conftest.s$ac_file + fi + if test ! -s conftest.s$ac_file; then + ac_more_lines=false + rm -f conftest.s$ac_file + else + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f conftest.s$ac_file" + else + ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" + fi + ac_file=`expr $ac_file + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_cmds` + fi +done +if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat +fi +EOF + +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + top_srcdir="$ac_dots$ac_given_srcdir" ;; + esac + + case "$ac_given_INSTALL" in + [/$]*) INSTALL="$ac_given_INSTALL" ;; + *) INSTALL="$ac_dots$ac_given_INSTALL" ;; + esac + + echo creating "$ac_file" + rm -f "$ac_file" + configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +s%@INSTALL@%$INSTALL%g +" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file +fi; done +rm -f conftest.s* + +# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where +# NAME is the cpp macro being defined and VALUE is the value it is being given. +# +# ac_d sets the value in "#define NAME VALUE" lines. +ac_dA='s%^\([ ]*\)#\([ ]*define[ ][ ]*\)' +ac_dB='\([ ][ ]*\)[^ ]*%\1#\2' +ac_dC='\3' +ac_dD='%g' +# ac_u turns "#undef NAME" with trailing blanks into "#define NAME VALUE". +ac_uA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' +ac_uB='\([ ]\)%\1#\2define\3' +ac_uC=' ' +ac_uD='\4%g' +# ac_e turns "#undef NAME" without trailing blanks into "#define NAME VALUE". +ac_eA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' +ac_eB='$%\1#\2define\3' +ac_eC=' ' +ac_eD='%g' + +if test "${CONFIG_HEADERS+set}" != set; then +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +fi +for ac_file in .. $CONFIG_HEADERS; do if test "x$ac_file" != x..; then + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + echo creating $ac_file + + rm -f conftest.frag conftest.in conftest.out + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` + cat $ac_file_inputs > conftest.in + +EOF + +# Transform confdefs.h into a sed script conftest.vals that substitutes +# the proper values into config.h.in to produce config.h. And first: +# Protect against being on the right side of a sed subst in config.status. +# Protect against being in an unquoted here document in config.status. +rm -f conftest.vals +cat > conftest.hdr <<\EOF +s/[\\&%]/\\&/g +s%[\\$`]%\\&%g +s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%${ac_dA}\1${ac_dB}\1${ac_dC}\2${ac_dD}%gp +s%ac_d%ac_u%gp +s%ac_u%ac_e%gp +EOF +sed -n -f conftest.hdr confdefs.h > conftest.vals +rm -f conftest.hdr + +# This sed command replaces #undef with comments. This is necessary, for +# example, in the case of _POSIX_SOURCE, which is predefined and required +# on some systems where configure will not decide to define it. +cat >> conftest.vals <<\EOF +s%^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*%/* & */% +EOF + +# Break up conftest.vals because some shells have a limit on +# the size of here documents, and old seds have small limits too. + +rm -f conftest.tail +while : +do + ac_lines=`grep -c . conftest.vals` + # grep -c gives empty output for an empty file on some AIX systems. + if test -z "$ac_lines" || test "$ac_lines" -eq 0; then break; fi + # Write a limited-size here document to conftest.frag. + echo ' cat > conftest.frag <> $CONFIG_STATUS + sed ${ac_max_here_lines}q conftest.vals >> $CONFIG_STATUS + echo 'CEOF + sed -f conftest.frag conftest.in > conftest.out + rm -f conftest.in + mv conftest.out conftest.in +' >> $CONFIG_STATUS + sed 1,${ac_max_here_lines}d conftest.vals > conftest.tail + rm -f conftest.vals + mv conftest.tail conftest.vals +done +rm -f conftest.vals + +cat >> $CONFIG_STATUS <<\EOF + rm -f conftest.frag conftest.h + echo "/* $ac_file. Generated automatically by configure. */" > conftest.h + cat conftest.in >> conftest.h + rm -f conftest.in + if cmp -s $ac_file conftest.h 2>/dev/null; then + echo "$ac_file is unchanged" + rm -f conftest.h + else + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + fi + rm -f $ac_file + mv conftest.h $ac_file + fi +fi; done + +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + +if test "$no_recursion" != yes; then + + # Remove --cache-file and --srcdir arguments so they do not pile up. + ac_sub_configure_args= + ac_prev= + for ac_arg in $ac_configure_args; do + if test -n "$ac_prev"; then + ac_prev= + continue + fi + case "$ac_arg" in + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + ;; + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + ;; + *) ac_sub_configure_args="$ac_sub_configure_args $ac_arg" ;; + esac + done + + for ac_config_dir in demo; do + + # Do not complain, so a configure script can configure whichever + # parts of a large source tree are present. + if test ! -d $srcdir/$ac_config_dir; then + continue + fi + + echo configuring in $ac_config_dir + + case "$srcdir" in + .) ;; + *) + if test -d ./$ac_config_dir || mkdir ./$ac_config_dir; then :; + else + { echo "configure: error: can not create `pwd`/$ac_config_dir" 1>&2; exit 1; } + fi + ;; + esac + + ac_popdir=`pwd` + cd $ac_config_dir + + # A "../" for each directory in /$ac_config_dir. + ac_dots=`echo $ac_config_dir|sed -e 's%^\./%%' -e 's%[^/]$%&/%' -e 's%[^/]*/%../%g'` + + case "$srcdir" in + .) # No --srcdir option. We are building in place. + ac_sub_srcdir=$srcdir ;; + /*) # Absolute path. + ac_sub_srcdir=$srcdir/$ac_config_dir ;; + *) # Relative path. + ac_sub_srcdir=$ac_dots$srcdir/$ac_config_dir ;; + esac + + # Check for guested configure; otherwise get Cygnus style configure. + if test -f $ac_sub_srcdir/configure; then + ac_sub_configure=$ac_sub_srcdir/configure + elif test -f $ac_sub_srcdir/configure.in; then + ac_sub_configure=$ac_configure + else + echo "configure: warning: no configuration information is in $ac_config_dir" 1>&2 + ac_sub_configure= + fi + + # The recursion is here. + if test -n "$ac_sub_configure"; then + + # Make the cache file name correct relative to the subdirectory. + case "$cache_file" in + /*) ac_sub_cache_file=$cache_file ;; + *) # Relative path. + ac_sub_cache_file="$ac_dots$cache_file" ;; + esac + case "$ac_given_INSTALL" in + [/$]*) INSTALL="$ac_given_INSTALL" ;; + *) INSTALL="$ac_dots$ac_given_INSTALL" ;; + esac + + echo "running ${CONFIG_SHELL-/bin/sh} $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_sub_srcdir" + # The eval makes quoting arguments work. + if eval ${CONFIG_SHELL-/bin/sh} $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_sub_srcdir + then : + else + { echo "configure: error: $ac_sub_configure failed for $ac_config_dir" 1>&2; exit 1; } + fi + fi + + cd $ac_popdir + done +fi + + + +PROGRAM_OBJECT_RULES="$PROGRAM_OBJECT_RULES +calc : \$(OBJDIR)/calc + @echo calc created in \$(OBJDIR) +\$(OBJDIR)/calc : \$(OBJDIR)/calc.o \$("calc"_DEPS) \$(EXECDEPS) + \$(CC) -o \$(OBJDIR)/calc \$(LDFLAGS) \$(OBJDIR)/calc.o \$("calc"_LIBS) \$(EXECLIBS) +\$(OBJDIR)/calc.o : \$(SRCDIR)/calc.c \$(DOT_O_DEPS) \$("calc"_O_DEP) + cd \$(OBJDIR); \$(COMPILE_CMD) \$("calc"_INC) \$(EXECINC) \$(SRCDIR)/calc.c +" + + +PROGRAM_OBJECT_RULES="$PROGRAM_OBJECT_RULES +untic : \$(OBJDIR)/untic + @echo untic created in \$(OBJDIR) +\$(OBJDIR)/untic : \$(OBJDIR)/untic.o \$("untic"_DEPS) \$(EXECDEPS) + \$(CC) -o \$(OBJDIR)/untic \$(LDFLAGS) \$(OBJDIR)/untic.o \$("untic"_LIBS) \$(EXECLIBS) +\$(OBJDIR)/untic.o : \$(SRCDIR)/untic.c \$(DOT_O_DEPS) \$("untic"_O_DEP) + cd \$(OBJDIR); \$(COMPILE_CMD) \$("untic"_INC) \$(EXECINC) \$(SRCDIR)/untic.c +" + + + echo "$PROGRAM_OBJECT_RULES" >> src/Makefile + + + echo "$PROGRAM_ELF_ORULES" >> src/Makefile + + +echo "" +echo "Configuration complete. You may need to edit src/Makefile." +echo "You are compiling SLANG with the following compiler configuration:" +echo " CC =" "$CC" +echo " CFLAGS =" "$CFLAGS" +echo " LDFLAGS =" "$LDFLAGS $DYNAMIC_LINK_FLAGS" +echo "" +echo " ELF_CC =" "$ELF_CC" +echo " ELF_LINK =" "$ELF_LINK" +echo "ELF_CFLAGS=" "$ELF_CFLAGS" +echo "" +echo " prefix:" "$prefix" +echo " exec_prefix:" "$exec_prefix" +echo " Installation Lib Dir:" "$libdir" +echo "Installation Include Dir:" "$includedir" +echo "" +echo "See also src/sl-feat.h for various features." +echo "Type 'make' to build normal library." +echo "On ELF systems, type 'make elf' to create ELF shared library." diff --git a/libslang/demo/Makefile.in b/libslang/demo/Makefile.in new file mode 100644 index 0000000..963c274 --- /dev/null +++ b/libslang/demo/Makefile.in @@ -0,0 +1,66 @@ +# -*- sh -*- + +#--------------------------------------------------------------------------- +# Choose a C compiler. It must understand prototypes. +#----------------------------------------------------------------------------- +CC = @CC@ +CFLAGS = @CFLAGS@ +LDFLAGS = @LDFLAGS@ @DYNAMIC_LINK_FLAGS@ +#----------------------------------------------------------------------------- +# Location where object files are placed (Absolute path) +#----------------------------------------------------------------------------- +OBJDIR = @OBJDIR@ +SRCDIR = @SRCDIR@ +#----------------------------------------------------------------------------- +# Directory where the various libraries are located. +#----------------------------------------------------------------------------- +SLANG_INCLUDE = $(SRCDIR)/../src# location of slang.h +SLANG_LIB = $(SLANG_INCLUDE)/$(ARCH)objs# location of libslang.a + +#--------------------------------------------------------------------------- +# Other libraries +#--------------------------------------------------------------------------- +TCAPLIB = @TERMCAP@ @DYNAMIC_LINK_LIB@ +#TCAPLIB = -ltermcap + +#---------------------------------------------------------------------------- +# End of user configuration +#---------------------------------------------------------------------------- +@SET_MAKE@ +SHELL = /bin/sh +OTHERSTUFF = useropen pager keypad smgtest +CONFIG_H = config.h + +ALL_CFLAGS = $(CFLAGS) -Dunix -I$(SLANG_INCLUDE) + +COMPILE_CMD = $(CC) -c $(ALL_CFLAGS) +EXECLIBS = -L$(SLANG_LIB) -lslang -lm $(TCAPLIB) +EXECDEPS = $(SLANG_LIB)/libslang.a +DOT_O_DEPS = demolib.c + +#--------------------------------------------------------------------------- +all: $(OBJDIR) $(CONFIG_H) $(OTHERSTUFF) + +$(CONFIG_H) : $(SLANG_LIB)/libslang.a ../src/config.h + /bin/cp ../src/config.h $(CONFIG_H) +$(SLANG_LIB)/libslang.a : + cd ../src; $(MAKE) +# +$(OBJDIR): + @mkdir $(OBJDIR) +#--------------------------------------------------------------------------- +# Housekeeping +#--------------------------------------------------------------------------- +# The symlinks target is for my own private use. It simply creates the object +# directory as a symbolic link to a local disk instead of an NFS mounted one. +symlinks: + -/bin/rm -f $(ARCH)objs + mkdir -p $(HOME)/sys/$(ARCH)/objs/slang/demo + ln -s $(HOME)/sys/$(ARCH)/objs/slang/demo $(ARCH)objs +clean: + -/bin/rm -f $(OBJDIR)/* *~ +distclean: clean + -/bin/rm -rf $(OBJDIR) Makefile +#--------------------------------------------------------------------------- +# Everything else from configure script +#--------------------------------------------------------------------------- diff --git a/libslang/demo/Makefile.w32 b/libslang/demo/Makefile.w32 new file mode 100644 index 0000000..2455cb0 --- /dev/null +++ b/libslang/demo/Makefile.w32 @@ -0,0 +1,5 @@ +CC=gcc +smgtest: smgtest.c + $(CC) $(CFLAGS) smgtest.c -I../src -L../src/gw32objs -o smgtest -lslang +pager: pager.c + $(CC) $(CFLAGS) pager.c -I../src -L../src/gw32objs -o pager -lslang diff --git a/libslang/demo/README b/libslang/demo/README new file mode 100644 index 0000000..f50f7b0 --- /dev/null +++ b/libslang/demo/README @@ -0,0 +1,43 @@ +What's here? + +Each C file in this directory are heavily commented examples that illustrate +only one or two S-Lang features. Some C files are accompanied by a .sl file +that contains S-Lang code relevant to the example. + +If you find these demos confusing, please let me know so I can work on +improving them. + +Please note that these demos WILL NOT WORK under msdos unless the S-lang +library is compiled with the -DFLOAT_TYPE option. + +--------------------------------------------------------------------------- +pager.c: A simple file pager demo. Use pageup/down keys to scroll + through the file. It illustrates the SLsmg, SLsig, SLkp, + and SLscroll routines of the S-Lang library. This example + should be contrasted with the curses demo ../src/curses/view.c. + +keypad.c: Illustrates the slkeypad facility. + +simple.c: This file contains slightly more than the miniumum required to + embed S-Lang. It loads a file specified on the command line. + +simple.sl: An S-Lang script that prompts for a filename and returns + information about the file. Use this with the `simple' + executable. + +array.c: This example shows how to embed a C array into S-Lang allowing + access to the array from a S-Lang script. +array.sl: This script reads and writes the array specified in array.c. + +useropen.c This example shows how to specify an object that S-Lang will + interpret. S-lang already knows how to interpret code contained + in strings and files. Interpreting code from a `readline' + structure is illustrated here. The demo in ../src/calc.c uses + this technique to interpret data from S-Lang's readline routines. + +complex.c Adding an application defined data type is the focus of this + example. Specifically, a complex number type is added and the + binary and unary operators are overloaded to work with the new + type. +complex.sl A script that manipulates the complex number type defined in + complex.c. diff --git a/libslang/demo/configure b/libslang/demo/configure new file mode 100755 index 0000000..fe8e9cb --- /dev/null +++ b/libslang/demo/configure @@ -0,0 +1,1597 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.13 +# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: +ac_help="$ac_help + --enable-warnings turn on GCC compiler warnings" + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +# Initialize some other variables. +subdirs= +MFLAGS= MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} +# Maximum number of lines to put in a shell here document. +ac_max_here_lines=12 + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir="$ac_optarg" ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [same as prefix] + --bindir=DIR user executables in DIR [EPREFIX/bin] + --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] + --libexecdir=DIR program executables in DIR [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data in DIR + [PREFIX/share] + --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data in DIR + [PREFIX/com] + --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] + --libdir=DIR object code libraries in DIR [EPREFIX/lib] + --includedir=DIR C header files in DIR [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] + --infodir=DIR info documentation in DIR [PREFIX/info] + --mandir=DIR man documentation in DIR [PREFIX/man] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM + run sed PROGRAM on installed program names +EOF + cat << EOF +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +EOF + if test -n "$ac_help"; then + echo "--enable and --with options recognized:$ac_help" + fi + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir="$ac_optarg" ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir="$ac_optarg" ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir="$ac_optarg" ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir="$ac_optarg" ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir="$ac_optarg" ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir="$ac_optarg" ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir="$ac_optarg" ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir="$ac_optarg" ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.13" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +done + +# NLS nuisances. +# Only set these to C if already set. These must not be set unconditionally +# because not all systems understand e.g. LANG=C (notably SCO). +# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! +# Non-C LC_CTYPE values break the ctype check. +if test "${LANG+set}" = set; then LANG=C; export LANG; fi +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi +if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +ac_unique_file=smgtest.c + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +ac_exeext= +ac_objext=o +if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + + +ac_aux_dir= +for ac_dir in ../autoconf $srcdir/../autoconf; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { echo "configure: error: can not find install-sh or install.sh in ../autoconf $srcdir/../autoconf" 1>&2; exit 1; } +fi +ac_config_guess=$ac_aux_dir/config.guess +ac_config_sub=$ac_aux_dir/config.sub +ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. + + + +#These variable are initialized by JD init function +CONFIG_DIR=`pwd` +cd $srcdir +if test "`pwd`" != "$CONFIG_DIR" + then + { echo "configure: error: "This software does not support configuring from another directory. See the INSTALL file"" 1>&2; exit 1; } + fi +# Note: these will differ if one is a symbolic link +if test -f /usr/bin/dirname; then + JD_Above_Dir=`dirname $CONFIG_DIR` +else +# system is a loser + JD_Above_Dir=`cd ..;pwd` +fi +JD_Above_Dir2=`cd ..;pwd` + + +# Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:569: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="gcc" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:599: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_prog_rejected=no + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + break + fi + done + IFS="$ac_save_ifs" +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# -gt 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + set dummy "$ac_dir/$ac_word" "$@" + shift + ac_cv_prog_CC="$@" + fi +fi +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + if test -z "$CC"; then + case "`uname -s`" in + *win32* | *WIN32*) + # Extract the first word of "cl", so it can be a program name with args. +set dummy cl; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:650: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="cl" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + ;; + esac + fi + test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; } +fi + +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 +echo "configure:682: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +cat > conftest.$ac_ext << EOF + +#line 693 "configure" +#include "confdefs.h" + +main(){return(0);} +EOF +if { (eval echo configure:698: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + ac_cv_prog_cc_works=yes + # If we can't run a trivial program, we are probably using a cross compiler. + if (./conftest; exit) 2>/dev/null; then + ac_cv_prog_cc_cross=no + else + ac_cv_prog_cc_cross=yes + fi +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + ac_cv_prog_cc_works=no +fi +rm -fr conftest* +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +echo "$ac_t""$ac_cv_prog_cc_works" 1>&6 +if test $ac_cv_prog_cc_works = no; then + { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } +fi +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 +echo "configure:724: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 +cross_compiling=$ac_cv_prog_cc_cross + +echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 +echo "configure:729: checking whether we are using GNU C" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then + ac_cv_prog_gcc=yes +else + ac_cv_prog_gcc=no +fi +fi + +echo "$ac_t""$ac_cv_prog_gcc" 1>&6 + +if test $ac_cv_prog_gcc = yes; then + GCC=yes +else + GCC= +fi + +ac_test_CFLAGS="${CFLAGS+set}" +ac_save_CFLAGS="$CFLAGS" +CFLAGS= +echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 +echo "configure:757: checking whether ${CC-cc} accepts -g" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + echo 'void f(){}' > conftest.c +if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then + ac_cv_prog_cc_g=yes +else + ac_cv_prog_cc_g=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$ac_cv_prog_cc_g" 1>&6 +if test "$ac_test_CFLAGS" = set; then + CFLAGS="$ac_save_CFLAGS" +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi + +echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 +echo "configure:789: checking how to run the C preprocessor" >&5 +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then +if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + # This must be in double quotes, not single quotes, because CPP may get + # substituted into the Makefile and "${CC-cc}" will confuse make. + CPP="${CC-cc} -E" + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:810: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP="${CC-cc} -E -traditional-cpp" + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:827: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP="${CC-cc} -nologo -E" + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:844: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP=/lib/cpp +fi +rm -f conftest* +fi +rm -f conftest* +fi +rm -f conftest* + ac_cv_prog_CPP="$CPP" +fi + CPP="$ac_cv_prog_CPP" +else + ac_cv_prog_CPP="$CPP" +fi +echo "$ac_t""$CPP" 1>&6 + +if test $ac_cv_prog_gcc = yes; then + echo $ac_n "checking whether ${CC-cc} needs -traditional""... $ac_c" 1>&6 +echo "configure:870: checking whether ${CC-cc} needs -traditional" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_gcc_traditional'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_pattern="Autoconf.*'x'" + cat > conftest.$ac_ext < +Autoconf TIOCGETP +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "$ac_pattern" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_prog_gcc_traditional=yes +else + rm -rf conftest* + ac_cv_prog_gcc_traditional=no +fi +rm -f conftest* + + + if test $ac_cv_prog_gcc_traditional = no; then + cat > conftest.$ac_ext < +Autoconf TCGETA +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "$ac_pattern" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_prog_gcc_traditional=yes +fi +rm -f conftest* + + fi +fi + +echo "$ac_t""$ac_cv_prog_gcc_traditional" 1>&6 + if test $ac_cv_prog_gcc_traditional = yes; then + CC="$CC -traditional" + fi +fi + +echo $ac_n "checking for POSIXized ISC""... $ac_c" 1>&6 +echo "configure:916: checking for POSIXized ISC" >&5 +if test -d /etc/conf/kconfig.d && + grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1 +then + echo "$ac_t""yes" 1>&6 + ISC=yes # If later tests want to check for ISC. + cat >> confdefs.h <<\EOF +#define _POSIX_SOURCE 1 +EOF + + if test "$GCC" = yes; then + CC="$CC -posix" + else + CC="$CC -Xp" + fi +else + echo "$ac_t""no" 1>&6 + ISC= +fi + +echo $ac_n "checking for AIX""... $ac_c" 1>&6 +echo "configure:937: checking for AIX" >&5 +cat > conftest.$ac_ext <&5 | + egrep "yes" >/dev/null 2>&1; then + rm -rf conftest* + echo "$ac_t""yes" 1>&6; cat >> confdefs.h <<\EOF +#define _ALL_SOURCE 1 +EOF + +else + rm -rf conftest* + echo "$ac_t""no" 1>&6 +fi +rm -f conftest* + + + +cat > conftest.$ac_ext <&5 | + egrep "yes" >/dev/null 2>&1; then + rm -rf conftest* + +cat >> confdefs.h <<\EOF +#define _HPUX_SOURCE 1 +EOF + +if test "$CC" = cc; then CC="cc -Ae"; fi + +fi +rm -f conftest* +echo $ac_n "checking C compiler that understands ANSI prototypes""... $ac_c" 1>&6 +echo "configure:982: checking C compiler that understands ANSI prototypes" >&5 +cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + + echo "$ac_t""$CC looks ok. Good." 1>&6 +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + + echo "$ac_t""$CC is not a good enough compiler" 1>&6 + { echo "configure: error: Set env variable CC to your ANSI compiler and rerun configure." 1>&2; exit 1; } + +fi +rm -f conftest* + +echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 +echo "configure:1008: checking whether ${MAKE-make} sets \${MAKE}" >&5 +set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftestmake <<\EOF +all: + @echo 'ac_maketemp="${MAKE}"' +EOF +# GNU make sometimes prints "make[1]: Entering...", which would confuse us. +eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=` +if test -n "$ac_maketemp"; then + eval ac_cv_prog_make_${ac_make}_set=yes +else + eval ac_cv_prog_make_${ac_make}_set=no +fi +rm -f conftestmake +fi +if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then + echo "$ac_t""yes" 1>&6 + SET_MAKE= +else + echo "$ac_t""no" 1>&6 + SET_MAKE="MAKE=${MAKE-make}" +fi + + + +# Make sure we can run config.sub. +if ${CONFIG_SHELL-/bin/sh} $ac_config_sub sun4 >/dev/null 2>&1; then : +else { echo "configure: error: can not run $ac_config_sub" 1>&2; exit 1; } +fi + +echo $ac_n "checking host system type""... $ac_c" 1>&6 +echo "configure:1042: checking host system type" >&5 + +host_alias=$host +case "$host_alias" in +NONE) + case $nonopt in + NONE) + if host_alias=`${CONFIG_SHELL-/bin/sh} $ac_config_guess`; then : + else { echo "configure: error: can not guess host type; you must specify one" 1>&2; exit 1; } + fi ;; + *) host_alias=$nonopt ;; + esac ;; +esac + +host=`${CONFIG_SHELL-/bin/sh} $ac_config_sub $host_alias` +host_cpu=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` +host_vendor=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` +host_os=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` +echo "$ac_t""$host" 1>&6 + + +DYNAMIC_LINK_LIB="" +ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6 +echo "configure:1066: checking for dlfcn.h" >&5 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:1076: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + + cat >> confdefs.h <<\EOF +#define HAVE_DLFCN_H 1 +EOF + + echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6 +echo "configure:1098: checking for dlopen in -ldl" >&5 +ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-ldl $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + + DYNAMIC_LINK_LIB="-ldl" + cat >> confdefs.h <<\EOF +#define HAVE_DLOPEN 1 +EOF + + +else + echo "$ac_t""no" 1>&6 + + echo $ac_n "checking for dlopen""... $ac_c" 1>&6 +echo "configure:1143: checking for dlopen" >&5 +if eval "test \"`echo '$''{'ac_cv_func_dlopen'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char dlopen(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_dlopen) || defined (__stub___dlopen) +choke me +#else +dlopen(); +#endif + +; return 0; } +EOF +if { (eval echo configure:1171: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_func_dlopen=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_dlopen=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'dlopen`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define HAVE_DLOPEN 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi + + if test "$ac_cv_func_dlopen" != yes + then + echo "configure: warning: cannot perform dynamic linking" 1>&2 + fi + +fi + +else + echo "$ac_t""no" 1>&6 +fi + + + +case "$host_os" in + linux ) + DYNAMIC_LINK_FLAGS="-Wl,-export-dynamic" + ;; + * ) + DYNAMIC_LINK_FLAGS="" + ;; +esac + + + +JD_Terminfo_Dirs="/usr/lib/terminfo \ + /usr/share/terminfo \ + /usr/share/lib/terminfo \ + /usr/local/lib/terminfo" + +TERMCAP=-ltermcap + +echo $ac_n "checking for Terminfo""... $ac_c" 1>&6 +echo "configure:1225: checking for Terminfo" >&5 +for terminfo_dir in $JD_Terminfo_Dirs +do + if test -d $terminfo_dir + then + echo "$ac_t""yes" 1>&6 + TERMCAP="" + break + fi +done +if test "$TERMCAP"; then + echo "$ac_t""no" 1>&6 + cat >> confdefs.h <<\EOF +#define USE_TERMCAP 1 +EOF + +fi + + +# Check whether --enable-warnings or --disable-warnings was given. +if test "${enable_warnings+set}" = set; then + enableval="$enable_warnings" + gcc_warnings=$enableval +fi + +if test -n "$GCC" +then + CFLAGS="$CFLAGS -fno-strength-reduce" + if test -n "$gcc_warnings" + then + CFLAGS="$CFLAGS -Wall -W -pedantic -Winline -Wmissing-prototypes \ + -Wnested-externs -Wpointer-arith -Wcast-align -Wshadow -Wstrict-prototypes" + # Now trim excess whitespace + CFLAGS=`echo $CFLAGS` + fi +fi + + + +#--------------------------------------------------------------------------- +# Set the source directory and object directory. The makefile assumes an +# abcolute path name. This is because src/Makefile cds to OBJDIR and compiles +# the src file which is in SRCDIR +#--------------------------------------------------------------------------- +SRCDIR=$CONFIG_DIR +if test "." != "." +then + if test -z "." + then + SRCDIR=$SRCDIR/src + else + SRCDIR=$SRCDIR/. + fi +fi + +OBJDIR=$SRCDIR/"$ARCH"objs +ELFDIR=$SRCDIR/elf"$ARCH"objs + + + PROGRAM_HFILES="" + PROGRAM_OFILES="" + PROGRAM_CFILES="" + PROGRAM_OBJECTS="" + PROGRAM_ELFOBJECTS="" + PROGRAM_OBJECT_RULES="" + PROGRAM_ELF_ORULES="" + if test -z "modules.unx" + then + Program_Modules="" + else + comment_re="^#" + Program_Modules=`grep -v '$comment_re' modules.unx | awk '{print $1}'` + Program_H_Modules=`grep -v '$comment_re' modules.unx | awk '{print $2}'` + for program_module in $Program_H_Modules; do + PROGRAM_HFILES="$PROGRAM_HFILES $program_module" + done + fi + for program_module in $Program_Modules; do + PROGRAM_OFILES="$PROGRAM_OFILES $program_module.o" + PROGRAM_CFILES="$PROGRAM_CFILES $program_module.c" + PROGRAM_OBJECTS="$PROGRAM_OBJECTS \$(OBJDIR)/$program_module.o" + PROGRAM_ELFOBJECTS="$PROGRAM_ELFOBJECTS \$(ELFDIR)/$program_module.o" + done + + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +(set) 2>&1 | + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote substitution + # turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + -e "s/'/'\\\\''/g" \ + -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' + ;; + esac >> confcache +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +cat > conftest.defs <<\EOF +s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g +s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g +s%\[%\\&%g +s%\]%\\&%g +s%\$%$$%g +EOF +DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` +rm -f conftest.defs + + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS </dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" + exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; + -version | --version | --versio | --versi | --vers | --ver | --ve | --v) + echo "$CONFIG_STATUS generated by autoconf version 2.13" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir + +trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +EOF +cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF +$ac_vpsub +$extrasub +s%@SHELL@%$SHELL%g +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@FFLAGS@%$FFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@bindir@%$bindir%g +s%@sbindir@%$sbindir%g +s%@libexecdir@%$libexecdir%g +s%@datadir@%$datadir%g +s%@sysconfdir@%$sysconfdir%g +s%@sharedstatedir@%$sharedstatedir%g +s%@localstatedir@%$localstatedir%g +s%@libdir@%$libdir%g +s%@includedir@%$includedir%g +s%@oldincludedir@%$oldincludedir%g +s%@infodir@%$infodir%g +s%@mandir@%$mandir%g +s%@CONFIG_DIR@%$CONFIG_DIR%g +s%@CC@%$CC%g +s%@CPP@%$CPP%g +s%@SET_MAKE@%$SET_MAKE%g +s%@host@%$host%g +s%@host_alias@%$host_alias%g +s%@host_cpu@%$host_cpu%g +s%@host_vendor@%$host_vendor%g +s%@host_os@%$host_os%g +s%@DYNAMIC_LINK_LIB@%$DYNAMIC_LINK_LIB%g +s%@DYNAMIC_LINK_FLAGS@%$DYNAMIC_LINK_FLAGS%g +s%@TERMCAP@%$TERMCAP%g +s%@SRCDIR@%$SRCDIR%g +s%@OBJDIR@%$OBJDIR%g +s%@ELFDIR@%$ELFDIR%g +s%@PROGRAM_OFILES@%$PROGRAM_OFILES%g +s%@PROGRAM_CFILES@%$PROGRAM_CFILES%g +s%@PROGRAM_HFILES@%$PROGRAM_HFILES%g +s%@PROGRAM_OBJECTS@%$PROGRAM_OBJECTS%g +s%@PROGRAM_ELFOBJECTS@%$PROGRAM_ELFOBJECTS%g + +CEOF +EOF + +cat >> $CONFIG_STATUS <<\EOF + +# Split the substitutions into bite-sized pieces for seds with +# small command number limits, like on Digital OSF/1 and HP-UX. +ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. +ac_file=1 # Number of current file. +ac_beg=1 # First line for current file. +ac_end=$ac_max_sed_cmds # Line after last line for current file. +ac_more_lines=: +ac_sed_cmds="" +while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file + else + sed "${ac_end}q" conftest.subs > conftest.s$ac_file + fi + if test ! -s conftest.s$ac_file; then + ac_more_lines=false + rm -f conftest.s$ac_file + else + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f conftest.s$ac_file" + else + ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" + fi + ac_file=`expr $ac_file + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_cmds` + fi +done +if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat +fi +EOF + +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + top_srcdir="$ac_dots$ac_given_srcdir" ;; + esac + + + echo creating "$ac_file" + rm -f "$ac_file" + configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file +fi; done +rm -f conftest.s* + +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + + + + for program_module in $Program_Modules; do + +PROGRAM_OBJECT_RULES="$PROGRAM_OBJECT_RULES +$program_module : \$(OBJDIR)/$program_module + @echo $program_module created in \$(OBJDIR) +\$(OBJDIR)/$program_module : \$(OBJDIR)/$program_module.o \$("$program_module"_DEPS) \$(EXECDEPS) + \$(CC) -o \$(OBJDIR)/$program_module \$(LDFLAGS) \$(OBJDIR)/$program_module.o \$("$program_module"_LIBS) \$(EXECLIBS) +\$(OBJDIR)/$program_module.o : \$(SRCDIR)/$program_module.c \$(DOT_O_DEPS) \$("$program_module"_O_DEP) + cd \$(OBJDIR); \$(COMPILE_CMD) \$("$program_module"_INC) \$(EXECINC) \$(SRCDIR)/$program_module.c +" + + done + + + echo "$PROGRAM_OBJECT_RULES" >> Makefile + diff --git a/libslang/demo/configure.in b/libslang/demo/configure.in new file mode 100644 index 0000000..fc35785 --- /dev/null +++ b/libslang/demo/configure.in @@ -0,0 +1,51 @@ +dnl -*- sh -*- + +AC_INIT(smgtest.c) + +AC_CONFIG_AUX_DIR(../autoconf) + +JD_INIT +JD_ANSI_CC + +AC_PROG_MAKE_SET + +AC_CANONICAL_HOST + +dnl #------------------------------------------------------------------------- +dnl # Check for dynamic linker +dnl #------------------------------------------------------------------------- +DYNAMIC_LINK_LIB="" +AC_CHECK_HEADER(dlfcn.h,[ + AC_DEFINE(HAVE_DLFCN_H) + AC_CHECK_LIB(dl,dlopen,[ + DYNAMIC_LINK_LIB="-ldl" + AC_DEFINE(HAVE_DLOPEN) + ],[ + AC_CHECK_FUNC(dlopen,AC_DEFINE(HAVE_DLOPEN)) + if test "$ac_cv_func_dlopen" != yes + then + AC_MSG_WARN(cannot perform dynamic linking) + fi + ])]) +AC_SUBST(DYNAMIC_LINK_LIB) + +case "$host_os" in + linux ) + DYNAMIC_LINK_FLAGS="-Wl,-export-dynamic" + ;; + * ) + DYNAMIC_LINK_FLAGS="" + ;; +esac +AC_SUBST(DYNAMIC_LINK_FLAGS) + +JD_TERMCAP +JD_GCC_WARNINGS + +JD_SET_OBJ_SRC_DIR(.) +JD_GET_MODULES(modules.unx) + +AC_OUTPUT(Makefile) + +JD_CREATE_MODULE_EXEC_RULES +JD_APPEND_RULES(Makefile) diff --git a/libslang/demo/demolib.c b/libslang/demo/demolib.c new file mode 100644 index 0000000..7cb364a --- /dev/null +++ b/libslang/demo/demolib.c @@ -0,0 +1,96 @@ +/* These routines are used by several of the demos. */ +#include "config.h" +#include +#include + +#ifdef HAVE_STDLIB_H +# include +#endif + +#include + +static void demolib_exit (int sig) +{ + SLang_reset_tty (); + SLsmg_reset_smg (); + + if (sig) + { + fprintf (stderr, "Exiting on signal %d\n", sig); + exit (1); + } + exit (sig); +} + +#ifdef SIGTSTP +static void sigtstp_handler (int sig) +{ + demolib_exit (sig); +} +#endif + +#ifdef SIGINT +static void sigint_handler (int sig) +{ + demolib_exit (sig); +} +#endif + +static void init_signals (void) +{ +#ifdef SIGTSTP + SLsignal (SIGTSTP, sigtstp_handler); +#endif +#ifdef SIGINT + SLsignal (SIGINT, sigint_handler); +#endif +} + +static void exit_error_hook (char *fmt, va_list ap) +{ + SLang_reset_tty (); + SLsmg_reset_smg (); + + vfprintf (stderr, fmt, ap); + fputc ('\n', stderr); + exit (1); +} + + + +static int demolib_init_terminal (int tty, int smg) +{ + SLang_Exit_Error_Hook = exit_error_hook; + + /* It is wise to block the occurance of display related signals while we are + * initializing. + */ + SLsig_block_signals (); + + SLtt_get_terminfo (); + + /* SLkp_init assumes that SLtt_get_terminfo has been called. */ + if (tty && (-1 == SLkp_init ())) + { + SLsig_unblock_signals (); + return -1; + } + + init_signals (); + + if (tty) SLang_init_tty (-1, 0, 1); +#ifdef REAL_UNIX_SYSTEM + if (tty) SLtty_set_suspend_state (1); +#endif + if (smg + && (-1 == SLsmg_init_smg ())) + { + SLsig_unblock_signals (); + return -1; + } + + SLsig_unblock_signals (); + + return 0; +} + diff --git a/libslang/demo/keypad.c b/libslang/demo/keypad.c new file mode 100644 index 0000000..ac2a736 --- /dev/null +++ b/libslang/demo/keypad.c @@ -0,0 +1,52 @@ +/* This routine illustrates the keypad interface. To implement + * detection of a single escape character, allow for timeout. + */ + +#include +#include + +#include "demolib.c" + +#define TIMEOUT 2 /* 2/10 of a second */ + +static int getch (void) +{ + int ch; + + while (0 == SLang_input_pending (1000)) + continue; + + ch = SLang_getkey (); + + if (ch == 033) /* escape */ + { + if (0 == SLang_input_pending (TIMEOUT)) + return 033; + } + + SLang_ungetkey (ch); + + return SLkp_getkey (); +} + + +int main (int argc, char **argv) +{ + int ch; + + (void) argc; (void) argv; + + if (-1 == demolib_init_terminal (1, 0)) + return 1; + + fprintf (stderr, "This program illustrates the slkeypad facility.\n"); + fprintf (stderr, "Press any key ('q' quits).\n"); + while ('q' != (ch = getch ())) + { + fprintf (stderr, "Keysym: %d\r\n", ch); + } + + demolib_exit (0); + + return 0; +} diff --git a/libslang/demo/modules.unx b/libslang/demo/modules.unx new file mode 100644 index 0000000..ea2c37c --- /dev/null +++ b/libslang/demo/modules.unx @@ -0,0 +1,4 @@ +useropen +pager +keypad +smgtest diff --git a/libslang/demo/pager.c b/libslang/demo/pager.c new file mode 100644 index 0000000..b094a0a --- /dev/null +++ b/libslang/demo/pager.c @@ -0,0 +1,280 @@ +/* This file pager demo illustrates the screen management and + * keyboard routines. + */ + +#include +#include + +#include + +#include + +#ifdef unix +# include +#endif + +#include + +#include "demolib.c" + +static void usage (char *pgm) +{ + fprintf (stderr, "Usage: %s [FILENAME]\n", pgm); + exit (1); +} + +static int read_file (char *); +static void main_loop (void); + +static char *File_Name; /* if NULL, use stdin */ + +int main (int argc, char **argv) +{ + if (argc == 2) + { + File_Name = argv[1]; + } + else if ((argc != 1) || (1 == isatty (fileno(stdin)))) + usage (argv[0]); + + + if (-1 == read_file (File_Name)) + { + fprintf (stderr, "Unable to read %s\n", File_Name); + return 1; + } + + /* This sets up the terminal, signals, screen management routines, etc... */ + if (-1 == demolib_init_terminal (1, 1)) + { + fprintf (stderr, "Unable to initialize terminal."); + return 1; + } + +#define APP_KEY_EOB 0x1001 +#define APP_KEY_BOB 0x1002 + + /* Add a few application defined keysyms. 0x1000 and above are for + * applications. + */ + (void) SLkp_define_keysym ("\033>", APP_KEY_EOB); + (void) SLkp_define_keysym ("\033<", APP_KEY_BOB); + + main_loop (); /* should not return */ + return 1; +} + + +/* The SLscroll routines will be used for pageup/down commands. They assume + * a linked list of lines. The first element of the structure MUST point to + * the NEXT line, the second MUST point to the PREVIOUS line. + */ +typedef struct _File_Line_Type +{ + struct _File_Line_Type *next; + struct _File_Line_Type *prev; + char *data; /* pointer to line data */ +} +File_Line_Type; + +static File_Line_Type *File_Lines; + +/* The SLscroll routines will use this structure. */ +static SLscroll_Window_Type Line_Window; + +static void free_lines (void) +{ + File_Line_Type *line, *next; + + line = File_Lines; + while (line != NULL) + { + next = line->next; + if (line->data != NULL) free (line->data); + free (line); + line = next; + } + File_Lines = NULL; +} + +static File_Line_Type *create_line (char *buf) +{ + File_Line_Type *line; + + line = (File_Line_Type *) malloc (sizeof (File_Line_Type)); + if (line == NULL) return NULL; + + memset ((char *) line, sizeof (File_Line_Type), 0); + + line->data = SLmake_string (buf); /* use a slang routine */ + if (line->data == NULL) + { + free (line); + return NULL; + } + + return line; +} + + +static int read_file (char *file) +{ + FILE *fp; + char buf [1024]; + File_Line_Type *line, *last_line; + unsigned int num_lines; + + if (file == NULL) + fp = stdin; + else fp = fopen (file, "r"); + + if (fp == NULL) return -1; + + last_line = NULL; + num_lines = 0; + + while (NULL != fgets (buf, sizeof(buf), fp)) + { + num_lines++; + + if (NULL == (line = create_line (buf))) + { + fprintf (stderr, "Out of memory."); + free_lines (); + return -1; + } + + if (last_line == NULL) + File_Lines = line; + else + last_line->next = line; + + line->prev = last_line; + line->next = NULL; + + last_line = line; + } + + memset ((char *)&Line_Window, 0, sizeof (SLscroll_Window_Type)); + + Line_Window.current_line = (SLscroll_Type *) File_Lines; + Line_Window.lines = (SLscroll_Type *) File_Lines; + Line_Window.line_num = 1; + Line_Window.num_lines = num_lines; + /* Line_Window.border = 3; */ + + return 0; +} + + +static void update_display (void) +{ + unsigned int row, nrows; + File_Line_Type *line; + + /* All well behaved applications should block signals that may affect + * the display while performing screen update. + */ + SLsig_block_signals (); + + Line_Window.nrows = nrows = SLtt_Screen_Rows - 1; + + /* Always make the current line equal to the top window line. */ + if (Line_Window.top_window_line != NULL) + Line_Window.current_line = Line_Window.top_window_line; + + SLscroll_find_top (&Line_Window); + + row = 0; + line = (File_Line_Type *) Line_Window.top_window_line; + + SLsmg_normal_video (); + + while (row < Line_Window.nrows) + { + SLsmg_gotorc (row, 0); + + if (line != NULL) + { + SLsmg_write_string (line->data); + line = line->next; + } + SLsmg_erase_eol (); + row++; + } + + SLsmg_gotorc (row, 0); + SLsmg_reverse_video (); + SLsmg_printf ("%s", (File_Name == NULL) ? "" : File_Name); + SLsmg_erase_eol (); + SLsmg_refresh (); + + SLsig_unblock_signals (); +} + +static int Screen_Start; + +static void main_loop (void) +{ + int screen_start; + + while (1) + { + update_display (); + switch (SLkp_getkey ()) + { + case SL_KEY_ERR: + case 'q': + case 'Q': + demolib_exit (0); + break; + + case SL_KEY_RIGHT: + Screen_Start += 1; + screen_start = Screen_Start; + SLsmg_set_screen_start (NULL, &screen_start); + break; + + case SL_KEY_LEFT: + Screen_Start -= 1; + if (Screen_Start < 0) Screen_Start = 0; + screen_start = Screen_Start; + SLsmg_set_screen_start (NULL, &screen_start); + break; + + case SL_KEY_UP: + SLscroll_prev_n (&Line_Window, 1); + Line_Window.top_window_line = Line_Window.current_line; + break; + + case '\r': + case SL_KEY_DOWN: + SLscroll_next_n (&Line_Window, 1); + Line_Window.top_window_line = Line_Window.current_line; + break; + + case SL_KEY_NPAGE: + case ' ': case 4: + SLscroll_pagedown (&Line_Window); + break; + + case SL_KEY_PPAGE: + case 127: case 21: + SLscroll_pageup (&Line_Window); + break; + + case APP_KEY_BOB: + while (-1 != SLscroll_pageup (&Line_Window)) + ; + break; + + case APP_KEY_EOB: + while (-1 != SLscroll_pagedown (&Line_Window)) + ; + break; + + default: + SLtt_beep (); + } + } +} diff --git a/libslang/demo/smgtest.c b/libslang/demo/smgtest.c new file mode 100644 index 0000000..ee0d7fc --- /dev/null +++ b/libslang/demo/smgtest.c @@ -0,0 +1,799 @@ +/* This demo test some of the slsmg features. */ +#include "config.h" + +#include +#ifdef HAVE_STDLIB_H +# include +#endif + +#include +#include + +#include "demolib.c" + +static void menu_loop (void); +static int select_menu_item (int i); +static void init_colors (void); + +int main (int argc, char **argv) +{ + if (-1 == demolib_init_terminal (1, 1)) + return 1; + + init_colors (); + + (void) SLtt_set_mouse_mode (1, 0); + + if (argc <= 1) + menu_loop (); + + do + { + argc--; + argv++; + + if (-1 == select_menu_item (atoi (*argv))) + menu_loop (); + } + while (argc > 1); + + demolib_exit (0); + return 1; +} + +static void quit (void) +{ + demolib_exit (0); +} + +static void bce_color_test (void); +static void color_test (void); +static void color_test1 (void); +static void alt_char_test (void); +static void esc_seq_test (void); +static void ansi_esc_seq_test (void); +static void line_test (void); +static void mouse_test (void); +static void low_level_test (void); +static void box_test (void); +static void draw_symbols_test (void); +static void lr_corner_test (void); +static void mono_test (void); + +typedef struct +{ + char *name; + void (*funct) (void); +} +Menu_Type; + +static Menu_Type Root_Menu [] = +{ + {"Color Test", color_test}, + {"Another Color Test", color_test1}, + {"BCE Color Test", bce_color_test}, + {"Alt charset test", alt_char_test}, + {"Drawing Symbols", draw_symbols_test}, + {"Key Escape Sequence Report", esc_seq_test}, +#ifdef IBMPC_SYSTEM + {"ANSI Key Escape Sequence Report", ansi_esc_seq_test}, +#endif + {"Line Drawing Test", line_test}, + {"Test Mouse", mouse_test}, + {"Box Test", box_test}, + {"Write to Lower Right Corner Test", lr_corner_test}, + {"Test Low Level Functions", low_level_test}, + {"Test monochrome functions", mono_test}, + {"Quit", quit}, + {NULL, NULL} +}; + +Menu_Type *Current_Menu = Root_Menu; + +static void print_menu (void) +{ + int i; + int row; + Menu_Type *menu; + + menu = Current_Menu; + + SLsig_block_signals (); + + SLsmg_cls (); + + row = 2; + i = 1; + while (menu->name != NULL) + { + SLsmg_gotorc (row, 3); + SLsmg_printf ("%2X. %s", i, menu->name); + menu++; + row++; + i++; + } + + row = 0; + SLsmg_gotorc (row, 1); + SLsmg_write_string ("Choose number:"); + + SLsmg_refresh (); + SLsig_unblock_signals (); +} + + +static int select_menu_item (int num) +{ + int i = 1; + Menu_Type *m = Current_Menu; + + while (m->name != NULL) + { + if (i == num) + { + (*m->funct) (); + return 0; + } + i++; + m++; + } + + return -1; +} + + +static void menu_loop (void) +{ + int ch; + + print_menu (); + + while (1) + { + ch = SLkp_getkey (); + + if ((ch == 'q') || (ch == 'Q')) + quit (); + + if ((ch >= '0') + && (ch <= '9')) + ch -= '0'; + else if ((ch >= 'A') && (ch <= 'Z')) + ch = 10 + (ch - 'A'); + else + ch = 10 + (ch - 'a'); + + + if (-1 == select_menu_item (ch)) + { + SLtt_beep (); + continue; + } + print_menu (); + } +} + +static void write_centered_string (char *s, int row) +{ + unsigned int len; + int col; + + if (s == NULL) + return; + + len = strlen (s); + + /* Want 2 * col + len == SLtt_Screen_Rows */ + if (len >= (unsigned int) SLtt_Screen_Cols) col = 0; + else col = (SLtt_Screen_Cols - (int)len) / 2; + + SLsmg_gotorc (row, col); + SLsmg_write_string (s); +} + +static void pre_test (char *title) +{ + SLsig_block_signals (); + SLsmg_cls (); + write_centered_string (title, 0); +} + +static void post_test (void) +{ + write_centered_string ("Press any key to return.", SLtt_Screen_Rows - 1); + SLsmg_refresh (); + SLsig_unblock_signals (); + (void) SLkp_getkey (); +} + +/* Various tests */ + +#define NUM_COLORS 16 +static char *Colors [NUM_COLORS] = +{ + "black/default", + "red", + "green", + "brown", + "blue", + "magenta", + "cyan", + "lightgray", + "gray", + "brightred", + "brightgreen", + "yellow", + "brightblue", + "brightmagenta", + "brightcyan", + "white" +}; + +static void init_colors (void) +{ + int i; + char *fg, *bg; + + fg = "black"; + for (i = 0; i < NUM_COLORS; i++) + { + bg = Colors[i]; + SLtt_set_color (i + 1, NULL, fg, bg); + } +} + + +static void box_test (void) +{ + char *msg = "This is a box with changing background"; + int r, c, dr, dc; + int color; + + pre_test ("Box Test"); + + dr = 8; + dc = 4 + strlen (msg); + r = SLtt_Screen_Rows / 2 - dr/2; + c = SLtt_Screen_Cols / 2 - dc/2; + + SLsmg_set_color (1); + SLsmg_set_char_set (1); + SLsmg_fill_region (r + 1, c + 1, dr - 2, dc - 2, SLSMG_CKBRD_CHAR); + SLsmg_set_char_set (0); + SLsmg_set_color (0); + SLsmg_gotorc (r + dr/2, c + 2); SLsmg_write_string (msg); + SLsmg_draw_box (r, c, dr, dc); + + SLsmg_refresh (); + + color = 2; + while (0 == SLang_input_pending (10)) + { + SLsmg_set_color_in_region (color, r, c, dr, dc); + SLsmg_refresh (); + color++; + color = color % NUM_COLORS; + } + post_test (); +} + +static int check_color_support (void) +{ + if (SLtt_Use_Ansi_Colors) + return 0; + + pre_test ("Your terminal does not provide color support."); + post_test (); + return -1; +} + + +static void bce_color_test (void) +{ + int row; + + if (-1 == check_color_support ()) + return; + + pre_test ("Background Color Erase Test"); + + SLtt_set_color (0, NULL, "lightgray", "blue"); + + row = SLtt_Screen_Rows/2; + SLsmg_set_color (0); + SLsmg_gotorc (row, 1); + SLsmg_write_string ("The screen background should be blue."); + + row += 2; + SLsmg_gotorc (row++, 1); + SLsmg_write_string ("****If the screen update is slow, then your terminal"); + SLsmg_gotorc (row++, 1); + SLsmg_write_string (" does not support background-color-erase."); + SLsmg_set_color (0); + post_test (); +} + +static void lr_corner_test (void) +{ + pre_test ("Write to Lower Right Corner Test"); + + SLsmg_gotorc (SLtt_Screen_Rows-1, SLtt_Screen_Cols-1); + SLsmg_write_string ("X"); + + write_centered_string ("An 'X' should be in the lower-right corner.", + SLtt_Screen_Rows/2); + + SLsmg_refresh (); + SLsig_unblock_signals (); + (void) SLkp_getkey (); +} + +static void color_test (void) +{ + int color; + int row; + + if (-1 == check_color_support ()) + return; + + pre_test ("Color Test"); + + row = 1; + + color = 0; + while (row < SLtt_Screen_Rows - 1) + { + color = color % NUM_COLORS; + + SLsmg_gotorc (row, 0); + SLsmg_set_color (0); + SLsmg_write_string (Colors[color]); + color++; + SLsmg_set_color (color); + SLsmg_erase_eol (); + row++; + } + + SLsmg_set_color (0); + post_test (); +} + +static void color_test1 (void) +{ + int color; + int r0, r1; + int c0, c1; + unsigned int dr0, dr1, dc0, dc1; + + if (-1 == check_color_support ()) + return; + + pre_test ("Another Color Test"); + + r0 = 1; + r1 = SLtt_Screen_Rows / 2; + dr0 = r1; + dr1 = SLtt_Screen_Rows; + + c0 = 0; + c1 = SLtt_Screen_Cols / 2; + dc0 = c1; + dc1 = SLtt_Screen_Cols; + + color = 0; + do + { + SLsmg_gotorc (r1, 0); + SLsmg_set_color (color); color++; color = color % NUM_COLORS; + SLsmg_write_string (" "); + SLsmg_set_color (color); color++; color = color % NUM_COLORS; + SLsmg_write_string ("X"); + SLsmg_set_color (color); color++; color = color % NUM_COLORS; + SLsmg_erase_eol (); + SLsmg_refresh (); + } + while (0 == SLang_input_pending (30)); + SLang_flush_input (); + + color = 0; + do + { + SLsmg_set_color (color); color++; color = color % NUM_COLORS; + SLsmg_fill_region (r0, c0, dr0, dc0, ' '); + + SLsmg_set_color (color); color++; color = color % NUM_COLORS; + SLsmg_fill_region (r0, c1, dr0, dc1, ' '); + + SLsmg_set_color (color); color++; color = color % NUM_COLORS; + SLsmg_fill_region (r1, c0, dr1, dc0, ' '); + + SLsmg_set_color (color); color++; color = color % NUM_COLORS; + SLsmg_fill_region (r1, c1, dr1, dc1, ' '); + + SLsmg_refresh (); + } + while (0 == SLang_input_pending (30)); + + SLsmg_set_color (0); + post_test (); +} + +static void alt_char_test (void) +{ + int row, col; + int ch; + + pre_test ("Alternate Charset Test"); + + row = SLtt_Screen_Rows / 2 - 2; + col = 0; + for (ch = 32; ch < 128; ch++) + { + SLsmg_gotorc (row, col); + SLsmg_write_char (ch); + SLsmg_gotorc (row + 1, col); + SLsmg_set_char_set (1); + SLsmg_write_char (ch); + SLsmg_set_char_set (0); + col++; + + if (col > 40) + { + col = 0; + row += 4; + } + } + + post_test (); +} + +typedef struct +{ + char *name; + unsigned char value; +} +Draw_Symbols_Type; + +static Draw_Symbols_Type Draw_Symbols [] = +{ + {"SLSMG_HLINE_CHAR", SLSMG_HLINE_CHAR}, + {"SLSMG_VLINE_CHAR", SLSMG_VLINE_CHAR}, + {"SLSMG_ULCORN_CHAR", SLSMG_ULCORN_CHAR}, + {"SLSMG_URCORN_CHAR", SLSMG_URCORN_CHAR}, + {"SLSMG_LLCORN_CHAR", SLSMG_LLCORN_CHAR}, + {"SLSMG_LRCORN_CHAR", SLSMG_LRCORN_CHAR}, + {"SLSMG_RTEE_CHAR", SLSMG_RTEE_CHAR}, + {"SLSMG_LTEE_CHAR", SLSMG_LTEE_CHAR}, + {"SLSMG_UTEE_CHAR", SLSMG_UTEE_CHAR}, + {"SLSMG_DTEE_CHAR", SLSMG_DTEE_CHAR}, + {"SLSMG_PLUS_CHAR", SLSMG_PLUS_CHAR}, + {"SLSMG_CKBRD_CHAR", SLSMG_CKBRD_CHAR}, + {"SLSMG_DIAMOND_CHAR", SLSMG_DIAMOND_CHAR}, + {"SLSMG_DEGREE_CHAR", SLSMG_DEGREE_CHAR}, + {"SLSMG_PLMINUS_CHAR", SLSMG_PLMINUS_CHAR}, + {"SLSMG_BULLET_CHAR", SLSMG_BULLET_CHAR}, + {"SLSMG_LARROW_CHAR", SLSMG_LARROW_CHAR}, + {"SLSMG_RARROW_CHAR", SLSMG_RARROW_CHAR}, + {"SLSMG_DARROW_CHAR", SLSMG_DARROW_CHAR}, + {"SLSMG_UARROW_CHAR", SLSMG_UARROW_CHAR}, + {"SLSMG_BOARD_CHAR", SLSMG_BOARD_CHAR}, + {"SLSMG_BLOCK_CHAR", SLSMG_BLOCK_CHAR}, + {NULL} +}; + +static void draw_symbols_test (void) +{ + int row, col; + Draw_Symbols_Type *d; + + pre_test ("Alternate Charset Test"); + + row = 3; + col = 3; + d = Draw_Symbols; + while (d->name != NULL) + { + SLsmg_gotorc (row, col); + SLsmg_set_char_set (1); + SLsmg_write_char ((char) d->value); + SLsmg_set_char_set (0); + SLsmg_printf (":%s", d->name); + col += 40; + if (col >= 80) + { + col = 3; + row++; + } + d++; + } + post_test (); +} + +static void line_test (void) +{ + int row, col; + pre_test ("Line Test"); + + row = 4; + col = 2; + SLsmg_gotorc (row, col); + SLsmg_draw_hline (10); + SLsmg_write_string ("Result of SLsmg_draw_hline(10)"); + SLsmg_draw_vline (5); + SLsmg_write_string ("Result of SLsmg_draw_vline(5)"); + + post_test (); +} + + +static void do_esc_seq_test (char *testname) +{ + int row; + unsigned char ch; + unsigned char buf[80], *b; + + pre_test (testname); + + while (1) + { + row = SLtt_Screen_Rows / 2; + + SLsmg_gotorc (row, 0); + SLsmg_write_string ("Press key: (RETURN quits)"); + SLsmg_refresh (); + + ch = SLang_getkey (); + SLang_ungetkey (ch); + if (ch == '\r') + break; + + SLsmg_gotorc (row+1, 0); + SLsmg_write_string ("Key returned \""); + + b = buf; + do + { + ch = SLang_getkey (); + if (ch < ' ') + { + *b++ = '^'; + ch += '@'; + *b++ = ch; + } + else if (ch >= 127) + { + sprintf ((char *) b, "\\x%02X", ch); + b += strlen ((char *) b); + } + else if ((ch == '"') || (ch == '\\')) + { + *b++ = '\\'; + *b++ = ch; + } + else *b++ = ch; + } + while (SLang_input_pending (3) > 0); + *b++ = '"'; + *b = 0; + SLsmg_write_string ((char *) buf); + SLsmg_erase_eol (); + SLsmg_refresh (); + } + + post_test (); +} + +static void esc_seq_test (void) +{ +#ifdef IBMPC_SYSTEM + SLgetkey_map_to_ansi (0); +#endif + do_esc_seq_test ("Escape Sequence Report"); +} + +#ifdef IBMPC_SYSTEM +static void ansi_esc_seq_test (void) +{ + SLgetkey_map_to_ansi (1); + do_esc_seq_test ("ANSI Escape Sequence Report"); +} +#endif + +static void mouse_test (void) +{ + int row; + int b, x, y; + + pre_test ("Mouse Test"); + + row = SLtt_Screen_Rows / 2; + + SLsmg_gotorc (row, 0); + SLsmg_write_string ("Click Mouse: "); + SLsmg_refresh (); + + if ((27 != SLang_getkey ()) + || ('[' != SLang_getkey ()) + || ('M' != SLang_getkey ())) + { + SLsmg_gotorc (row, 0); + SLsmg_write_string ("That did not appear to be a mouse escape sequence"); + post_test (); + return; + } + + b = SLang_getkey () - ' '; + x = SLang_getkey () - ' '; + y = SLang_getkey () - ' '; + + SLsmg_gotorc (row, 0); SLsmg_printf ("Button: %d ", b); + SLsmg_gotorc (row + 1, 0); SLsmg_printf ("Column: %d", x); + SLsmg_gotorc (row + 2, 0); SLsmg_printf (" Row: %d", y); + + post_test (); +} + +static void mono_test (void) +{ + int row; + int c; + + c = SLtt_Use_Ansi_Colors; + SLtt_Use_Ansi_Colors = 0; + SLsmg_normal_video (); + SLsmg_cls (); + + pre_test ("Mono Test"); + + row = SLtt_Screen_Rows / 2; + SLsmg_set_color(1); + SLsmg_gotorc (row, 0); + + /* Make a gap for testing erase_eol in bw mode */ + SLsmg_write_string ("This line"); + SLsmg_set_color (2); + SLsmg_erase_eol (); + SLsmg_gotorc (row, 30); + SLsmg_write_string ("should be in reverse video"); + + SLsmg_refresh (); + (void) SLkp_getkey (); + SLsmg_gotorc (row, 20); + SLsmg_write_string ("xxxxx"); + SLsmg_refresh (); + post_test (); + SLtt_Use_Ansi_Colors = c; +} + +static void low_level_test (void) +{ + int mid, bot; + int r; + + if (SLtt_Term_Cannot_Scroll) + { + pre_test ("Sorry! Your terminal lacks scrolling capability."); + post_test (); + return; + } + + if (-1 == SLsmg_suspend_smg ()) + SLang_exit_error ("SLsmg_suspend_smg failed"); + + if (-1 == SLtt_init_video ()) + SLang_exit_error ("SLang_init_video failed"); + + SLtt_get_screen_size (); + + mid = SLtt_Screen_Rows/2; + bot = SLtt_Screen_Rows - 1; + + SLtt_cls (); + SLtt_goto_rc (0, 0); + SLtt_write_string ("The following set of tests are designed to test the display system."); + SLtt_goto_rc (1, 0); + SLtt_write_string ("There should be a line of text in the middle and one at the bottom."); + SLtt_goto_rc (mid, 0); + SLtt_write_string ("This line is in the middle."); + SLtt_goto_rc (bot, 0); + SLtt_write_string ("This line is at the bottom."); + + SLtt_goto_rc (2, 0); + SLtt_write_string ("Press return now."); + SLtt_flush_output (); + SLang_flush_input (); + (void) SLang_getkey (); + + SLtt_goto_rc (2, 0); + SLtt_write_string ("The middle row should slowly move down next the bottom and then back up."); + SLtt_goto_rc (mid - 1, 0); + SLtt_write_string ("This line should not move."); + SLtt_goto_rc (mid + 1, 0); + SLtt_write_string ("This line should vanish at the bottom"); + SLtt_goto_rc (mid + 1, SLtt_Screen_Cols - 5); + SLtt_write_string ("End->"); + SLtt_flush_output (); + + SLtt_set_scroll_region (mid, bot - 1); + + r = (bot - mid) - 1; + while (r > 0) + { + (void) SLang_input_pending (2); /* 3/10 sec delay */ + SLtt_goto_rc (0,0); /* relative to scroll region */ + SLtt_reverse_index (1); + SLtt_flush_output (); + r--; + } + + r = (bot - mid) - 1; + while (r > 0) + { + (void) SLang_input_pending (2); /* 3/10 sec delay */ + SLtt_goto_rc (0,0); /* relative to scroll region */ + SLtt_delete_nlines (1); + SLtt_flush_output (); + r--; + } + + SLtt_reset_scroll_region (); + SLtt_goto_rc (mid - 1, 0); + SLtt_write_string ("Now the bottom will come up and clear the lines below"); + + SLtt_set_scroll_region (mid, bot); + r = (bot - mid) + 1; + while (r > 0) + { + (void) SLang_input_pending (2); /* 3/10 sec delay */ + SLtt_goto_rc (0,0); /* relative to scroll region */ + SLtt_delete_nlines (1); + SLtt_flush_output (); + r--; + } + + SLtt_reset_scroll_region (); + SLtt_goto_rc (3,0); + SLtt_write_string ("This line will go down and vanish"); + SLtt_set_scroll_region (3, mid - 2); + + r = ((mid - 2) - 3) + 1; + while (r > 0) + { + (void) SLang_input_pending (3); /* 3/10 sec delay */ + SLtt_goto_rc (0,0); /* relative to scroll region */ + SLtt_reverse_index (1); + SLtt_flush_output (); + r--; + } + + + SLtt_reset_scroll_region (); + SLtt_set_scroll_region (1,1); SLtt_goto_rc (0,0); + SLtt_delete_nlines (1); + SLtt_reset_scroll_region (); + SLtt_set_scroll_region (2,2); SLtt_goto_rc (0,0); + SLtt_reverse_index (1); + SLtt_reset_scroll_region (); + + SLtt_goto_rc (1, 10); + SLtt_write_string ("Press Any Key To Continue."); + SLtt_flush_output (); + r = 15; + if (0 == SLtt_Term_Cannot_Insert) while (r) + { + r--; + SLtt_goto_rc (1, 0); + SLtt_begin_insert (); + SLtt_putchar (' '); + SLtt_end_insert (); + SLtt_flush_output (); + SLang_input_pending (2); + } + + SLang_flush_input (); + (void) SLang_getkey (); + + SLtt_reset_video (); + SLsmg_resume_smg (); +} + diff --git a/libslang/demo/useropen.c b/libslang/demo/useropen.c new file mode 100644 index 0000000..efb2f57 --- /dev/null +++ b/libslang/demo/useropen.c @@ -0,0 +1,119 @@ +/* This demo indicates how to read and parse a S-Lang file by bypassing the + * built-in routines. + */ +#include "config.h" +#include +#include +#ifdef HAVE_STDLIB_H +# include +#endif +#include + +/* Suppose that you want to read input using a read line package + * such as one provided by S-Lang. For generality, lets assume that this + * function is called 'readline' and it is prototyped as: + * int readline (char *prompt, char *buffer); + * where it returns the number of characters read and -1 if end of file. The + * first parameter is a prompt and the second represents the buffer where the + * characters are to placed. Also assume that this routine requires that the + * function 'init_readline' be called first before it can be used and + * 'reset_readline' must be called after using it. + * + * The goal here is to get S-Lang to call the readline function. + */ + +/* For the purposes of this demo, we will use just fgets */ +#define MAX_BUF_LEN 256 +static int readline (char *prompt, char *buf) +{ + fputs (prompt, stdout); fflush (stdout); + if (NULL == fgets (buf, MAX_BUF_LEN, stdin)) return -1; + return (int) strlen (buf); +} + +static int init_readline (void) +{ + puts ("Initializing readline."); fflush (stdout); + return 0; +} + +static void reset_readline (void) +{ + puts ("Resetting readline."); fflush (stdout); +} + +/* Now lets define the function that S-Lang will use to actually read the data. + * It calls readline. S-Lang will call this function and the function must + * return a pointer to the buffer containg the characters of the line or NULL + * upon end of file. In many ways, it is like fgets except that it is passed + * a pointer to SLang_Load_Type in stead of FILE. + */ + +typedef struct +{ + char buf[MAX_BUF_LEN]; + char *prompt; +} +Our_Client_Data_Type; + +static char *read_using_readline (SLang_Load_Type *x) +{ + Our_Client_Data_Type *client_data; + + client_data = (Our_Client_Data_Type *) x->client_data; + if (-1 == readline (client_data->prompt, client_data->buf)) + return NULL; + + return client_data->buf; +} + +/* Now, we all of this is tied together in this routine which will be called + * from main below. + */ + +static int read_input (void) +{ + SLang_Load_Type *x; + Our_Client_Data_Type client_data; + + if (NULL == (x = SLallocate_load_type (""))) + return -1; + + client_data.prompt = "Demo> "; + + x->client_data = (VOID_STAR) &client_data; + x->read = read_using_readline; /* function to call to perform the read */ + SLang_load_object (x); + return 0; +} + +/* Now here is are some intrinsic functions */ + +int main (int argc, char **argv) +{ + /* usual stuff */ + + (void) argc; (void) argv; + + if ((-1 == SLang_init_slang ()) /* basic interpreter functions */ + || (-1 == SLang_init_slmath ()) /* sin, cos, etc... */ +#ifdef unix + || (-1 == SLang_init_slunix ()) /* unix system calls */ +#endif + || (-1 == SLang_init_slfile ())) /* file i/o */ + { + fprintf(stderr, "Unable to initialize S-Lang.\n"); + return 1; + } + + init_readline (); + + read_input (); + + reset_readline (); + return SLang_Error; +} + + + + diff --git a/libslang/doc/OLD/help/README b/libslang/doc/OLD/help/README new file mode 100644 index 0000000..fce6919 --- /dev/null +++ b/libslang/doc/OLD/help/README @@ -0,0 +1,3 @@ +The program this directory `slhelp' is capable of reading VMS style help +files. The program `texconv' in ../doc is able to convert the TeX documents +there to produce VMS style help files. diff --git a/libslang/doc/OLD/help/makefile.djg b/libslang/doc/OLD/help/makefile.djg new file mode 100644 index 0000000..67432c5 --- /dev/null +++ b/libslang/doc/OLD/help/makefile.djg @@ -0,0 +1,18 @@ +CC = gcc +CFLAGS = -Wall -O6 +GO32 = C:\djgpp\bin\go32.exe +SLIB = ../src# +LFLAGS = -L$(SLIB) -lslang -lpc + +SUFFIXES = .c +.SUFFIXES: $(SUFFIXES) + +.c.o: + $(CC) -c $(CFLAGS) -I$(SLIB) $*.c + + +slhelp: slhelp.o + $(CC) slhelp.o $(LFLAGS) -o slhelp.386 + coff2exe -s $(GO32) slhelp.386 + + diff --git a/libslang/doc/OLD/help/makefile.os2 b/libslang/doc/OLD/help/makefile.os2 new file mode 100644 index 0000000..9338fa9 --- /dev/null +++ b/libslang/doc/OLD/help/makefile.os2 @@ -0,0 +1,70 @@ +#================ JED makefile for DMAKE 3.8 ====================== +# This makefile is for DMAKE, either under DOS or OS/2 +# The following OS/Compiler combinations are supported: +# +# Target Compiler Command Compiler +# Operating Mnemoic Line +# System +#----------------------------------------------------------------------- +# OS2 MSC OS=OS2 COMP=MSC Microsoft C +# OS2 EMX OS=OS2 COMP=EMX emx/gcc +#----------------------------------------------------------------------- +MODEL = L +#----------------------------------------------------------------------- +# default setup for EMX under OS/2, optimized version +# change values below or override with -e switch on command line +#----------------------------------------------------------------------- +OS=OS2 +COMP=EMX +OPT=Y +#----------------------------------------------------------------------- +.IF $(TOS) == $(NULL) + TOS = $(OS) +.END +.IF $(OS) == OS2 +#======================================================================== +#========================= OS2 - MSC ==================================== +#======================================================================== + .IF $(COMP) == MSC + CC = cl -nologo -MT + LIB_CMD = lib + .IF $(OPT) == N + CDBUG = -Od -Zi -W2 + LDEBUG = -Zi + .ELSE + CDBUG = + LDEBUG = + .END + CDEBUG = $(CDBUG) + O = .obj + LFLAGS2 = setargv.obj $(SLANG).lib $(SLIB)os2sl16.def -link /NOE $(SLIB) +#======================================================================== +#========================= OS2 - EMX ==================================== +#======================================================================== + .ELIF $(COMP) == EMX + CC = gcc -Zmtd + .IF $(OPT) == N + CDEBUG =-g + LDEBUG = + .ELSE + CDEBUG = -O + LDEBUG = + .END + O = .o + LFLAGS2 = $(SLIB)os2sl.def -L$(SLIB) -l$(SLANG) + .ENDIF +.ENDIF + +CFLAGS=$(CDEBUG) -I$(SLIB) -DHAS_MEMSET +LFLAGS = $(LDEBUG) + +SLIB = ..\src\\ +SLANG = slang + +.c$O: + $(CC) -c $(CFLAGS) $*.c + +slhelp : slhelp.exe + +slhelp.exe: slhelp$O + $(CC) $(LFLAGS) -o $@ slhelp$O $(LFLAGS2) diff --git a/libslang/doc/OLD/help/makefile.unx b/libslang/doc/OLD/help/makefile.unx new file mode 100644 index 0000000..e87eaa0 --- /dev/null +++ b/libslang/doc/OLD/help/makefile.unx @@ -0,0 +1,8 @@ +# Uncomment if you have gcc +# CC = gcc +# +# If you compiled with termcap, uncomment next line. +# THETERMCAP = -ltermcap + +slhelp: slhelp.c + $(CC) $(CFLAGS) slhelp.c -I../src -L../src -o slhelp -lslang $(THETERMCAP) diff --git a/libslang/doc/OLD/help/slang.hlp b/libslang/doc/OLD/help/slang.hlp new file mode 100644 index 0000000..254031e --- /dev/null +++ b/libslang/doc/OLD/help/slang.hlp @@ -0,0 +1,241 @@ +Help file for slang + +1 Interpreter + See readme files for information--- no help file yet. +1 Keyboard-Interface + SLang's keyboard interface is designed to allow one to read a character + at a time in a system independent manner. To initialize the interface, + one must first call the function `SLang_init_tty'. Before exiting the + program, the function `SLang_reset_tty' must be called to restore the + keyboard interface to its original state. This is particularly true for + MSDOS since INT-9 is hooked by S-Lang. + +2 Functions + +3 init_tty + + Prototype: int SLang_init_tty (int abort_char, int flow_ctrl, int opost); + + This function must be called to initialize the tty for single character + input. The first parameter `abort_char' must lie in the range 0-255 and + is used as an abort character. By default, pressing this character sets + the global variable `SLang_Error' to USER_BREAK. See help on the function + `SLang_set_abort_signal' to change the default action. + + If the second parameter `flow_ctrl' is non-zero, flow control is enabled. + + If the third parmeter `opost' is zero, output processing is NOT turned on. + A value of zero is required for SLang's screen management routines (SLsmg) + to work properly. + + This function returns 0 upon success. In addition, if the global variable + SLang_TT_Baud_Rate == 0 when this function is called, SLang will attempt + to determine the terminals baud rate and set this variable accordingly. As + far as the SLang library is concerned, if SLang_TT_Baud_Rate is less than + or equal to zero, the baud rate is effectively infinite. + +3 reset_tty + + Prototype: void SLang_reset_tty (void); + + This function must be called to reset the tty to the state the terminal + was in before a previous call to `SLang_init_tty'. + +3 getkey + + Prototype: unsigned int SLang_getkey (void); + + This function returns a single key from the tty. If the read fails, + 0xFFFF is returned. Before attempting to use this function, one myust + first call SLang_init_tty to initialize the terminal. + + If the abort character is pressed while this function is called, it will + return the value of the abort character. In addition, the global variable + SLKeyBoard_Quit will be set and SLang_Error will will be set to USER_BREAK + unless the variable SLang_Ignore_User_Abort is non-zero. + +3 unget_keystring + + Prototype: void SLang_ungetkey_string (unsigned char *buf, int buflen); + +3 buffer_keystring + + Prototype: void SLang_buffer_keystring (unsigned char *buf, int buflen); + +3 ungetkey + + Prototype: void SLang_ungetkey (unsigned char ch); + +3 flush_input + + Prototype: void SLang_flush_input (void); + +3 input_pending + + Prototype int SLang_input_pending (int tsecs); + +3 set_abort_signal + + Prototype: void SLang_set_abort_signal (void (*f)(int)); + + If SIGINT is generated, the function p1 will be called. If `f' is NULL + the SLang default signal handler is called. This sets SLang_Error to + USER_BREAK. I suspect most users will simply want to pass NULL. + +2 Variables +3 Abort_Char + + int SLang_Abort_Char; + The value of the character (0-255) used to trigger SIGINT + +3 Ignore_User_Abort + + int SLang_Ignore_User_Abort; + If non-zero, pressing the abort character will not result in USER_BREAK + SLang_Error. + +3 KeyBoard_Quit + + volatile int SLKeyBoard_Quit + +3 TT_Baud_Rate + + int SLang_TT_Baud_Rate; + + If this value is zero before SLang_init_tty is called, after the call, it + will be set to the baud rate if the terminal on systems which support it. + +1Screen_Management + S-Lang's screen management routines are located in the slsmg.c file. All + exported functions and variables are prefixed by `SLsmg', e.g., `SLsmg_cls'. + The screen management code uses the `SLtt' routines for writing output to + the terminal. + + To initialize the screen management system, call `SLtt_get_terminfo' first + to initialize the display system. Then call `SLsmg_init_smg' to initialize + the SLsmg routines. If you are going to read characters from the keyboard, + it is also a good idea to initialize the tty at this point via the + SLang_init_tty function (See `Keyboard'). + + Before exiting the program, call the approriate routines to reset the + terminal and display system. Basically, your program will look like + something like: +\begin{verbatim} + #include "slang.h" + + int main () + { + SLtt_get_terminfo (); + SLang_init_tty (7, 0, 0); + SLsmg_init_smg (); + + /* do stuff .... */ + + SLsmg_reset_smg (); + SLang_reset_tty (); + return 0; + } +\end{verbatim} + +2Functions +3erase_eol + Prototype: void SLsmg_erase_eol (void); + Erase line from current position to the end of the line. +3gotorc + Prototype: void SLsmg_gotorc (int row, int col); + Move cursor position to ('row', 'col'). (0,0) corresponds to the top left + corner of the screen. +3erase_eos + Prototype: void SLsmg_erase_eos (void); + Erase fro the current position to the end of the screen. +3reverse_video + Prototype: void SLsmg_reverse_video (void); + Start writing characters in reverse video. +3set_color + Prototype: void SLsmg_set_color (int obj); + Set the character attributes to those of 'obj'. +3normal_video + Prototype: void SLsmg_normal_video (void); + Turn off characters attributes and set attributes to object 0. +3printf + Prototype: void SLsmg_printf (char *, ...); + Write a formatted string to the virtual display. +3vprintf + Prototype: void SLsmg_vprintf (char *, va_list); + Like 'SLsmg_printf' but uses a variable argument list. +3write_string + Prototype: void SLsmg_write_string (char *); +3write_char + Prototype: void SLsmg_write_char (char); +3write_nchars + Prototype: void SLsmg_write_nchars (char *, int); +3cls + Prototype: void SLsmg_cls (void); + Clear the screen +3refresh + Prototype: void SLsmg_refresh (void); + Make the physical display look like the virtual display. +3touch_lines + Prototype: void SLsmg_touch_lines (int row, int n); + Mark screen rows 'row', 'row + 1', ... 'row + (n - 1)' as modified. +3init_smg + Prototype: int SLsmg_init_smg (void); + Must be called before any of the other routines will work. +3reset_smg + Prototype: void SLsmg_reset_smg (void); +3char_at + unsigned short SLsmg_char_at(void); + Prototype: unsigned short SLsmg_char_at(void); + Returns the character and its attributes object number at the current + cursor position. +2Variables + SLsmg_Tab_Width (Default is 8). + +1Searching-Functions + The S-Lang library incorporates two types of searches: Regular expression + pattern matching and ordinary searching. +2Regular-Expressions + + !!! No documentation available yet !!! + +2Simple-Searches + The routines for ordinary searching are defined in the `slsearch.c' file. + To use these routines, simply include "slang.h" in your program and simply + call the appropriate routines. + + The searches can go in either a forward or backward direction and can + either be case or case insensitive. The region that is searched may + contain null characters (ASCII 0) however, the search string cannot in the + current implementation. In addition the length of the string to be found + is currently limited to 256 characters. + + Before searching, the function `SLsearch_init' must first be called to + ``preprocess'' the search string. +3initialization + The function `SLsearch_init' must be called before a search can take place. + Its prototype is: + + int SLsearch_init (char *key, int dir, int case_sens, SLsearch_Type *st); + + Here `key' is the string to be searched for. `dir' specifies the direction + of the search: a value greater than zero is used for searching forward and + a value less than zero is used for searching backward. The parameter + `case_sens' specifies whether the search is case sensitive or not. A + non-zero value indicates that case is important. `st' is a pointer to a + structure of type `SLsearch_Type' defined in "slang.h". This structure is + initialized by this routine and must be passed to `SLsearch' when the + search is actually performed. + + This routine returns the length of the string to be searched for. + +3SLsearch + Prototype: unsigned char *SLsearch (unsigned char *pmin, unsigned char *pmax, + SLsearch_Type *st); + + This function performs the search defined by a previous call to + `SLsearch_init' over a region specified by the pointers `pmin' and `pmax'. + + It returns a pointer to the start of the match if successful or it will + return NULL if a match was not found. + + diff --git a/libslang/doc/OLD/help/slhelp.c b/libslang/doc/OLD/help/slhelp.c new file mode 100644 index 0000000..be7638f --- /dev/null +++ b/libslang/doc/OLD/help/slhelp.c @@ -0,0 +1,587 @@ +#include "config.h" + +#include + +#ifdef unix +# include +#endif + +#include "slang.h" +#include "jdmacros.h" + +#ifndef HELP_DIR +#define HELP_DIR "" +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#endif + + +typedef struct SLhlp_Node_Type +{ + char *name; + struct SLhlp_Node_Type *child; + struct SLhlp_Node_Type *sister; + unsigned long pos; +} SLhlp_Node_Type; + +typedef struct +{ + FILE *fp; + SLhlp_Node_Type *root; + SLhlp_Node_Type *sub; /* current subtopic node */ + SLhlp_Node_Type *now; /* Node we are currently reading from */ + SLhlp_Node_Type *path[10]; /* path to current node */ + int level; +} SLhlp_File_Type; + +#define MAX_HELP_FILES 10 + +SLhlp_File_Type Help_Files[MAX_HELP_FILES]; + + +static int add_level (int level, int fd, char *name, unsigned long pos) +{ + SLhlp_Node_Type *node, *parent, *new_node; + int len; + + while (*name == ' ') name++; + len = strlen(name); + + if (len) while (name[len - 1] == ' ') len--; + if (len == 0) return -1; + name[len] = 0; + + parent = node = Help_Files[fd].root; + while (level-- > 0) + { + if (node == NULL) + { + return -1; + } + while (node->sister != NULL) node = node->sister; + parent = node; + node = node->child; + } + + + if ((NULL == (new_node = (SLhlp_Node_Type *) SLMALLOC (sizeof (SLhlp_Node_Type)))) + || (NULL == (new_node->name = (char *) SLMALLOC (len + 1)))) + { + SLang_Error = SL_MALLOC_ERROR; + return -1; + } + + new_node->sister = NULL; + new_node->child = NULL; + new_node->pos = pos; + strcpy (new_node->name, name); + + if (node == NULL) + { + if (parent == NULL) + { + Help_Files[fd].root = new_node; + } + else parent->child = new_node; + } + else + { + while (node->sister != NULL) node = node->sister; + node->sister = new_node; + } + return 0; +} + + +static void free_nodes (SLhlp_Node_Type *node) +{ + if (node->child != NULL) free_nodes (node->child); + if (node->sister != NULL) free_nodes (node->sister); + if (node->name != NULL) SLFREE (node->name); + SLFREE (node); +} + + + +static int check_fd (int fd) +{ + if (((fd >= MAX_HELP_FILES) || (fd < 0)) || (Help_Files[fd].fp == NULL)) + { + if (SLang_Error == 0) SLang_Error = INTRINSIC_ERROR; + return 0; + } + return 1; +} + + +static void SLhlp_close_help (int fd) +{ + if (!check_fd (fd)) return; + fclose (Help_Files[fd].fp); Help_Files[fd].fp = NULL; + if (Help_Files[fd].root != NULL) free_nodes (Help_Files[fd].root); +} + + +static int SLhlp_open_help (char *file) +{ + int fd = 0, ch; + FILE *fp; + int level; + char topic[256], *b; + unsigned long pos; + + while ((fd < MAX_HELP_FILES) && (Help_Files[fd].fp != NULL)) + fd++; + + if (fd == MAX_HELP_FILES) return -1; + if (NULL == (Help_Files[fd].fp = fp = fopen (file, "r"))) return -1; + + + while (1) + { + ch = getc (fp); + + bypass_getc: + + if ((ch > '9') || (ch == ' ')) continue; + if (ch == '\n') + { + ch = getc (fp); + if ((ch == ' ') || (ch > '9')) continue; + if (ch >= '1') + { + level = ch - '1'; + pos = ftell (fp); + b = topic; + while (('\n' != (ch = getc (fp))) && (ch != EOF)) + { + *b++ = ch; + } + *b = 0; + if (add_level (level, fd, topic, pos)) goto error; + } + goto bypass_getc; + } + if (ch == EOF) break; + } + + Help_Files[fd].now = NULL; + Help_Files[fd].sub = Help_Files[fd].root; + Help_Files[fd].path[0] = NULL; + + return fd; + + + error: + SLhlp_close_help (fd); + return -1; +} + +static char *SLhlp_get_subtopic (int fd) +{ + SLhlp_Node_Type *node; + + if (!check_fd(fd)) return NULL; + if ((node = Help_Files[fd].sub) == NULL) return NULL; + + Help_Files[fd].sub = node->sister; + return node->name; +} + + +static char *SLhlp_gets (int fd, char *buf) +{ + SLhlp_Node_Type *node; + char ch; + + + if (!check_fd(fd)) return NULL; + + node = Help_Files[fd].now; + if (node == NULL) return NULL; + + if ((NULL == fgets(buf, 255, Help_Files[fd].fp)) + || ((*buf <= '9') && (*buf >= '0'))) + { + if ((node->child == NULL) && Help_Files[fd].level) + { + Help_Files[fd].level--; + } + Help_Files[fd].now = NULL; + return NULL; + } + + /* First character is reserved. */ + if (*buf > ' ') + { + ch = *buf | 0x20; + if ((ch < 'a') || (ch > 'z')) + { + *buf = '\n'; + *(buf + 1) = 0; + } + } + + return buf; +} + +static int my_strncasecmp (char *a, char *b, int n) +{ + register char cha, chb; + + while (n--) + { + cha = *a++; + chb = *b++; + if (cha != 0) + { + if ((cha == chb) + || ((cha | 0x20) == (chb | 0x20))) continue; + } + return cha - chb; + } + return 0; +} + + + +static int SLhlp_select_topic (int fd, char *topic) +{ + char topic_buf[256]; + char *t, ch; + int level = 0; + int len; + + SLhlp_Node_Type *node, *parent; + + if (!check_fd (fd)) return -1; + + parent = node = Help_Files[fd].root; + + ch = 0; + if (topic != NULL) + while (((ch = *topic) <= ' ') && ch) topic++; + + if (ch != 0) while (node != NULL) + { + parent = node; + t = topic_buf; + + while ((ch = *topic) > ' ') + { + *t++ = ch; + topic++; + } + while (((ch = *topic) <= ' ') && ch) topic++; + *t = 0; + + len = strlen (topic_buf); + + + if (len) while (my_strncasecmp (node->name, topic_buf, len)) + { + node = node->sister; + if (node == NULL) break; + } + + if (node == NULL) break; + Help_Files[fd].path[level++] = node; + if ((ch == 0) || (ch == '\n')) break; + node = node -> child; + } + + /* level comes out at 1 greater than last valid one */ + Help_Files[fd].level = level; + + if (node != NULL) /* success */ + { + Help_Files[fd].sub = node->child; + Help_Files[fd].now = node; + fseek (Help_Files[fd].fp, node->pos, SEEK_SET); + return 0; + } + else /* failure */ + { + Help_Files[fd].now = NULL; + Help_Files[fd].sub = parent; + return -1; + } +} + +static int SLhlp_what_topic (int fd, char *buf) +{ + int level, i; + char *b; + if (!check_fd(fd)) return -1; + + level = Help_Files[fd].level; + *buf = 0; + if (level == 0) return 0; + + b = buf; + for (i = 0; i < level; i++) + { + strcpy (b, Help_Files[fd].path[i]->name); + b = b + strlen (b); + *b++ = ' '; + } + *(b - 1) = 0; + return level; +} + +static int SLhlp_up_topic (int fd) +{ + if (!check_fd(fd)) return -1; + + if (Help_Files[fd].level) Help_Files[fd].level--; + return 0; +} + + + + +/* --------------------------------------------------------------------- */ + +static void cls (void) +{ + SLtt_cls (); + SLtt_flush_output (); +} + + +static void newline (int nl, int reset, int cls_flag) +{ + static int n; + + if (nl) putc('\n', stdout); + n++; + + if (n == SLtt_Screen_Rows - 1) + { + SLtt_reverse_video (1); + SLtt_write_string ("---Press RETURN to continue.---"); + SLtt_normal_video (); + SLtt_flush_output (); + + SLang_getkey (); + if (cls_flag) cls (); + else + fputs("\r \r", stdout); + + cls_flag = 0; + n = 0; + } + + if (reset) + { + n = 0; + if (cls_flag) cls (); + return; + } +} + +SLang_RLine_Info_Type *Help_Rli; + +static SLang_RLine_Info_Type *init_readline (void) +{ + unsigned char *buf = NULL; + SLang_RLine_Info_Type *rli; + + if ((NULL == (rli = (SLang_RLine_Info_Type *) SLMALLOC (sizeof(SLang_RLine_Info_Type)))) + || (NULL == (buf = (unsigned char *) SLMALLOC (256)))) + { + fprintf(stderr, "malloc error.\n"); + exit(-1); + } + + SLMEMSET ((char *) rli, 0, sizeof (SLang_RLine_Info_Type)); + rli->buf = buf; + rli->buf_len = 255; + rli->tab = 8; + rli->dhscroll = 20; + rli->getkey = SLang_getkey; + rli->tt_goto_column = NULL; + rli->update_hook = NULL; + + if (SLang_init_readline (rli) < 0) + { + fprintf(stderr, "Unable to initialize readline library.\n"); + exit (-1); + } + + return rli; +} + +static char *hlp_get_input (char *prompt) +{ + int i; + + if (Help_Rli == NULL) + { + Help_Rli = init_readline (); + Help_Rli->update_hook = NULL; + } + + Help_Rli->edit_width = SLtt_Screen_Cols - 1; + Help_Rli->prompt = prompt; + *Help_Rli->buf = 0; + + + i = SLang_read_line (Help_Rli); + + if ((i >= 0) && !SLang_Error && !SLKeyBoard_Quit) + { + SLang_rline_save_line (Help_Rli); + } + else return NULL; + + return (char *) Help_Rli->buf; +} + + +static void do_subtopics (int fd) +{ + char *s; + int len, dlen; + + if ((s = SLhlp_get_subtopic (fd)) != NULL) + { + len = 0; + newline (1, 0, 0); + fprintf(stdout, "Available Topics/Subtopics:"); + newline (1, 0, 0); + newline (1, 0, 0); + do + { + dlen = strlen (s); + len += dlen; + + if (len >= 80) + { + len = dlen; + newline (1, 0, 0); + } + fputs(s, stdout); + dlen = 21 - len % 20; + len += dlen; + if (len < 80) + { + while (dlen--) putc(' ', stdout); + } + } + while (NULL != (s = SLhlp_get_subtopic(fd))); + newline (1, 0, 0); + } +} + +static void get_screen_size (int sig) +{ + SLtt_get_screen_size (); +#ifdef SIGWINCH + signal (SIGWINCH, get_screen_size); +#endif +} + + + +int main (int argc, char **argv) +{ + char *buf, *file; + char buffer[256]; + static int fd = -1; + int len; + + if (argc != 2) + { + fprintf(stderr, "Usage: slhelp HELP-FILE\n"); + exit (-1); + } + + file = argv[1]; + if (fd < 0) fd = SLhlp_open_help (file); + if (fd < 0) + { + fprintf (stderr, "Unable to open help file %s\n", file); + exit (-1); + } + + SLang_init_tty (7, 1, 1); + SLtt_get_terminfo (); + SLtt_init_video (); + SLtt_Use_Ansi_Colors = 0; + +#ifdef SIGWINCH + signal (SIGWINCH, get_screen_size); +#endif + + get_screen_size (0); + cls (); + + fputs ("\n\nSimply press RETURN at the 'Topic>' prompt to quit help.\n\n", + stdout); + + if (SLhlp_what_topic (fd, buffer) > 0) + { + SLhlp_select_topic (fd, buffer); + } + + while (1) + { + while (1) + { + if (SLhlp_what_topic (fd, buffer) <= 0) + { + SLhlp_select_topic (fd, "?"); + *buffer = 0; + } + do_subtopics (fd); + + len = strlen (buffer); + if (len) strcat (buffer, " Subtopic> "); + else strcpy (buffer, "Topic> "); + newline (1, 1, 0); + + if (NULL == (buf = hlp_get_input (buffer))) + { + SLang_Error = 0; + if (SLKeyBoard_Quit) + { + SLKeyBoard_Quit = 0; + continue; + } + goto the_return; + } + + if ((*buf == '\n') || (*buf == 0)) + { + if (len == 0) goto the_return; + SLhlp_up_topic (fd); + continue; + } + + buffer[len] = ' '; /* kill prompt */ + strcpy (buffer + (len + 1), buf); + break; + } + + newline (1, 1, 1); + if (-1 == SLhlp_select_topic (fd, buffer)) + { + fprintf(stdout, "No help available on: %s", buf); + newline (1, 0, 0); + } + else while (NULL != SLhlp_gets (fd, buffer)) + { + fputs(buffer, stdout); + newline (0, 0, 1); + } + } + + the_return: + + SLtt_reset_video (); + SLang_reset_tty (); + return 0; +} diff --git a/libslang/doc/README b/libslang/doc/README new file mode 100644 index 0000000..32612e8 --- /dev/null +++ b/libslang/doc/README @@ -0,0 +1,25 @@ +The documentation here is provided in text format. Documentation in +SGML, HTML, TeX, and postscript formats are also available from +ftp://space.mit.edu/pub/davis/slang/slang-doc.tar.gz as well as the +mirror sites. In addition, the documentation is available on-line from +http://space.mit.edu/%7Edavis/slang-doc.html. + +The text subdirectory contains: + + text/slang.txt Documentation describing the slang language + text/cslang.txt C programmer's guide to the library + text/cref.txt Reference Manual for the C functions + text/slangfun.txt Reference Manual for the slang intrinsic functions + +There may be additional subdirectories: + + tm/ Text-Macro source for documentation + html/ Documentation in HTML form + text/ Documentation in text form + ps/ Documentation in postscript (from LaTeX) + sgml/ SGML source + +The documentation was created by SGML-Tools from SGML format, which +itself was created from text-macro source. The LaTeX2e output +produced by SGML-Tools needs some additional tweaking by the script +tm/fixtex.sl. diff --git a/libslang/doc/grammar.txt b/libslang/doc/grammar.txt new file mode 100644 index 0000000..0c69b37 --- /dev/null +++ b/libslang/doc/grammar.txt @@ -0,0 +1,131 @@ +This grammar was derived from slparse.c + +statement: + compound-statement + if ( expression ) statement + if ( expression ) statement else statement + !if ( expression ) statement + loop ( expression ) statement + _for ( expression ) statement + while ( expression ) statement + do statement while (expression) ; + for ( expressionopt ; expressionopt ; expressionopt ) statement + ERROR_BLOCK statement + EXIT_BLOCK statement + USER_BLOCK0 statement + USER_BLOCK1 statement + USER_BLOCK2 statement + USER_BLOCK3 statement + USER_BLOCK4 statement + forever statement + break ; + continue ; + return expressionopt ; + variable variable-list ; + struct struct-decl ; + define identifier function-args ; + define identifier function-args compound-statement + switch ( expression ) statement + rpn-line + at-line + push ( expression ) + ( expression ) = expression ; + expression ; + expression : + + + +statement-list: + statement + statement-list statement + + +compound-statement: + { statement-list } + + +variable-list: + variable-decl + variable-decl variable-list + +variable-decl: + identifier + identifier = simple-expression + + +struct-declaration: + struct { struct-field-list }; + +struct-field-list: + struct-field-name , struct-field-list + struct-field-name + +struct-declaration: + typedef struct { struct-field-list } Type_Name; + +struct-field-list: + struct-field-name , struct-field-list + struct-field-name + +function-args: + ( args-dec-opt ) + +args-decl-opt: + identifier + args-decl , identifier + +expression: + simple_expression + simple-expression , expression + + + +% Note: simple-expression groups operators OP1 at same level. The +% actual implementation will not do this. +simple-expression: + unary-expression + binary-expression BINARY-OP unary-expression + andelse xxelse-expression-list + orelse xxelse-expression-list + +xxelse-expression-list: + { expression } + xxelse-expression-list { expression } +binary-expression: + unary-expression + unary-expression BINARY-OP binary-expression + +unary-expression: + postfix-expression + ++ postfix-expression + -- postfix-expression + case unary-expression + OP3 unary-expression + (OP3: + - ~ & not @) + +postfix-expression: + primary-expression + postfix-expression [ expression ] + postfix-expression ( function-args-expression ) + postfix-expression . identifier + postfix-expression ^ unary-expression + postfix-expression ++ + postfix-expression -- + postfix-expression = simple-expression + postfix-expression += simple-expression + postfix-expression -= simple-expression + +primary-expression: + literal + identifier + ( expression_opt ) + [ inline-array-expression ] + &identifier + struct-definition + __tmp(literal) + +inline-array-expression: + expression + expression : expression + expression : expression : expression + diff --git a/libslang/doc/internal/rpn.txt b/libslang/doc/internal/rpn.txt new file mode 100644 index 0000000..e613021 --- /dev/null +++ b/libslang/doc/internal/rpn.txt @@ -0,0 +1,60 @@ +Variable Assignment: + x = --> =x + x += --> +=x + x -= --> -=x + x++ --> ++x + x-- --> --x + Note: The current version of slang does not distguish between the + post and pre-increment operators. A future version may make a + distinction and assignment statements may return a value. + + +Function Definition: define f (arg1, ..., argN) { statements } + --> ( [ arg1 arg2 ... argN ] =argN ... =arg1 rpn-statements ) f + +Variable Declaration: variable x1, ... xN; + --> [ x1 ... xN ] + +Structure Definition: struct {f1, ... fN} + --> "f1" ... "fN" N struct + +Structure Typedef: typedef struct { f1, ... fN } Type_Name ; + --> __typedef f1 ... fN ] "Type_Name" + +Multiple Assignment Expression: (x1, ..., xN) = expression + --> rpn-expression =xN ... =x1 + Note: If xj is missing, it will be replaced by `pop' + +Function call: f (x1, ..., xN) + --> __arg x1 ... xN __earg f + Note: if xj is missing, it will be replaced by NULL + +Array reference: X [x1, .., xN] + --> __arg x1 ... xN X __aget + Note: __earg is implicit + +Array assignment: X [x1, ... xN] ASSIGNMENT-OP + --> __arg x1 ... xN X RPN-ASSIGNMENT-OP + ASSIGNMENT-OP: + = --> __aput + ++ --> __aput_plusplus + -- --> __aput_minusminus + += --> __aput_pluseqs + -= --> __aput_minuseqs + Note: __earg is implicit + +Structure Reference: X.a --> "a" X . + +Structure Assignment: X.a ASSIGNMENT-OP expression; + --> rpn-expression "a" X RPN-ASSIGNMENT-OP + ASSIGNMENT-OP --> RPN-ASSIGNMENT-OP: + = --> __struct_eqs + += --> __struct_pluseqs + -= --> __struct_minuseqs + -- --> __struct_minusminus + ++ --> __struct_plusplus + +Variable Alias: &x --> __alias x + +foreach (X) using (Y,...) block + --> X __arg Y... __earg { block } foreach diff --git a/libslang/doc/slangdoc.html b/libslang/doc/slangdoc.html new file mode 100644 index 0000000..97ef431 --- /dev/null +++ b/libslang/doc/slangdoc.html @@ -0,0 +1,27 @@ + + +Index + + +The slang documentation available online from + +http://www.s-lang.org/docs.html.

+ +The entire documentation (HTML, SGML, text, postscript, and +text-macro formats) is also available for download from + +ftp://space.mit.edu/pub/davis/slang/

+ +If you have downloaded the above file, then the following local links should +work:

+ +A Guide to the S-Lang Language

+ +S-Lang Library Programmer's Guide

+ +Intrinsic Function Reference

+ +C Library Reference

+ + + diff --git a/libslang/doc/text/cref.txt b/libslang/doc/text/cref.txt new file mode 100644 index 0000000..fca54da --- /dev/null +++ b/libslang/doc/text/cref.txt @@ -0,0 +1,4870 @@ +SLsmg_fill_region + + SYNOPSIS + Fill a rectangular region with a character + + USAGE + void SLsmg_fill_region (r, c, nr, nc, ch) + + int r + int c + unsigned int nr + unsigned int nc + unsigned char ch + + + DESCRIPTION + The `SLsmg_fill_region' function may be used to a + rectangular region with the character `ch' in the current color. + The rectangle's upper left corner is at row `r' and column + `c', and spans `nr' rows and `nc' columns. The position + of the virtual cursor will be left at (`r', `c'). + + SEE ALSO + SLsmg_write_char, SLsmg_set_color +-------------------------------------------------------------- + +SLsmg_set_char_set + + SYNOPSIS + Turn on or off line drawing characters + + USAGE + void SLsmg_set_char_set (int a); + + DESCRIPTION + `SLsmg_set_char_set' may be used to select or deselect the line drawing + character set as the current character set. If `a' is non-zero, + the line drawing character set will be selected. Otherwise, the + standard character set will be selected. + + NOTES + There is no guarantee that this function will actually enable the + use of line drawing characters. All it does is cause subsequent + characters to be rendered using the terminal's alternate character + set. Such character sets usually contain line drawing characters. + + SEE ALSO + SLsmg_write_char, SLtt_get_terminfo +-------------------------------------------------------------- + +int SLsmg_Scroll_Hash_Border; + + SYNOPSIS + Set the size of the border for the scroll hash + + USAGE + int SLsmg_Scroll_Hash_Border = 0; + + DESCRIPTION + This variable may be used to ignore the characters that occur at the + beginning and the end of a row when performing the hash calculation + to determine whether or not a line has scrolled. The default value + is zero which means that all the characters on a line will be used. + + SEE ALSO + SLsmg_refresh +-------------------------------------------------------------- + +SLsmg_suspend_smg + + SYNOPSIS + Suspend screen management + + USAGE + int SLsmg_suspend_smg (void) + + DESCRIPTION + `SLsmg_suspend_smg' can be used to suspend the state of the + screen management facility during suspension of the program. Use of + this function will reset the display back to its default state. The + funtion `SLsmg_resume_smg' should be called after suspension. + + It returns zero upon success, or -1 upon error. + + This function is similar to `SLsmg_reset_smg' except that the + state of the display prior to calling `SLsmg_suspend_smg' is saved. + + SEE ALSO + SLsmg_resume_smg, SLsmg_reset_smg +-------------------------------------------------------------- + +SLsmg_resume_smg + + SYNOPSIS + Resume screen management + + USAGE + int SLsmg_resume_smg (void) + + DESCRIPTION + `SLsmg_resume_smg' should be called after + `SLsmg_suspend_smg' to redraw the display exactly like it was + before `SLsmg_suspend_smg' was called. It returns zero upon + success, or -1 upon error. + + SEE ALSO + SLsmg_suspend_smg +-------------------------------------------------------------- + +SLsmg_erase_eol + + SYNOPSIS + Erase to the end of the row + + USAGE + void SLsmg_erase_eol (void); + + DESCRIPTION + `SLsmg_erase_eol' erases all characters from the current + position to the end of the line. The newly created space is given + the color of the current color. This function has no effect on the + position of the virtual cursor. + + SEE ALSO + SLsmg_gotorc, SLsmg_erase_eos, SLsmg_fill_region +-------------------------------------------------------------- + +SLsmg_gotorc + + SYNOPSIS + Move the virtual cursor + + USAGE + void SLsmg_gotorc (int r, int c) + + DESCRIPTION + The `SLsmg_gotorc' function moves the virtual cursor to the row + `r' and column `c'. The first row and first column is + specified by `r = 0' and `c = 0'. + + SEE ALSO + SLsmg_refresh +-------------------------------------------------------------- + +SLsmg_erase_eos + + SYNOPSIS + Erase to the end of the screen + + USAGE + void SLsmg_erase_eos (void); + + DESCRIPTION + The `SLsmg_erase_eos' is like `SLsmg_erase_eol' except that + it erases all text from the current position to the end of the + display. The current color will be used to set the background of + the erased area. + + SEE ALSO + SLsmg_erase_eol +-------------------------------------------------------------- + +SLsmg_reverse_video + + SYNOPSIS + Set the current color to 1 + + USAGE + void SLsmg_reverse_video (void); + + DESCRIPTION + This function is nothing more than `SLsmg_set_color(1)'. + + SEE ALSO + SLsmg_set_color +-------------------------------------------------------------- + +SLsmg_set_color (int) + + SYNOPSIS + Set the current color + + USAGE + void SLsmg_set_color (int c); + + DESCRIPTION + `SLsmg_set_color' is used to set the current color. The + parameter `c' is really a color object descriptor. Actual + foreground and background colors as well as other visual attributes + may be associated with a color descriptor via the + `SLtt_set_color' function. + + EXAMPLE + This example defines color `7' to be green foreground on black + background and then displays some text in this color: + + SLtt_set_color (7, NULL, "green", "black"); + SLsmg_set_color (7); + SLsmg_write_string ("Hello"); + SLsmg_refresh (); + + + NOTES + It is important to understand that the screen managment routines + know nothing about the actual colors associated with a color + descriptor. Only the descriptor itself is used by the `SLsmg' + routines. The lower level `SLtt' interface converts the color + descriptors to actual colors. Thus + + SLtt_set_color (7, NULL, "green", "black"); + SLsmg_set_color (7); + SLsmg_write_string ("Hello"); + SLtt_set_color (7, NULL, "red", "blue"); + SLsmg_write_string ("World"); + SLsmg_refresh (); + + will result in `"hello"' displayed in red on blue and _not_ + green on black. + + SEE ALSO + SLtt_set_color, SLtt_set_color_object +-------------------------------------------------------------- + +SLsmg_normal_video + + SYNOPSIS + Set the current color to 0 + + USAGE + void SLsmg_normal_video (void); + + DESCRIPTION + `SLsmg_normal_video' sets the current color descriptor to `0'. + + SEE ALSO + SLsmg_set_color +-------------------------------------------------------------- + +SLsmg_printf + + SYNOPSIS + Format a string on the virtual display + + USAGE + void SLsmg_printf (char *fmt, ...) + + DESCRIPTION + `SLsmg_printf' format a `printf' style variable argument + list and writes it on the virtual display. The virtual cursor will + be moved to the end of the string. + + SEE ALSO + SLsmg_write_string, SLsmg_vprintf +-------------------------------------------------------------- + +SLsmg_vprintf + + SYNOPSIS + Format a string on the virtual display + + USAGE + void SLsmg_vprintf (char *fmt, va_list ap) + + DESCRIPTION + `SLsmg_vprintf' formats a string in the manner of _vprintf_ + and writes the result to the display. The virtual cursor is + advanced to the end of the string. + + SEE ALSO + SLsmg_write_string, SLsmg_printf +-------------------------------------------------------------- + +SLsmg_write_string + + SYNOPSIS + Write a character string on the display + + USAGE + void SLsmg_write_string (char *s) + + DESCRIPTION + The function `SLsmg_write_string' displays the string `s' on + the virtual display at the current position and moves the position + to the end of the string. + + SEE ALSO + SLsmg_printf, SLsmg_write_nstring +-------------------------------------------------------------- + +SLsmg_write_nstring + + SYNOPSIS + Write the first n characters of a string on the display + + USAGE + void SLsmg_write_nstring (char *s, unsigned int n); + + DESCRIPTION + `SLsmg_write_nstring' writes the first `n' characters of + `s' to this virtual display. If the length of the string + `s' is less than `n', the spaces will used until + `n' characters have been written. `s' can be `NULL', in + which case `n' spaces will be written. + + SEE ALSO + SLsmg_write_string, SLsmg_write_nchars +-------------------------------------------------------------- + +SLsmg_write_char + + SYNOPSIS + Write a character to the virtual display + + USAGE + void SLsmg_write_char (char ch); + + DESCRIPTION + `SLsmg_write_char' writes the character `ch' to the virtual + display. + + SEE ALSO + SLsmg_write_nchars, SLsmg_write_string +-------------------------------------------------------------- + +SLsmg_write_nchars + + SYNOPSIS + Write n characters to the virtual display + + USAGE + void SLsmg_write_nchars (char *s, unsigned int n); + + DESCRIPTION + `SLsmg_write_nchars' writes at most `n' characters from the + string `s' to the display. If the length of `s' is less + than `n', the whole length of the string will get written. + + This function differs from `SLsmg_write_nstring' in that + `SLsmg_write_nstring' will pad the string to write exactly + `n' characters. `SLsmg_write_nchars' does not perform any + padding. + + SEE ALSO + SLsmg_write_nchars, SLsmg_write_nstring +-------------------------------------------------------------- + +SLsmg_write_wrapped_string + + SYNOPSIS + Write a string to the display with wrapping + + USAGE + void SLsmg_write_wrapped_string (s, r, c, nr, nc, fill) + + char *s + int r, c + unsigned int nr, nc + int fill + + + DESCRIPTION + `SLsmg_write_wrapped_string' writes the string `s' to the + virtual display. The string will be confined to the rectangular + region whose upper right corner is at row `r' and column `c', + and consists of `nr' rows and `nc' columns. The string will + be wrapped at the boundaries of the box. If `fill' is non-zero, + the last line to which characters have been written will get padded + with spaces. + + NOTES + This function does not wrap on word boundaries. However, it will + wrap when a newline charater is encountered. + + SEE ALSO + SLsmg_write_string +-------------------------------------------------------------- + +SLsmg_cls + + SYNOPSIS + Clear the virtual display + + USAGE + void SLsmg_cls (void) + + DESCRIPTION + `SLsmg_cls' erases the virtual display using the current color. + This will cause the physical display to get cleared the next time + `SLsmg_refresh' is called. + + NOTES + This function is not the same as + + SLsmg_gotorc (0,0); SLsmg_erase_eos (); + + since these statements do not guarantee that the physical screen + will get cleared. + + SEE ALSO + SLsmg_refresh, SLsmg_erase_eos +-------------------------------------------------------------- + +SLsmg_refresh + + SYNOPSIS + Update physical screen + + USAGE + void SLsmg_refresh (void) + + DESCRIPTION + The `SLsmg_refresh' function updates the physical display to + look like the virtual display. + + SEE ALSO + SLsmg_suspend_smg, SLsmg_init_smg, SLsmg_reset_smg +-------------------------------------------------------------- + +SLsmg_touch_lines + + SYNOPSIS + Mark lines on the virtual display for redisplay + + USAGE + void SLsmg_touch_lines (int r, unsigned int nr) + + DESCRIPTION + `SLsmg_touch_lines' marks the `nr' lines on the virtual + display starting at row `r' for redisplay upon the next call to + `SLsmg_refresh'. + + NOTES + This function should rarely be called, if ever. If you find that + you need to call this function, then your application should be + modified to properly use the `SLsmg' screen management routines. + This function is provided only for curses compatibility. + + SEE ALSO + SLsmg_refresh +-------------------------------------------------------------- + +SLsmg_init_smg + + SYNOPSIS + Initialize the var{SLsmg + + USAGE + int SLsmg_init_smg (void) + + DESCRIPTION + The `SLsmg_init_smg' function initializes the `SLsmg' screen + management routines. Specifically, this function allocates space + for the virtual display and calls `SLtt_init_video' to put the + terminal's physical display in the proper state. It is up to the + caller to make sure that the `SLtt' routines are initialized via + `SLtt_get_terminfo' before calling `SLsmg_init_smg'. + + This function should also be called any time the size of the + physical display has changed so that it can reallocate a new virtual + display to match the physical display. + + It returns zero upon success, or -1 upon failure. + + SEE ALSO + SLsmg_reset_smg +-------------------------------------------------------------- + +SLsmg_reset_smg + + SYNOPSIS + Reset the var{SLsmg + + USAGE + int SLsmg_reset_smg (void); + + DESCRIPTION + `SLsmg_reset_smg' resets the `SLsmg' screen management + routines by freeing all memory allocated while it was active. It + also calls `SLtt_reset_video' to put the terminal's display in + it default state. + + SEE ALSO + SLsmg_init_smg +-------------------------------------------------------------- + +SLsmg_char_at + + SYNOPSIS + Get the character at the current position on the virtual display + + USAGE + unsigned short SLsmg_char_at(void) + + DESCRIPTION + The `SLsmg_char_at' function returns the character and its color + at the current position on the virtual display. + + SEE ALSO + SLsmg_read_raw, SLsmg_write_char +-------------------------------------------------------------- + +SLsmg_set_screen_start + + SYNOPSIS + Set the origin of the virtual display + + USAGE + void SLsmg_set_screen_start (int *r, int *c) + + DESCRIPTION + `SLsmg_set_screen_start' sets the origin of the virtual display + to the row `*r' and the column `*c'. If either `r' or `c' + is `NULL', then the corresponding value will be set to `0'. + Otherwise, the location specified by the pointers will be updated to + reflect the old origin. + + See \tt{slang/demo/pager.c} for how this function may be used to + scroll horizontally. + + SEE ALSO + SLsmg_init_smg +-------------------------------------------------------------- + +SLsmg_draw_hline + + SYNOPSIS + Draw a horizontal line + + USAGE + void SLsmg_draw_hline (unsigned int len) + + DESCRIPTION + The `SLsmg_draw_hline' function draws a horizontal line of + length `len' on the virtual display. The position of the + virtual cursor is left at the end of the line. + + SEE ALSO + SLsmg_draw_vline +-------------------------------------------------------------- + +SLsmg_draw_vline + + SYNOPSIS + Draw a vertical line + + USAGE + void SLsmg_draw_vline (unsigned int len); + + DESCRIPTION + The `SLsmg_draw_vline' function draws a vertical line of + length `len' on the virtual display. The position of the + virtual cursor is left at the end of the line. + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLsmg_draw_object + + SYNOPSIS + Draw an object from the alternate character set + + USAGE + void SLsmg_draw_object (int r, int c, unsigned char obj) + + DESCRIPTION + The `SLsmg_draw_object' function may be used to place the object + specified by `obj' at row `r' and column `c'. The + object is really a character from the alternate character set and + may be specified using one of the following constants: + + SLSMG_HLINE_CHAR Horizontal line + SLSMG_VLINE_CHAR Vertical line + SLSMG_ULCORN_CHAR Upper left corner + SLSMG_URCORN_CHAR Upper right corner + SLSMG_LLCORN_CHAR Lower left corner + SLSMG_LRCORN_CHAR Lower right corner + SLSMG_CKBRD_CHAR Checkboard character + SLSMG_RTEE_CHAR Right Tee + SLSMG_LTEE_CHAR Left Tee + SLSMG_UTEE_CHAR Up Tee + SLSMG_DTEE_CHAR Down Tee + SLSMG_PLUS_CHAR Plus or Cross character + + + SEE ALSO + SLsmg_draw_vline, SLsmg_draw_hline, SLsmg_draw_box +-------------------------------------------------------------- + +SLsmg_draw_box + + SYNOPSIS + Draw a box on the virtual display + + USAGE + void SLsmg_draw_box (int r, int c, unsigned int dr, unsigned int dc) + + DESCRIPTION + `SLsmg_draw_box' uses the `SLsmg_draw_hline' and + `SLsmg_draw_vline' functions to draw a rectangular box on the + virtual display. The box's upper left corner is placed at row + `r' and column `c'. The width and length of the box is + specified by `dc' and `dr', respectively. + + SEE ALSO + SLsmg_draw_vline, SLsmg_draw_hline, SLsmg_draw_object +-------------------------------------------------------------- + +SLsmg_set_color_in_region + + SYNOPSIS + Change the color of a specifed region + + USAGE + void SLsmg_set_color_in_region (color, r, c, dr, dc) + + int color; + int r, c; + unsigned int dr, dc; + + + DESCRIPTION + `SLsmg_set_color_in_region' may be used to change the color of a + rectangular region whose upper left corner is given by + (`r',`c'), and whose width and height is given by `dc' + and `dr', respectively. The color of the region is given by the + `color' parameter. + + SEE ALSO + SLsmg_draw_box, SLsmg_set_color +-------------------------------------------------------------- + +SLsmg_get_column + + SYNOPSIS + Get the column of the virtual cursor + + USAGE + int SLsmg_get_column(void); + + DESCRIPTION + The `SLsmg_get_column' function returns the current column of + the virtual cursor on the virtual display. + + SEE ALSO + SLsmg_get_row, SLsmg_gotorc +-------------------------------------------------------------- + +SLsmg_get_row + + SYNOPSIS + Get the row of the virtual cursor + + USAGE + int SLsmg_get_row(void); + + DESCRIPTION + The `SLsmg_get_row' function returns the current row of the + virtual cursor on the virtual display. + + SEE ALSO + SLsmg_get_column, SLsmg_gotorc +-------------------------------------------------------------- + +SLsmg_forward + + SYNOPSIS + Move the virtual cursor forward n columns + + USAGE + void SLsmg_forward (int n); + + DESCRIPTION + The `SLsmg_forward' function moves the virtual cursor forward + `n' columns. + + SEE ALSO + SLsmg_gotorc +-------------------------------------------------------------- + +SLsmg_write_color_chars + + SYNOPSIS + Write characters with color descriptors to virtual display + + USAGE + void SLsmg_write_color_chars (unsigned short *s, unsigned int len) + + DESCRIPTION + The `SLsmg_write_color_chars' function may be used to write + `len' characters, each with a different color descriptor to the + virtual display. Each character and its associated color are + encoded as an `unsigned short' such that the lower eight bits + form the character and the next eight bits form the color. + + SEE ALSO + SLsmg_char_at, SLsmg_write_raw +-------------------------------------------------------------- + +SLsmg_read_raw + + SYNOPSIS + Read characters from the virtual display + + USAGE + unsigned int SLsmg_read_raw (unsigned short *buf, unsigned int len) + + DESCRIPTION + `SLsmg_read_raw' attempts to read `len' characters from the + current position on the virtual display into the buffer specified by + `buf'. It returns the number of characters actually read. This + number will be less than `len' if an attempt is made to read + past the right margin of the display. + + NOTES + The purpose of the pair of functions, `SLsmg_read_raw' and + `SLsmg_write_raw', is to permit one to copy the contents of one + region of the virtual display to another region. + + SEE ALSO + SLsmg_char_at, SLsmg_write_raw +-------------------------------------------------------------- + +SLsmg_write_raw + + SYNOPSIS + Write characters directly to the virtual display + + USAGE + unsigned int SLsmg_write_raw (unsigned short *buf, unsigned int len) + + DESCRIPTION + The `SLsmg_write_raw' function attempts to write `len' + characters specified by `buf' to the display at the current + position. It returns the number of characters successfully written, + which will be less than `len' if an attempt is made to write + past the right margin. + + NOTES + The purpose of the pair of functions, `SLsmg_read_raw' and + `SLsmg_write_raw', is to permit one to copy the contents of one + region of the virtual display to another region. + + SEE ALSO + SLsmg_read_raw +-------------------------------------------------------------- + +SLallocate_load_type + + SYNOPSIS + Allocate a SLang_Load_Type object + + USAGE + SLang_Load_Type *SLallocate_load_type (char *name) + + DESCRIPTION + The `SLallocate_load_type' function allocates and initializes + space for a `SLang_Load_Type' object and returns it. Upon + failure, the function returns `NULL'. The parameter `name' + must uniquely identify the object. For example, if the object + represents a file, then `name' could be the absolute path name + of the file. + + SEE ALSO + SLdeallocate_load_type, SLang_load_object +-------------------------------------------------------------- + +SLdeallocate_load_type + + SYNOPSIS + Free a SLang_Load_Type object + + USAGE + void SLdeallocate_load_type (SLang_Load_Type *slt) + + DESCRIPTION + This function frees the memory associated with a + `SLang_Load_Type' object that was acquired from a call to the + `SLallocate_load_type' function. + + SEE ALSO + SLallocate_load_type, SLang_load_object +-------------------------------------------------------------- + +SLang_load_object + + SYNOPSIS + Load an object into the interpreter + + USAGE + int SLang_load_object (SLang_Load_Type *obj) + + DESCRIPTION + The function `SLang_load_object' is a generic function that may + be used to loaded an object of type `SLang_Load_Type' into the + interpreter. For example, the functions `SLang_load_file' and + `SLang_load_string' are wrappers around this function to load a + file and a string, respectively. + + SEE ALSO + SLang_load_file, SLang_load_string, SLallocate_load_type +-------------------------------------------------------------- + +SLclass_allocate_class + + SYNOPSIS + Allocate a class for a new data type + + USAGE + SLang_Class_Type *SLclass_allocate_class (char *name) + + DESCRIPTION + The purpose of this function is to allocate and initialize space + that defines a new data type or class called `name'. If + successful, a pointer to the class is returned, or upon failure the + function returns `NULL'. + + This function does not automatically create the new data type. + Callback functions must first be associated with the data type via + functions such as `SLclass_set_push_function', and the data + type must be registered with the interpreter via + `SLclass_register_class'. See the S-Lang library programmer's + guide for more information. + + SEE ALSO + SLclass_register_class, SLclass_set_push_function +-------------------------------------------------------------- + +SLclass_register_class + + SYNOPSIS + Register a new data type with the interpreter + + USAGE + int SLclass_register_class (cl, type, sizeof_type, class_type) + + SLang_Class_Type *cl + unsigned char type + unsigned int sizeof_type + unsigned char class_type + + + DESCRIPTION + The `SLclass_register_class' function is used to register a new + class or data type with the interpreter. If successful, the + function returns `0', or upon failure, it returns `-1'. + + The first parameter, `cl', must have been previously obtained + via the `SLclass_allocate_class' function. + + The second parameter, `type' specifies the data type of the new + class. It must be an unsigned character with value greater that + `127'. The values in the range `0-127' are reserved for + internal use by the library. + + The size that the data type represents in bytes is specified by the + third parameter, `sizeof_type'. This value should not be + confused with the sizeof the structure that represents the data + type, unless the data type is of class `SLANG_CLASS_TYPE_VECTOR' + or `SLANG_CLASS_TYPE_SCALAR'. For pointer objects, the value + of this parameter is just `sizeof(void *)'. + + The final parameter specifies the class type of the data type. It must + be one of the values: + + SLANG_CLASS_TYPE_SCALAR + SLANG_CLASS_TYPE_VECTOR + SLANG_CLASS_TYPE_PTR + SLANG_CLASS_TYPE_MMT + + The `SLANG_CLASS_TYPE_SCALAR' indicates that the new data type + is a scalar. Examples of scalars in `SLANG_INT_TYPE' and + `SLANG_DOUBLE_TYPE'. + + Setting `class_type' to SLANG_CLASS_TYPE_VECTOR implies that the + new data type is a vector, or a 1-d array of scalar types. An + example of a data type of this class is the + `SLANG_COMPLEX_TYPE', which represents complex numbers. + + `SLANG_CLASS_TYPE_PTR' specifies the data type is of a pointer + type. Examples of data types of this class include + `SLANG_STRING_TYPE' and `SLANG_ARRAY_TYPE'. Such types must + provide for their own memory management. + + Data types of class `SLANG_CLASS_TYPE_MMT' are pointer types + except that the memory management, i.e., creation and destruction of + the type, is handled by the interpreter. Such a type is called a + _memory managed type_. An example of this data type is the + `SLANG_FILEPTR_TYPE'. + + NOTES + See the \slang-c-programmers-guide for more information. + + SEE ALSO + SLclass_allocate_class +-------------------------------------------------------------- + +SLclass_set_string_function + + SYNOPSIS + Set a data type's string representation callback + + USAGE + int SLclass_set_string_function (cl, sfun) + + SLang_Class_Type *cl + char *(*sfun) (unsigned char, VOID_STAR); + + + DESCRIPTION + The `SLclass_set_string_function' routine is used to define a + callback function, `sfun', that will be used when a string + representation of an object of the data type represented by `cl' + is needed. `cl' must have already been obtained via a call to + `SLclass_allocate_class'. When called, `sfun' will be + passed two arguments: a unsigned char which represents the data + type, and the address of the object for which a string represetation + is required. The callback function must return a _malloced_ + string. + + Upon success, `SLclass_set_string_function' returns zero, or + upon error it returns -1. + + EXAMPLE + A callback function that handles both `SLANG_STRING_TYPE' and + `SLANG_INT_TYPE' variables looks like: + + char *string_and_int_callback (unsigned char type, VOID_STAR addr) + { + char buf[64]; + + switch (type) + { + case SLANG_STRING_TYPE: + return SLmake_string (*(char **)addr); + + case SLANG_INTEGER_TYPE: + sprintf (buf, "%d", *(int *)addr); + return SLmake_string (buf); + } + return NULL; + } + + + NOTES + The default string callback simply returns the name of the data type. + + SEE ALSO + SLclass_allocate_class, SLclass_register_class +-------------------------------------------------------------- + +SLclass_set_destroy_function + + SYNOPSIS + Set the destroy method callback for a data type + + USAGE + int SLclass_set_destroy_function (cl, destroy_fun) + + SLang_Class_Type *cl + void (*destroy_fun) (unsigned char, VOID_STAR); + + + DESCRIPTION + `SLclass_set_destroy_function' is used to set the destroy + callback for a data type. The data type's class `cl' must have + been previously obtained via a call to `SLclass_allocate_class'. + When called, `destroy_fun' will be passed two arguments: a + unsigned char which represents the data type, and the address of the + object to be destroyed. + + `SLclass_set_destroy_function' returns zero upon success, and + -1 upon failure. + + EXAMPLE + The destroy method for `SLANG_STRING_TYPE' looks like: + + static void string_destroy (unsigned char type, VOID_STAR ptr) + { + char *s = *(char **) ptr; + if (s != NULL) SLang_free_slstring (*(char **) s); + } + + + NOTES + Data types of class SLANG_CLASS_TYPE_SCALAR do not require a destroy + callback. However, other classes do. + + SEE ALSO + SLclass_allocate_class, SLclass_register_class +-------------------------------------------------------------- + +SLclass_set_push_function + + SYNOPSIS + Set the push callback for a new data type + + USAGE + int SLclass_set_push_function (cl, push_fun) + + SLang_Class_Type *cl + int (*push_fun) (unsigned char, VOID_STAR); + + + DESCRIPTION + `SLclass_set_push_function' is used to set the push callback + for a new data type specified by `cl', which must have been + previously obtained via `SLclass_allocate_class'. + + The parameter `push_fun' is a pointer to the push callback. It + is required to take two arguments: an unsigned character + representing the data type, and the address of the object to be + pushed. It must return zero upon success, or -1 upon failure. + + `SLclass_set_push_function' returns zero upon success, or -1 + upon failure. + + EXAMPLE + The push callback for `SLANG_COMPLEX_TYPE' looks like: + + static int complex_push (unsigned char type, VOID_STAR ptr) + { + double *z = *(double **) ptr; + return SLang_push_complex (z[0], z[1]); + } + + + SEE ALSO + SLclass_allocate_class, SLclass_register_class +-------------------------------------------------------------- + +SLclass_set_pop_function + + SYNOPSIS + Set the pop callback for a new data type + + USAGE + int SLclass_set_pop_function (cl, pop_fun) + + SLang_Class_Type *cl + int (*pop_fun) (unsigned char, VOID_STAR); + + + DESCRIPTION + `SLclass_set_pop_function' is used to set the callback for + popping an object from the stack for a new data type specified by + `cl', which must have been previously obtained via + `SLclass_allocate_class'. + + The parameter `pop_fun' is a pointer to the pop callback + function, which is required to take two arguments: an unsigned + character representing the data type, and the address of the object + to be popped. It must return zero upon success, or -1 upon + failure. + + `SLclass_set_pop_function' returns zero upon success, or -1 + upon failure. + + EXAMPLE + The pop callback for `SLANG_COMPLEX_TYPE' looks like: + + static int complex_push (unsigned char type, VOID_STAR ptr) + { + double *z = *(double **) ptr; + return SLang_pop_complex (&z[0], &z[1]); + } + + + SEE ALSO + SLclass_allocate_class, SLclass_register_class +-------------------------------------------------------------- + +SLclass_get_datatype_name + + SYNOPSIS + Get the name of a data type + + USAGE + char *SLclass_get_datatype_name (unsigned char type) + + DESCRIPTION + The `SLclass_get_datatype_name' function returns the name of the + data type specified by `type'. For example, if `type' is + `SLANG_INT_TYPE', the string `"Integer_Type"' will be + returned. + + This function returns a pointer that should not be modified or freed. + + SEE ALSO + SLclass_allocate_class, SLclass_register_class +-------------------------------------------------------------- + +SLang_free_mmt + + SYNOPSIS + Free a memory managed type + + USAGE + void SLang_free_mmt (SLang_MMT_Type *mmt) + + DESCRIPTION + The `SLang_MMT_Type' function is used to free a memory managed + data type. + + SEE ALSO + SLang_object_from_mmt, SLang_create_mmt +-------------------------------------------------------------- + +SLang_object_from_mmt + + SYNOPSIS + Get a pointer to the value of a memory managed type + + USAGE + VOID_STAR SLang_object_from_mmt (SLang_MMT_Type *mmt) + + DESCRIPTION + The `SLang_object_from_mmt' function returns a pointer to the + actual object whose memory is being managed by the interpreter. + + SEE ALSO + SLang_free_mmt, SLang_create_mmt +-------------------------------------------------------------- + +SLang_create_mmt + + SYNOPSIS + Create a memory managed data type + + USAGE + SLang_MMT_Type *SLang_create_mmt (unsigned char t, VOID_STAR ptr) + + DESCRIPTION + The `SLang_create_mmt' function returns a pointer to a new + memory managed object. This object contains information necessary + to manage the memory associated with the pointer `ptr' which + represents the application defined data type of type `t'. + + SEE ALSO + SLang_object_from_mmt, SLang_push_mmt, SLang_free_mmt +-------------------------------------------------------------- + +SLang_push_mmt + + SYNOPSIS + Push a memory managed type + + USAGE + int SLang_push_mmt (SLang_MMT_Type *mmt) + + DESCRIPTION + This function is used to push a memory managed type onto the + interpreter stack. It returns zero upon success, or `-1' upon + failure. + + SEE ALSO + SLang_create_mmt, SLang_pop_mmt +-------------------------------------------------------------- + +SLang_pop_mmt + + SYNOPSIS + Pop a memory managed data type + + USAGE + SLang_MMT_Type *SLang_pop_mmt (unsigned char t) + + DESCRIPTION + The `SLang_pop_mmt' function may be used to pop a memory managed + type of type `t' from the stack. It returns a pointer to the + memory managed object upon success, or `NULL' upon failure. The + function `SLang_object_from_mmt' should be used to access the + actual pointer to the data type. + + SEE ALSO + SLang_object_from_mmt, SLang_push_mmt +-------------------------------------------------------------- + +SLang_inc_mmt + + SYNOPSIS + Increment a memory managed type reference count + + USAGE + void SLang_inc_mmt (SLang_MMT_Type *mmt); + + DESCRIPTION + The `SLang_inc_mmt' function may be used to increment the + reference count associated with the memory managed data type given + by `mmt'. + + SEE ALSO + SLang_free_mmt, SLang_create_mmt, SLang_pop_mmt, SLang_pop_mmt +-------------------------------------------------------------- + +SLang_vmessage + + SYNOPSIS + Display a message to the message device + + USAGE + void SLang_vmessage (char *fmt, ...) + + DESCRIPTION + This function prints a `printf' style formatted variable + argument list to the message device. The default message device is + `stdout'. + + SEE ALSO + SLang_verror +-------------------------------------------------------------- + +SLang_exit_error + + SYNOPSIS + Exit the program and display an error message + + USAGE + void SLang_exit_error (char *fmt, ...) + + DESCRIPTION + The `SLang_exit_error' function terminates the program and + displays an error message using a `printf' type variable + argument list. The default behavior to this function is to write + the message to `stderr' and exit with the `exit' system + call. + + If the function pointer `SLang_Exit_Error_Hook' is + non-NULL, the function to which it points will be called. This + permits an application to perform whatever cleanup is necessary. + This hook has the prototype: + + void (*SLang_Exit_Error_Hook)(char *, va_list); + + + SEE ALSO + SLang_verror, exit +-------------------------------------------------------------- + +SLang_init_slang + + SYNOPSIS + Initialize the interpreter + + USAGE + int SLang_init_slang (void) + + DESCRIPTION + The `SLang_init_slang' function must be called by all + applications that use the S-Lang interpreter. It initializes the + interpreter, defines the built-in data types, and adds a set of core + intrinsic functions. + + The function returns `0' upon success, or `-1' upon failure. + + SEE ALSO + SLang_init_slfile, SLang_init_slmath, SLang_init_slunix +-------------------------------------------------------------- + +SLang_init_slfile + + SYNOPSIS + Initialize the interpreter file I/O intrinsics + + USAGE + int SLang_init_slfile (void) + + DESCRIPTION + This function initializes the interpreters file I/O intrinsic + functions. This function adds intrinsic functions such as + `fopen', `fclose', and `fputs' to the interpreter. + It returns `0' if successful, or `-1' upon error. + + NOTES + Before this function can be called, it is first necessary to call + `SLang_init_slang'. It also adds + the preprocessor symbol `__SLFILE__' to the interpreter. + + SEE ALSO + SLang_init_slang, SLang_init_slunix, SLang_init_slmath +-------------------------------------------------------------- + +SLang_init_slmath + + SYNOPSIS + Initialize the interpreter math intrinsics + + USAGE + int SLang_init_slmath (void) + + DESCRIPTION + The `SLang_init_slmath' function initializes the interpreter's + mathematical intrinsic functions and makes them available to the + language. The intrinsic functions include `sin', `cos', + `tan', etc... It returns `0' if successful, or `-1' + upon failure. + + NOTES + This function must be called after `SLang_init_slang'. It adds + the preprocessor symbol `__SLMATH__' to the interpreter. + + SEE ALSO + SLang_init_slang, SLang_init_slfile, SLang_init_slunix +-------------------------------------------------------------- + +SLang_init_slunix + + SYNOPSIS + Make available some unix system calls to the interpreter + + USAGE + int SLang_init_slunix (void) + + DESCRIPTION + The `SLang_init_slunix' function initializes the interpreter's + unix system call intrinsic functions and makes them available to the + language. Examples of functions made available by + `SLang_init_slunix' include `chmod', `chown', and + `stat_file'. It returns `0' if successful, or `-1' + upon failure. + + NOTES + This function must be called after `SLang_init_slang'. It adds + the preprocessor symbol `__SLUNIX__' to the interpreter. + + SEE ALSO + SLang_init_slang, SLang_init_slfile, SLang_init_slmath +-------------------------------------------------------------- + +SLadd_intrin_fun_table + + SYNOPSIS + Add a table of intrinsic functions to the interpreter + + USAGE + int SLadd_intrin_fun_table(SLang_Intrin_Fun_Type *tbl, char *pp_name); + + DESCRIPTION + The `SLadd_intrin_fun_table' function adds an array, or table, of + `SLang_Intrin_Fun_Type' objects to the interpreter. The first + parameter, `tbl' specifies the table to be added. The second + parameter `pp_name', if non-NULL will be added to the list of + preprocessor symbols. + + This function returns -1 upon failure or zero upon success. + + NOTES + A table should only be loaded one time and it is considered to be an + error on the part of the application if it loads a table more than + once. + + SEE ALSO + SLadd_intrin_var_table, SLadd_intrinsic_function, SLdefine_for_ifdef +-------------------------------------------------------------- + +SLadd_intrin_var_table + + SYNOPSIS + Add a table of intrinsic variables to the interpreter + + USAGE + int SLadd_intrin_var_table (SLang_Intrin_Var_Type *tbl, char *pp_name); + + DESCRIPTION + The `SLadd_intrin_var_table' function adds an array, or table, of + `SLang_Intrin_Var_Type' objects to the interpreter. The first + parameter, `tbl' specifies the table to be added. The second + parameter `pp_name', if non-NULL will be added to the list of + preprocessor symbols. + + This function returns -1 upon failure or zero upon success. + + NOTES + A table should only be loaded one time and it is considered to be an + error on the part of the application if it loads a table more than + once. + + SEE ALSO + SLadd_intrin_var_table, SLadd_intrinsic_function, SLdefine_for_ifdef +-------------------------------------------------------------- + +SLang_load_file + + SYNOPSIS + Load a file into the interpreter + + USAGE + int SLang_load_file (char *fn) + + DESCRIPTION + The `SLang_load_file' function opens the file whose name is + specified by `fn' and feeds it to the interpreter, line by line, + for execution. If `fn' is `NULL', the function will take + input from `stdin'. + + If no error occurs, it returns `0'; otherwise, + it returns `-1', and sets `SLang_Error' accordingly. For + example, if it fails to open the file, it will return `-1' with + `SLang_Error' set to `SL_OBJ_NOPEN'. + + NOTES + If the hook `SLang_Load_File_Hook' declared as + + int (*SLang_Load_File_Hook)(char *); + + is non-NULL, the function point to by it will be used to load the + file. For example, the jed editor uses this hook to load files + via its own routines. + + SEE ALSO + SLang_load_object, SLang_load_string +-------------------------------------------------------------- + +SLang_restart + + SYNOPSIS + Reset the interpreter after an error + + USAGE + void SLang_restart (int full) + + DESCRIPTION + The `SLang_restart' function should be called by the + application at top level if an error occurs. If the parameter + `full' is non-zero, any objects on the S-Lang run time stack + will be removed from the stack; otherwise, the stack will be left + intact. Any time the stack is believed to be trashed, this routine + should be called with a non-zero argument (e.g., if + `setjmp'/`longjmp' is called). + + Calling `SLang_restart' does not reset the global variable + `SLang_Error' to zero. It is up to the application to reset + that variable to zero after calling `SLang_restart'. + + EXAMPLE + + while (1) + { + if (SLang_Error) + { + SLang_restart (1); + SLang_Error = 0; + } + (void) SLang_load_file (NULL); + } + + + SEE ALSO + SLang_init_slang, SLang_load_file +-------------------------------------------------------------- + +SLang_byte_compile_file + + SYNOPSIS + Byte-compile a file for faster loading + + USAGE + int SLang_byte_compile_file(char *fn, int reserved) + + DESCRIPTION + The `SLang_byte_compile_file' function ``byte-compiles'' the + file `fn' for faster loading by the interpreter. This produces + a new file whose filename is equivalent to the one specified by + `fn', except that a `'c'' is appended to the name. For + example, if `fn' is set to `init.sl', then the new file + will have the name exmp{init.slc}. The meaning of the second + parameter, `reserved', is reserved for future use. For now, set + it to `0'. + + The function returns zero upon success, or `-1' upon error and + sets SLang_Error accordingly. + + SEE ALSO + SLang_load_file, SLang_init_slang +-------------------------------------------------------------- + +SLang_autoload + + SYNOPSIS + Autoload a function from a file + + USAGE + int SLang_autoload(char *funct, char *filename) + + DESCRIPTION + The `SLang_autoload' function may be used to associate a + `slang' function name `funct' with the file `filename' + such that if `funct' has not already been defined when needed, + it will be loaded from `filename'. + + `SLang_autoload' has no effect if `funct' has already been + defined. Otherwise it declares `funct' as a user-defined S-Lang + function. It returns `0' upon success, or `-1' upon error. + + SEE ALSO + SLang_load_file, SLang_is_defined +-------------------------------------------------------------- + +SLang_load_string + + SYNOPSIS + Interpret a string + + USAGE + int SLang_load_string(char *str) + + DESCRIPTION + The `SLang_load_string' function feeds the string specified by + `str' to the interpreter for execution. It returns zero upon + success, or `-1' upon failure. + + SEE ALSO + SLang_load_file, SLang_load_object +-------------------------------------------------------------- + +SLdo_pop + + SYNOPSIS + Delete an object from the stack + + USAGE + int SLdo_pop(void) + + DESCRIPTION + This function removes an object from the top of the interpeter's + run-time stack and frees any memory associated with it. It returns + zero upon success, or `-1' upon error (most likely due to a + stack-underflow). + + SEE ALSO + SLdo_pop_n, SLang_pop_integer, SLang_pop_string +-------------------------------------------------------------- + +SLdo_pop_n + + SYNOPSIS + Delete n objects from the stack + + USAGE + int SLdo_pop_n (unsigned int n) + + DESCRIPTION + The `SLdo_pop_n' function removes the top `n' objects from + the interpreter's run-time stack and frees all memory associated + with the objects. It returns zero upon success, or `-1' upon + error (most likely due to a stack-underflow). + + SEE ALSO + SLdo_pop, SLang_pop_integer, SLang_pop_string +-------------------------------------------------------------- + +SLang_pop_integer + + SYNOPSIS + Pop an integer off the stack + + USAGE + int SLang_pop_integer (int *i) + + DESCRIPTION + The `SLang_pop_integer' function removes an integer from the + top of the interpreter's run-time stack and returns its value via + the pointer `i'. If successful, it returns zero. However, if + the top stack item is not of type `SLANG_INT_TYPE', or the + stack is empty, the function will return `-1' and set + `SLang_Error' accordingly. + + SEE ALSO + SLang_push_integer, SLang_pop_double +-------------------------------------------------------------- + +SLpop_string + + SYNOPSIS + Pop a string from the stack + + USAGE + int SLpop_string (char **strptr); + + DESCRIPTION + The `SLpop_string' function pops a string from the stack and + returns it as a malloced pointer. It is up to the calling routine + to free this string via a call to `free' or `SLfree'. If + successful, `SLpop_string' returns zero. However, if the top + stack item is not of type `SLANG_STRING_TYPE', or the stack is + empty, the function will return `-1' and set + `SLang_Error' accordingly. + + EXAMPLE + + define print_string (void) + { + char *s; + if (-1 == SLpop_string (&s)) + return; + fputs (s, stdout); + SLfree (s); + } + + + NOTES + This function should not be confused with `SLang_pop_slstring', + which pops a _hashed_ string from the stack. + + SEE ALSO + SLang_pop_slstring. SLfree +-------------------------------------------------------------- + +SLang_pop_string + + SYNOPSIS + Pop a string from the stack + + USAGE + int SLang_pop_string(char **strptr, int *do_free) + + DESCRIPTION + The `SLpop_string' function pops a string from the stack and + returns it as a malloced pointer via `strptr'. After the + function returns, the integer pointed to by the second parameter + will be set to a non-zero value if `*strptr' should be freed via + `free' or `SLfree'. If successful, `SLpop_string' + returns zero. However, if the top stack item is not of type + `SLANG_STRING_TYPE', or the stack is empty, the function will + return `-1' and set `SLang_Error' accordingly. + + NOTES + This function is considered obsolete and should not be used by + applications. If one requires a malloced string for modification, + `SLpop_string' should be used. If one requires a constant + string that will not be modifed by the application, + `SLang_pop_slstring' should be used. + + SEE ALSO + SLang_pop_slstring, SLpop_string +-------------------------------------------------------------- + +SLang_pop_slstring + + SYNOPSIS + Pop a hashed string from the stack + + USAGE + int SLang_pop_slstring (char **s_ptr) + + DESCRIPTION + The `SLang_pop_slstring' function pops a hashed string from the + S-Lang run-time stack and returns it via `s_ptr'. It returns + zero if successful, or -1 upon failure. The resulting string + should be freed via a call to `SLang_free_slstring' after use. + + EXAMPLE + + void print_string (void) + { + char *s; + if (-1 == SLang_pop_slstring (&s)) + return; + fprintf (stdout, "%s\n", s); + SLang_free_slstring (s); + } + + + NOTES + `SLang_free_slstring' is the preferred function for popping + strings. This is a result of the fact that the interpreter uses + hashed strings as the native representation for string data. + + One must _never_ free a hashed string using `free' or + `SLfree'. In addition, one must never make any attempt to + modify a hashed string and doing so will result in memory + corruption. + + SEE ALSO + SLang_free_slstring, SLpop_string +-------------------------------------------------------------- + +SLang_pop_double + + SYNOPSIS + Pop a double from the stack + + USAGE + int SLang_pop_double (double *dptr, int *iptr, int *conv) + + DESCRIPTION + The `SLang_pop_double' function pops a double precision number + from the stack and returns it via `dptr'. If the number was + derived from an integer, `*conv' will be set to `1' upon + return, otherwise, `*conv' will be set to `0'. This + function returns 0 upon success, otherwise it returns -1 and sets + `SLang_Error' accordingly. + + NOTES + If one does not care whether or not `*dptr' was derived from + an integer, `iptr' and `conv' may be passed as `NULL' + pointers. + + SEE ALSO + SLang_pop_integer, SLang_push_double +-------------------------------------------------------------- + +SLang_pop_complex + + SYNOPSIS + Pop a complex number from the stack + + USAGE + int SLang_pop_complex (double *re, double *im) + + DESCRIPTION + `SLang_pop_complex' pops a complex number from the stack and + returns it via the parameters `re' and `im' as the real and + imaginary parts of the complex number, respectively. This function + automatically converts objects of type `SLANG_DOUBLE_TYPE' and + `SLANG_INT_TYPE' to `SLANG_COMPLEX_TYPE', if necessary. + It returns zero upon success, or -1 upon error setting + `SLang_Error' accordingly. + + SEE ALSO + SLang_pop_integer, SLang_pop_double, SLang_push_complex +-------------------------------------------------------------- + +SLang_push_complex + + SYNOPSIS + Push a complex number onto the stack + + USAGE + int SLang_push_complex (double re, double im) + + DESCRIPTION + `SLang_push_complex' may be used to push the complex number + whose real and imaginary parts are given by `re' and `im', + respectively. It returns zero upon success, or -1 upon error + setting `SLang_Error' accordingly. + + SEE ALSO + SLang_pop_complex, SLang_push_double +-------------------------------------------------------------- + +SLang_push_double + + SYNOPSIS + Push a double onto the stack + + USAGE + int SLang_push_double(double d) + + DESCRIPTION + `SLang_push_double' may be used to push the double precision + floating point number `d' onto the interpreter's run-time + stack. It returns zero upon success, or -1 upon error setting + `SLang_Error' accordingly. + + SEE ALSO + SLang_pop_double, SLang_push_integer +-------------------------------------------------------------- + +SLang_push_string + + SYNOPSIS + Push a string onto the stack + + USAGE + int SLang_push_string (char *s) + + DESCRIPTION + `SLang_push_string' pushes a copy of the string specified by + `s' onto the interpreter's run-time stack. It returns zero + upon success, or -1 upon error setting `SLang_Error' + accordingly. + + NOTES + If `s' is `NULL', this function pushes `NULL' + (`SLANG_NULL_TYPE') onto the stack. + + SEE ALSO + SLang_push_malloced_string +-------------------------------------------------------------- + +SLang_push_integer + + SYNOPSIS + Push an integer onto the stack + + USAGE + int SLang_push_integer (int i) + + DESCRIPTION + `SLang_push_integer' the integer `i' onto the interpreter's + run-time stack. It returns zero upon success, or -1 upon error + setting `SLang_Error' accordingly. + + SEE ALSO + SLang_pop_integer, SLang_push_double, SLang_push_string +-------------------------------------------------------------- + +SLang_push_malloced_string + + SYNOPSIS + Push a malloced string onto the stack + + USAGE + int SLang_push_malloced_string (char *s); + + DESCRIPTION + `SLang_push_malloced_string' may be used to push a malloced + string onto the interpreter's run-time stack. It returns zero upon + success, or -1 upon error setting `SLang_Error' accordingly. + + EXAMPLE + The following example illustrates that it is up to the calling + routine to free the string if `SLang_push_malloced_string' fails: + + int push_hello (void) + { + char *s = malloc (6); + if (s == NULL) return -1; + strcpy (s, "hello"); + if (-1 == SLang_push_malloced_string (s)) + { + free (s); + return -1; + } + return 0; + } + + + EXAMPLE + The function `SLang_create_slstring' returns a hashed string. + Such a string may not be malloced and should not be passed to + `SLang_push_malloced_string'. + + NOTES + If `s' is `NULL', this function pushes `NULL' + (`SLANG_NULL_TYPE') onto the stack. + + SEE ALSO + SLang_push_string, SLmake_string +-------------------------------------------------------------- + +SLang_is_defined + + SYNOPSIS + Check to see if the interpreter defines an object + + USAGE + int SLang_is_defined (char *nm) + + DESCRIPTION + The `SLang_is_defined' function may be used to determine + whether or not a variable or function whose name is given by + `em' has been defined. It returns zero if no such object has + been defined. Othewise it returns a non-zero value whose meaning + is given by the following table: + + 1 intrinsic function (SLANG_INTRINSIC) + 2 user-defined slang function (SLANG_FUNCTION) + -1 intrinsic variable (SLANG_IVARIABLE) + -2 user-defined global variable (SLANG_GVARIABLE) + + + SEE ALSO + SLadd_intrinsic_function, SLang_run_hooks, SLang_execute_function +-------------------------------------------------------------- + +SLang_run_hooks + + SYNOPSIS + Run a user-defined hook with arguments + + USAGE + int SLang_run_hooks (char *fname, unsigned int n, ...) + + DESCRIPTION + The `SLang_run_hooks' function may be used to execute a + user-defined function named `fname'. Before execution of the + function, the `n' string arguments specified by the variable + parameter list are pushed onto the stack. If the function + `fname' does not exist, `SLang_run_hooks' returns zero; + otherwise, it returns `1' upon successful execution of the + function, or -1 if an error occurred. + + EXAMPLE + The jed editor uses `SLang_run_hooks' to setup the mode of a + buffer based on the filename extension of the file associated with + the buffer: + + char *ext = get_filename_extension (filename); + if (ext == NULL) return -1; + if (-1 == SLang_run_hooks ("mode_hook", 1, ext)) + return -1; + return 0; + + + SEE ALSO + SLang_is_defined, SLang_execute_function +-------------------------------------------------------------- + +SLang_execute_function + + SYNOPSIS + Execute a user or intrinsic function + + USAGE + int SLang_execute_function (char *fname) + + DESCRIPTION + This function may be used to execute either a user-defined function + or an intrinisic function. The name of the function is specified + by `fname'. It returns zero if `fname' is not defined, or + `1' if the function was successfully executed, or -1 upon + error. + + NOTES + The function `SLexecute_function' may be a better alternative + for some uses. + + SEE ALSO + SLang_run_hooks, SLexecute_function, SLang_is_defined +-------------------------------------------------------------- + +SLang_verror + + SYNOPSIS + Signal an error with a message + + USAGE + void SLang_verror (int code, char *fmt, ...); + + DESCRIPTION + The `SLang_verror' function sets `SLang_Error' to + `code' if `SLang_Error' is 0. It also displays the error + message implied by the `printf' variable argument list using + `fmt' as the format. + + EXAMPLE + + FILE *open_file (char *file) + { + char *file = "my_file.dat"; + if (NULL == (fp = fopen (file, "w"))) + SLang_verror (SL_INTRINSIC_ERROR, "Unable to open %s", file); + return fp; + } + + + SEE ALSO + SLang_vmessage, SLang_exit_error +-------------------------------------------------------------- + +SLang_doerror + + SYNOPSIS + Signal an error + + USAGE + void SLang_doerror (char *err_str) + + DESCRIPTION + The `SLang_doerror' function displays the string `err_str' + to the error device and signals a S-Lang error. + + NOTES + `SLang_doerror' is considered to obsolete. Applications should + use the `SLang_verror' function instead. + + SEE ALSO + SLang_verror, SLang_exit_error +-------------------------------------------------------------- + +SLang_get_function + + SYNOPSIS + Get a pointer to a slang function + + USAGE + SLang_Name_Type *SLang_get_function (char *fname) + + DESCRIPTION + This function returns a pointer to the internal S-Lang table entry + of a function whose name is given by `fname'. It returns + `NULL' upon failure. The value returned by this function can be + used `SLexecute_function' to call the function directly + from C. + + SEE ALSO + SLexecute_function +-------------------------------------------------------------- + +SLexecute_function + + SYNOPSIS + Execute a slang or intrinsic function + + USAGE + int SLexecute_function (SLang_Name_Type *nt) + + DESCRIPTION + The `SLexecute_function' allows an application to call the + S-Lang function specified by the `SLang_Name_Type' pointer + `nt'. This parameter must be non `NULL' and must have been + previously obtained by a call to `SLang_get_function'. + + EXAMPLE + Consider the S-Lang function: + + define my_fun (x) + { + return x^2 - 2; + } + + Suppose that it is desired to call this function many times with + different values of x. There are at least two ways to do this. + The easiest way is to use `SLang_execute_function' by passing + the string `"my_fun"'. A better way that is much faster is to + use `SLexecute_function': + + int sum_a_function (char *fname, double *result) + { + double sum, x, y; + SLang_Name_Type *nt; + + if (NULL == (nt = SLang_get_function (fname))) + return -1; + + sum = 0; + for (x = 0; x < 10.0; x += 0.1) + { + SLang_start_arg_list (); + if (-1 == SLang_push_double (x)) + return -1; + SLang_end_arg_list (); + if (-1 == SLexecute_function (nt)) + return -1; + if (-1 == SLang_pop_double (&y, NULL, NULL)) + return -1; + + sum += y; + } + return sum; + } + + Although not necessary in this case, `SLang_start_arg_list' and + `SLang_end_arg_list' were used to provide the function with + information about the number of parameters passed to it. + + SEE ALSO + SLang_get_function, SLang_start_arg_list, SLang_end_arg_list +-------------------------------------------------------------- + +SLang_peek_at_stack + + SYNOPSIS + Find the type of object on the top of the stack + + USAGE + int SLang_peek_at_stack (void) + + DESCRIPTION + The `SLang_peek_at_stack' function is useful for determining the + data type of the object at the top of the stack. It returns the + data type, or -1 upon a stack-underflow error. It does not remove + anything from the stack. + + SEE ALSO + SLang_pop_string, SLang_pop_integer +-------------------------------------------------------------- + +SLmake_string + + SYNOPSIS + Duplicate a string + + USAGE + char *SLmake_string (char *s) + + DESCRIPTION + The `SLmake_string' function creates a new copy of the string + `s', via `malloc', and returns it. Upon failure it returns + `NULL'. Since the resulting string is malloced, it should be + freed when nolonger needed via a call to either `free' or + `SLfree'. + + NOTES + `SLmake_string' should not be confused with the function + `SLang_create_slstring', which performs a similar function. + + SEE ALSO + SLmake_nstring, SLfree, SLmalloc, SLang_create_slstring +-------------------------------------------------------------- + +SLmake_nstring + + SYNOPSIS + Duplicate a substring + + USAGE + char *SLmake_nstring (char *s, unsigned int n) + + DESCRIPTION + This function is like `SLmake_nstring' except that it creates a + null terminated string formed from the first `n' characters of + `s'. Upon failure, it returns `NULL', otherwise it returns + the new string. When nolonger needed, the returned string should be + freed with either `free' or `SLfree'. + + SEE ALSO + SLmake_nstring, SLfree, SLang_create_nslstring +-------------------------------------------------------------- + +SLang_create_nslstring + + SYNOPSIS + Created a hashed substring + + USAGE + char *SLang_create_nslstring (char *s, unsigned int n) + + DESCRIPTION + `SLang_create_nslstring' is like `SLang_create_slstring' + except that only the first `n' characters of `s' are used to + perform the string. Upon error, it returns `NULL', otherwise it + returns the hashed substring. Such a string must be freed by the + function `SLang_free_slstring'. + + NOTES + Do not use `free' or `SLfree' to free the string returned by + `SLang_create_slstring' or `SLang_create_nslstring'. Also + it is important that no attempt is made to modify the hashed string + returned by either of these functions. If one needs to modify a + string, the functions `SLmake_string' or `SLmake_nstring' + should be used instead. + + SEE ALSO + SLang_free_slstring, SLang_create_slstring, SLmake_nstring +-------------------------------------------------------------- + +SLang_create_slstring + + SYNOPSIS + Create a hashed string + + USAGE + char *SLang_create_slstring (char *s) + + DESCRIPTION + The `SLang_create_slstring' creates a copy of `s' and + returns it as a hashed string. Upon error, the function returns + `NULL', otherwise it returns the hashed string. Such a string + must only be freed via the `SLang_free_slstring' function. + + NOTES + Do not use `free' or `SLfree' to free the string returned by + `SLang_create_slstring' or `SLang_create_nslstring'. Also + it is important that no attempt is made to modify the hashed string + returned by either of these functions. If one needs to modify a + string, the functions `SLmake_string' or `SLmake_nstring' + should be used instead. + + SEE ALSO + SLang_free_slstring, SLang_create_nslstring, SLmake_string +-------------------------------------------------------------- + +SLang_free_slstring + + SYNOPSIS + Free a hashed string + + USAGE + void SLang_free_slstring (char *s) + + DESCRIPTION + The `SLang_free_slstring' function is used to free a hashed + string such as one returned by `SLang_create_slstring', + `SLang_create_nslstring', or `SLang_create_static_slstring'. + If `s' is `NULL', the routine does nothing. + + SEE ALSO + SLang_create_slstring, SLang_create_nslstring, SLang_create_static_slstring +-------------------------------------------------------------- + +SLang_concat_slstrings + + SYNOPSIS + Concatenate two strings to produce a hashed string + + USAGE + char *SLang_concat_slstrings (char *a, char *b) + + DESCRIPTION + The `SLang_concat_slstrings' function concatenates two strings, + `a' and `b', and returns the result as a hashed string. + Upon failure, `NULL' is returned. + + NOTES + A hashed string can only be freed using `SLang_free_slstring'. + Never use either `free' or `SLfree' to free a hashed string, + otherwise memory corruption will result. + + SEE ALSO + SLang_free_slstring, SLang_create_slstring +-------------------------------------------------------------- + +SLang_create_static_slstring + + SYNOPSIS + Create a hashed string + + USAGE + char *SLang_create_static_slstring (char *s_literal) + + DESCRIPTION + The `SLang_create_static_slstring' creates a hashed string from + the string literal `s_literal' and returns the result. Upon + failure it returns `NULL'. + + EXAMPLE + + char *create_hello (void) + { + return SLang_create_static_slstring ("hello"); + } + + + NOTES + This function should only be used with string literals. + + SEE ALSO + SLang_create_slstring, SLang_create_nslstring +-------------------------------------------------------------- + +SLmalloc + + SYNOPSIS + Allocate some memory + + USAGE + char *SLmalloc (unsigned int nbytes) + + DESCRIPTION + This function uses `malloc' to allocate `nbytes' of memory. + Upon error it returns `NULL'; otherwise it returns a pointer to + the allocated memory. One should use `SLfree' to free the + memory after used. + + SEE ALSO + SLfree, SLrealloc, SLcalloc +-------------------------------------------------------------- + +SLcalloc + + SYNOPSIS + Allocate some memory + + USAGE + char *SLcalloc (unsigned int num_elem, unsigned int elem_size) + + DESCRIPTION + This function uses `calloc' to allocate memory for + `num_elem' objects with each of size `elem_size' and returns + the result. In addition, the newly allocated memory is zeroed. + Upon error it returns `NULL'; otherwise it returns a pointer to + the allocated memory. One should use `SLfree' to free the + memory after used. + + SEE ALSO + SLmalloc, SLrealloc, SLfree +-------------------------------------------------------------- + +SLfree + + SYNOPSIS + Free some allocated memory + + USAGE + void SLfree (char *ptr) + + DESCRIPTION + The `SLfree' function uses `free' to deallocate the memory + specified by `ptr', which may be `NULL' in which case the + function does nothing. + + NOTES + Never use this function to free a hashed string returned by one of + the family of `slstring' functions, e.g., + `SLang_pop_slstring'. + + SEE ALSO + SLmalloc, SLcalloc, SLrealloc, SLmake_string +-------------------------------------------------------------- + +SLrealloc + + SYNOPSIS + Resize a dynamic memory block + + USAGE + char *SLrealloc (char *ptr, unsigned int new_size) + + DESCRIPTION + The `SLrealloc' uses the `realloc' function to resize the + memory block specified by `ptr' to the new size `new_size'. + If `ptr' is `NULL', the function call is equivalent to + `SLmalloc(new_size)'. Similarly, if `new_size' is zero, + the function call is equivalent to `SLfree(ptr)'. + + If the function fails, or if `new_size' is zero, `NULL' is + returned. Otherwise a pointer is returned to the (possibly moved) + new block of memory. + + SEE ALSO + SLfree, SLmalloc, SLcalloc +-------------------------------------------------------------- + +SLcurrent_time_string + + SYNOPSIS + Get the current time as a string + + USAGE + char *SLcurrent_time_string (void) + + DESCRIPTION + The `SLcurrent_time_string' function uses the C library function + `ctime' to obtain a string representation of the + current date and time in the form + + "Wed Dec 10 12:50:28 1997" + + However, unlike the `ctime' function, a newline character is not + present in the string. + + The returned value points to a statically allocated memory block + which may get overwritten on subsequent function calls. + + SEE ALSO + SLmake_string +-------------------------------------------------------------- + +SLatoi + + SYNOPSIS + Convert a text string to an integer + + USAGE + int SLatoi(unsigned char *str + + DESCRIPTION + `SLatoi' parses the string `str' to interpret it as an + integer value. Unlike `atoi', `SLatoi' can also parse + strings containing integers expressed in + hexidecimal (e.g., `"0x7F"') and octal (e.g., `"012"'.) + notation. + + SEE ALSO + SLang_guess_type +-------------------------------------------------------------- + +SLang_pop_fileptr + + SYNOPSIS + Pop a file pointer + + USAGE + int SLang_pop_fileptr (SLang_MMT_Type **mmt, FILE **fp) + + DESCRIPTION + `SLang_pop_fileptr' pops a file pointer from the S-Lang + run-time stack. It returns zero upon success, or -1 upon failure. + + A S-Lang file pointer (SLANG_FILEPTR_TYPE) is actually a memory + managed object. For this reason, `SLang_pop_fileptr' also + returns the memory managed object via the argument list. It is up + to the calling routine to call `SLang_free_mmt' to free the + object. + + EXAMPLE + The following example illustrates an application defined intrinsic + function that writes a user defined double precision number to a + file. Note the use of `SLang_free_mmt': + + int write_double (void) + { + double t; + SLang_MMT_Type *mmt; + FILE *fp; + int status; + + if (-1 == SLang_pop_double (&d, NULL, NULL)) + return -1; + if (-1 == SLang_pop_fileptr (&mmt, &fp)) + return -1; + + status = fwrite (&d, sizeof (double), 1, fp); + SLang_free_mmt (mmt); + return status; + } + + This function can be used by a S-Lang function as follows: + + define write_some_values () + { + variable fp, d; + + fp = fopen ("myfile.dat", "wb"); + if (fp == NULL) + error ("file failed to open"); + for (d = 0; d < 10.0; d += 0.1) + { + if (-1 == write_double (fp, d)) + error ("write failed"); + } + if (-1 == fclose (fp)) + error ("fclose failed"); + } + + + SEE ALSO + SLang_free_mmt, SLang_pop_double +-------------------------------------------------------------- + +SLadd_intrinsic_function + + SYNOPSIS + Add a new intrinsic function to the interpreter + + USAGE + int SLadd_intrinsic_function (name, f, type, nargs, ...) + + char *name + FVOID_STAR f + unsigned char type + unsigned int nargs + + + DESCRIPTION + The `SLadd_intrinsic_function' function may be used to add a new + intrinsic function. The S-Lang name of the function is specified by + `name' and the actual function pointer is given by `f', cast + to `FVOID_STAR'. The third parameter, `type' specifies the + return type of the function and must be one of the following values: + + SLANG_VOID_TYPE (returns nothing) + SLANG_INT_TYPE (returns int) + SLANG_DOUBLE_TYPE (returns double) + SLANG_STRING_TYPE (returns char *) + + The `nargs' parameter specifies the number of parameters to pass + to the function. The variable argument list following `nargs' + must consists of `nargs' integers which specify the data type of + each argument. + + The function returns zero upon success or -1 upon failure. + + EXAMPLE + The jed editor uses this function to change the `system' + intrinsic function to the following: + + static int jed_system (char *cmd) + { + if (Jed_Secure_Mode) + { + msg_error ("Access denied."); + return -1; + } + return SLsystem (cmd); + } + + After initializing the interpreter with `SLang_init_slang', + jed calls `SLadd_intrinsic_function' to substitute the above + definition for the default S-Lang definition: + + if (-1 == SLadd_intrinsic_function ("system", (FVOID_STAR)jed_system, + SLANG_INT_TYPE, 1, + SLANG_STRING_TYPE)) + return -1; + + + SEE ALSO + SLadd_intrinsic_variable, SLadd_intrinsic_array +-------------------------------------------------------------- + +SLadd_intrinsic_variable + + SYNOPSIS + Add an intrinsic variable to the interpreter + + USAGE + int SLadd_intrinsic_variable (name, addr, type, rdonly) + + char *name + VOID_STAR type + unsigned char type + int rdonly + + + DESCRIPTION + The `SLadd_intrinsic_variable' function adds an intrinsic + variable called `name' to the interpeter. The second parameter + `addr' specifies the address of the variable (cast to + `VOID_STAR'). The third parameter, `type', specifies the + data type of the variable. If the fourth parameter, `rdonly', + is non-zero, the variable will interpreted by the interpreter as + read-only. + + If successful, `SLadd_intrinsic_variable' returns zero, + otherwise it returns -1. + + EXAMPLE + Suppose that `My_Global_Int' is a global variable (at least not + a local one): + + int My_Global_Int; + + It can be added to the interpreter via the function call + + if (-1 == SLadd_intrinsic_variable ("MyGlobalInt", + (VOID_STAR)&My_Global_Int, + SLANG_INT_TYPE, 0)) + exit (1); + + + NOTES + The current implementation requires all pointer type intrinsic + variables to be read-only. For example, + + char *My_Global_String; + + is of type `SLANG_STRING_TYPE', and must be declared as + read-only. Finally, not that + + char My_Global_Char_Buf[256]; + + is _not_ a `SLANG_STRING_TYPE' object. This difference is + very important because internally the interpreter dereferences the + address passed to it to get to the value of the variable. + + SEE ALSO + SLadd_intrinsic_function, SLadd_intrinsic_array +-------------------------------------------------------------- + +SLclass_add_unary_op + + SYNOPSIS + ?? + + USAGE + int SLclass_add_unary_op (unsigned char,int (*) (int, unsigned char, VOID_STAR, unsigned int, VOID_STAR), int (*) (int, unsigned char, unsigned char *)); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLclass_add_app_unary_op + + SYNOPSIS + ?? + + USAGE + int SLclass_add_app_unary_op (unsigned char, int (*) (int,unsigned char, VOID_STAR, unsigned int,VOID_STAR),int (*) (int, unsigned char, unsigned char *)); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLclass_add_binary_op + + SYNOPSIS + ?? + + USAGE + int SLclass_add_binary_op (unsigned char, unsigned char,int (*)(int, unsigned char, VOID_STAR, unsigned int,unsigned char, VOID_STAR, unsigned int,VOID_STAR),int (*) (int, unsigned char, unsigned char, unsigned char *)); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLclass_add_math_op + + SYNOPSIS + ?? + + USAGE + int SLclass_add_math_op (unsigned char,int (*)(int,unsigned char, VOID_STAR, unsigned int,VOID_STAR),int (*)(int, unsigned char, unsigned char *)); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLclass_add_typecast + + SYNOPSIS + ?? + + USAGE + int SLclass_add_typecast (unsigned char, unsigned char int (*)_PROTO((unsigned char, VOID_STAR, unsigned int,unsigned char, VOID_STAR)),int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLang_init_tty + + SYNOPSIS + Initialize the terminal keyboard interface + + USAGE + int SLang_init_tty (int intr_ch, int no_flow_ctrl, int opost) + + DESCRIPTION + `SLang_init_tty' initializes the terminal for single character + input. If the first parameter `intr_ch' is in the range 0-255, + it will be used as the interrupt character, e.g., under Unix this + character will generate a `SIGINT' signal. Otherwise, if it is + `-1', the interrupt character will be left unchanged. + + If the second parameter `no_flow_ctrl' is non-zero, flow control + (`XON'/`XOFF') processing will be + enabled. + + If the last parmeter `opost' is non-zero, output processing by the + terminal will be enabled. If one intends to use this function in + conjunction with the S-Lang screen management routines + (`SLsmg'), this paramete shold be set to zero. + + `SLang_init_tty' returns zero upon success, or -1 upon error. + + NOTES + Terminal I/O is a complex subject. The S-Lang interface presents a + simplification that the author has found useful in practice. For + example, the only special character processing that + `SLang_init_tty' enables is that of the `SIGINT' character, + and the generation of other signals via the keyboard is disabled. + However, generation of the job control signal `SIGTSTP' is possible + via the `SLtty_set_suspend_state' function. + + Under Unix, the integer variable `SLang_TT_Read_FD' is used to + specify the input descriptor for the terminal. If + `SLang_TT_Read_FD' represents a terminal device as determined + via the `isatty' system call, then it will be used as the + terminal file descriptor. Otherwise, the terminal device + `/dev/tty' will used as the input device. The default value of + `SLang_TT_Read_FD' is -1 which causes `/dev/tty' to be + used. So, if you prefer to use `stdin' for input, then set + `SLang_TT_Read_FD' to `fileno(stdin)' _before_ calling + `SLang_init_tty'. + + If the variable `SLang_TT_Baud_Rate' is zero when this function + is called, the function will attempt to determine the baud rate by + querying the terminal driver and set `SLang_TT_Baud_Rate' to + that value. + + SEE ALSO + SLang_reset_tty, SLang_getkey, SLtty_set_suspend_state +-------------------------------------------------------------- + +SLang_reset_tty + + SYNOPSIS + Reset the terminal + + USAGE + void SLang_reset_tty (void) + + DESCRIPTION + `SLang_reset_tty' resets the terminal interface back to the + state it was in before `SLang_init_tty' was called. + + SEE ALSO + SLang_init_tty +-------------------------------------------------------------- + +SLtty_set_suspend_state + + SYNOPSIS + Enable or disable keyboard suspension + + USAGE + void SLtty_set_suspend_state (int s) + + DESCRIPTION + The `SLtty_set_suspend_state' function may be used to enable or + disable keyboard generation of the `SIGTSTP' job control signal. + If `s' is non-zero, generation of this signal via the terminal + interface will be enabled, otherwise it will be disabled. + + This function should only be called after the terminal driver has be + initialized via `SLang_init_tty'. The `SLang_init_tty' + always disables the generation of `SIGTSTP' via the keyboard. + + SEE ALSO + SLang_init_tty +-------------------------------------------------------------- + +SLang_getkey + + SYNOPSIS + Read a character from the keyboard + + USAGE + unsigned int SLang_getkey (void); + + DESCRIPTION + The `SLang_getkey' reads a single character from the terminal + and returns it. The terminal must first be initialized via a call + to `SLang_init_tty' before this function can be called. Upon + success, `SLang_getkey' returns the character read from the + terminal, otherwise it returns `SLANG_GETKEY_ERROR'. + + SEE ALSO + SLang_init_tty, SLang_input_pending, SLang_ungetkey +-------------------------------------------------------------- + +SLang_ungetkey_string + + SYNOPSIS + Unget a key string + + USAGE + int SLang_ungetkey_string (unsigned char *buf, unsigned int n) + + DESCRIPTION + The `SLang_ungetkey_string' function may be used to push the + `n' characters pointed to by `buf' onto the buffered input + stream that `SLgetkey' uses. If there is not enough room for + the characters, -1 is returned and none are buffered. Otherwise, + it returns zero. + + NOTES + The difference between `SLang_buffer_keystring' and + `SLang_ungetkey_string' is that the `SLang_buffer_keystring' + appends the characters to the end of the getkey buffer, whereas + `SLang_ungetkey_string' inserts the characters at the beginning + of the input buffer. + + SEE ALSO + SLang_ungetkey, SLang_getkey +-------------------------------------------------------------- + +SLang_buffer_keystring + + SYNOPSIS + Append a keystring to the input buffer + + USAGE + int SLang_buffer_keystring (unsigned char *b, unsigned int len) + + DESCRIPTION + `SLang_buffer_keystring' places the `len' characters + specified by `b' at the _end_ of the buffer that + `SLang_getkey' uses. Upon success it returns 0; otherwise, no + characters are buffered and it returns -1. + + NOTES + The difference between `SLang_buffer_keystring' and + `SLang_ungetkey_string' is that the `SLang_buffer_keystring' + appends the characters to the end of the getkey buffer, whereas + `SLang_ungetkey_string' inserts the characters at the beginning + of the input buffer. + + SEE ALSO + SLang_getkey, SLang_ungetkey, SLang_ungetkey_string +-------------------------------------------------------------- + +SLang_ungetkey + + SYNOPSIS + Push a character back onto the input buffer + + USAGE + int SLang_ungetkey (unsigned char ch) + + DESCRIPTION + `SLang_ungetkey' pushes the character `ch' back onto the + `SLgetkey' input stream. Upon success, it returns zero, + otherwise it returns 1. + + EXAMPLE + This function is implemented as: + + int SLang_ungetkey (unsigned char ch) + { + return SLang_ungetkey_string(&ch, 1); + } + + + SEE ALSO + SLang_getkey, SLang_ungetkey_string +-------------------------------------------------------------- + +SLang_flush_input + + SYNOPSIS + Discard all keyboard input waiting to be read + + USAGE + void SLang_flush_input (void) + + DESCRIPTION + `SLang_flush_input' discards all input characters waiting to be + read by the `SLang_getkey' function. + + SEE ALSO + SLang_getkey +-------------------------------------------------------------- + +SLang_input_pending + + SYNOPSIS + Check to see if input is pending + + USAGE + int SLang_input_pending (int tsecs) + + DESCRIPTION + `SLang_input_pending' may be used to see if an input character + is available to be read without causing `SLang_getkey' to block. + It will wait up to `tsecs' tenths of a second if no characters + are immediately available for reading. If `tsecs' is less than + zero, then `SLang_input_pending' will wait `-tsecs' + milliseconds for input, otherwise `tsecs' represents `1/10' + of a second intervals. + + NOTES + Not all systems support millisecond resolution. + + SEE ALSO + SLang_getkey +-------------------------------------------------------------- + +SLang_set_abort_signal + + SYNOPSIS + Set the signal to trap SIGINT + + USAGE + void SLang_set_abort_signal (void (*f)(int)); + + DESCRIPTION + `SLang_set_abort_signal' sets the function that gets + triggered when the user presses the interrupt key (`SIGINT') to + the function `f'. If `f' is `NULL' the default handler + will get installed. + + EXAMPLE + The default interrupt handler on a Unix system is: + + static void default_sigint (int sig) + { + SLKeyBoard_Quit = 1; + if (SLang_Ignore_User_Abort == 0) SLang_Error = SL_USER_BREAK; + SLsignal_intr (SIGINT, default_sigint); + } + + + NOTES + For Unix programmers, the name of this function may appear + misleading since it is associated with `SIGINT' and not + `SIGABRT'. The origin of the name stems from the original intent + of the function: to allow the user to abort the running of a S-Lang + interpreter function. + + SEE ALSO + SLang_init_tty, SLsignal_intr +-------------------------------------------------------------- + +SLkm_define_key + + SYNOPSIS + Define a key in a keymap + + USAGE + int SLkm_define_key (char *seq, FVOID_STAR f, SLKeyMap_List_Type *km) + + DESCRIPTION + `SLkm_define_key' associates the key sequence `seq' with the + function pointer `f' in the keymap specified by `km'. Upon + success, it returns zero, otherwise it returns a negative integer + upon error. + + SEE ALSO + SLkm_define_keysym, SLang_define_key +-------------------------------------------------------------- + +SLang_define_key + + SYNOPSIS + Define a key in a keymap + + USAGE + int SLang_define_key(char *seq, char *fun, SLKeyMap_List_Type *km) + + DESCRIPTION + `SLang_define_key' associates the key sequence `seq' with + the function whose name is `fun' in the keymap specified by + `km'. + + SEE ALSO + SLkm_define_keysym, SLkm_define_key +-------------------------------------------------------------- + +SLkm_define_keysym + + SYNOPSIS + Define a keysym in a keymap + + USAGE + int SLkm_define_keysym (seq, ks, km) + + char *seq; + unsigned int ks; + SLKeyMap_List_Type *km; + + + DESCRIPTION + `SLkm_define_keysym' associates the key sequence `seq' with + the keysym `ks' in the keymap `km'. Keysyms whose value is + less than or equal to `0x1000' is reserved by the library and + should not be used. + + SEE ALSO + SLkm_define_key, SLang_define_key +-------------------------------------------------------------- + +SLang_undefine_key + + SYNOPSIS + Undefined a key from a keymap + + USAGE + void SLang_undefine_key(char *seq, SLKeyMap_List_Type *km); + + DESCRIPTION + `SLang_undefine_key' removes the key sequence `seq' from the + keymap `km'. + + SEE ALSO + SLang_define_key +-------------------------------------------------------------- + +SLang_create_keymap + + SYNOPSIS + Create a new keymap + + USAGE + SLKeyMap_List_Type *SLang_create_keymap (name, km) + + char *name; + SLKeyMap_List_Type *km; + + + DESCRIPTION + `SLang_create_keymap' creates a new keymap called `name' by + copying the key definitions from the keymap `km'. If `km' + is `NULL', the newly created keymap will be empty and it is up + to the calling routine to initialize it via the + `SLang_define_key' and `SLkm_define_keysym' functions. + `SLang_create_keymap' returns a pointer to the new keymap, or + `NULL' upon failure. + + SEE ALSO + SLang_define_key, SLkm_define_keysym +-------------------------------------------------------------- + +SLang_do_key + + SYNOPSIS + Read a keysequence and return its keymap entry + + USAGE + SLang_Key_Type *SLang_do_key (kml, getkey) + + SLKeyMap_List_Type *kml; + int (*getkey)(void); + + + DESCRIPTION + The `SLang_do_key' function reads characters using the function + specified by the `getkey' function pointer and uses the + key sequence to return the appropriate entry in the keymap specified + by `kml'. + + `SLang_do_key' returns `NULL' if the key sequence is not + defined by the keymap, otherwise it returns a pointer to an object + of type `SLang_Key_Type', which is defined in `slang.h' as + + #define SLANG_MAX_KEYMAP_KEY_SEQ 14 + typedef struct SLang_Key_Type + { + struct SLang_Key_Type *next; + union + { + char *s; + FVOID_STAR f; + unsigned int keysym; + } + f; + unsigned char type; /* type of function */ + #define SLKEY_F_INTERPRET 0x01 + #define SLKEY_F_INTRINSIC 0x02 + #define SLKEY_F_KEYSYM 0x03 + unsigned char str[SLANG_MAX_KEYMAP_KEY_SEQ + 1];/* key sequence */ + } + SLang_Key_Type; + + + The `type' field specifies which field of the union `f' + should be used. If `type' is `SLKEY_F_INTERPRET', then + `f.s' is a string that should be passed to the interpreter for + evaluation. If `type' is `SLKEY_F_INTRINSIC', then + `f.f' refers to function that should be called. Otherwise, + `type' is `SLKEY_F_KEYSYM' and `f.keysym' represents the + value of the keysym that is associated with the key sequence. + + SEE ALSO + SLkm_define_keysym, SLkm_define_key +-------------------------------------------------------------- + +SLang_find_key_function + + SYNOPSIS + Obtain a function pointer associated with a keymap + + USAGE + FVOID_STAR SLang_find_key_function (fname, km); + + char *fname; + SLKeyMap_List_Type *km; + + + DESCRIPTION + The `SLang_find_key_function' routine searches through the + `SLKeymap_Function_Type' list of functions associated with the + keymap `km' for the function with name `fname'. + If a matching function is found, a pointer to the function will + be returned, otherwise `SLang_find_key_function' will return + `NULL'. + + SEE ALSO + SLang_create_keymap, SLang_find_keymap +-------------------------------------------------------------- + +SLang_find_keymap + + SYNOPSIS + Find a keymap + + USAGE + SLKeyMap_List_Type *SLang_find_keymap (char *keymap_name); + + DESCRIPTION + The `SLang_find_keymap' function searches through the list of + keymaps looking for one whose name is `keymap_name'. If a + matching keymap is found, the function returns a pointer to the + keymap. It returns `NULL' if no such keymap exists. + + SEE ALSO + SLang_create_keymap, SLang_find_key_function +-------------------------------------------------------------- + +SLang_process_keystring + + SYNOPSIS + Un-escape a key-sequence + + USAGE + char *SLang_process_keystring (char *kseq); + + DESCRIPTION + The `SLang_process_keystring' function converts an escaped key + sequence to its raw form by converting two-character combinations + such as `^A' to the _single_ character `Ctrl-A' (ASCII + 1). In addition, if the key sequence contains constructs such as + `^(XX)', where `XX' represents a two-character termcap + specifier, the termcap escape sequence will be looked up and + substituted. + + Upon success, `SLang_process_keystring' returns a raw + key-sequence whose first character represents the total length of + the key-sequence, including the length specifier itself. It returns + `NULL' upon failure. + + EXAMPLE + Consider the following examples: + + SLang_process_keystring ("^X^C"); + SLang_process_keystring ("^[[A"); + + The first example will return a pointer to a buffer of three characters + whose ASCII values are given by `{3,24,3}'. Similarly, the + second example will return a pointer to the four characters + `{4,27,91,65}'. Finally, the result of + + SLang_process_keystring ("^[^(ku)"); + + will depend upon the termcap/terminfo capability `"ku"', which + represents the escape sequence associated with the terminal's UP + arrow key. For an ANSI terminal whose UP arrow produces + `"ESC [ A"', the result will be `5,27,27,91,65'. + + NOTES + `SLang_process_keystring' returns a pointer to a static area + that will be overwritten on subsequent calls. + + SEE ALSO + SLang_define_key, SLang_make_keystring +-------------------------------------------------------------- + +SLang_make_keystring + + SYNOPSIS + Make a printable key sequence + + USAGE + char *SLang_make_keystring (unsigned char *ks); + + DESCRIPTION + The `SLang_make_keystring' function takes a raw key sequence + `ks' and converts it to a printable form by converting + characters such as ASCII 1 (ctrl-A) to `^A'. That is, it + performs the opposite function of `SLang_process_keystring'. + + NOTES + This function returns a pointer to a static area that will be + overwritten on the next call to `SLang_make_keystring'. + + SEE ALSO + SLang_process_keystring +-------------------------------------------------------------- + +SLextract_list_element + + SYNOPSIS + Extract a substring of a delimited string + + USAGE + int SLextract_list_element (dlist, nth, delim, buf, buflen) + + char *dlist; + unsigned int nth; + char delim; + char *buf; + unsigned int buflen; + + + DESCRIPTION + `SLextract_list_element' may be used to obtain the `nth' + element of a list of strings, `dlist', that are delimited by the + character `delim'. The routine copies the `nth' element of + `dlist' to the buffer `buf' whose size is `buflen' + characters. It returns zero upon success, or -1 if `dlist' + does not contain an `nth' element. + + EXAMPLE + A delimited list of strings may be turned into an array of strings + as follows. For conciseness, all malloc error checking has been + omitted. + + int list_to_array (char *list, char delim, char ***ap) + { + unsigned int nth; + char **a; + char buf[1024]; + + /* Determine the size of the array */ + nth = 0; + while (0 == SLextract_list_element (list, nth, delim, buf, sizeof(buf))) + nth++; + + ap = (char **) SLmalloc ((nth + 1) * sizeof (char **)); + nth = 0; + while (0 == SLextract_list_element (list, nth, delim, buf, sizeof(buf))) + { + a[nth] = SLmake_string (buf); + nth++; + } + a[nth] = NULL; + *ap = a; + return 0; + } + + + SEE ALSO + SLmalloc, SLmake_string +-------------------------------------------------------------- + +SLprep_open_prep + + SYNOPSIS + ?? + + USAGE + int SLprep_open_prep (SLPreprocess_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLprep_close_prep + + SYNOPSIS + ?? + + USAGE + void SLprep_close_prep (SLPreprocess_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLprep_line_ok + + SYNOPSIS + ?? + + USAGE + int SLprep_line_ok (char *, SLPreprocess_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLdefine_for_ifdef + + SYNOPSIS + ?? + + USAGE + int SLdefine_for_ifdef (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLang_Read_Line_Type * SLang_rline_save_line (SLang_RLine_Info_Type *); + + SYNOPSIS + ?? + + USAGE + SLang_Read_Line_Type * SLang_rline_save_line (SLang_RLine_Info_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLang_init_readline (SLang_RLine_Info_Type *); + + SYNOPSIS + ?? + + USAGE + int SLang_init_readline (SLang_RLine_Info_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLang_read_line (SLang_RLine_Info_Type *); + + SYNOPSIS + ?? + + USAGE + int SLang_read_line (SLang_RLine_Info_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLang_rline_insert (char *); + + SYNOPSIS + ?? + + USAGE + int SLang_rline_insert (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLrline_redraw (SLang_RLine_Info_Type *); + + SYNOPSIS + ?? + + USAGE + void SLrline_redraw (SLang_RLine_Info_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_flush_output (void); + + SYNOPSIS + ?? + + USAGE + int SLtt_flush_output (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_set_scroll_region(int, int); + + SYNOPSIS + ?? + + USAGE + void SLtt_set_scroll_region(int, int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_reset_scroll_region(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_reset_scroll_region(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_reverse_video (int); + + SYNOPSIS + ?? + + USAGE + void SLtt_reverse_video (int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_bold_video (void); + + SYNOPSIS + ?? + + USAGE + void SLtt_bold_video (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_begin_insert(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_begin_insert(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_end_insert(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_end_insert(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_del_eol(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_del_eol(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_goto_rc (int, int); + + SYNOPSIS + ?? + + USAGE + void SLtt_goto_rc (int, int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_delete_nlines(int); + + SYNOPSIS + ?? + + USAGE + void SLtt_delete_nlines(int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_delete_char(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_delete_char(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_erase_line(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_erase_line(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_normal_video(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_normal_video(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_cls(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_cls(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_beep(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_beep(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_reverse_index(int); + + SYNOPSIS + ?? + + USAGE + void SLtt_reverse_index(int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_smart_puts(unsigned short *, unsigned short *, int, int); + + SYNOPSIS + ?? + + USAGE + void SLtt_smart_puts(unsigned short *, unsigned short *, int, int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_write_string (char *); + + SYNOPSIS + ?? + + USAGE + void SLtt_write_string (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_putchar(char); + + SYNOPSIS + ?? + + USAGE + void SLtt_putchar(char); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_init_video (void); + + SYNOPSIS + ?? + + USAGE + int SLtt_init_video (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_reset_video (void); + + SYNOPSIS + ?? + + USAGE + int SLtt_reset_video (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_get_terminfo(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_get_terminfo(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_get_screen_size (void); + + SYNOPSIS + ?? + + USAGE + void SLtt_get_screen_size (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_set_cursor_visibility (int); + + SYNOPSIS + ?? + + USAGE + int SLtt_set_cursor_visibility (int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_initialize (char *); + + SYNOPSIS + ?? + + USAGE + int SLtt_initialize (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_enable_cursor_keys(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_enable_cursor_keys(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_set_term_vtxxx(int *); + + SYNOPSIS + ?? + + USAGE + void SLtt_set_term_vtxxx(int *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_set_color_esc (int, char *); + + SYNOPSIS + ?? + + USAGE + void SLtt_set_color_esc (int, char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_wide_width(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_wide_width(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_narrow_width(void); + + SYNOPSIS + ?? + + USAGE + void SLtt_narrow_width(void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_set_mouse_mode (int, int); + + SYNOPSIS + ?? + + USAGE + int SLtt_set_mouse_mode (int, int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_set_alt_char_set (int); + + SYNOPSIS + ?? + + USAGE + void SLtt_set_alt_char_set (int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_write_to_status_line (char *, int); + + SYNOPSIS + ?? + + USAGE + int SLtt_write_to_status_line (char *, int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_disable_status_line (void); + + SYNOPSIS + ?? + + USAGE + void SLtt_disable_status_line (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +char *SLtt_tgetstr (char *); + + SYNOPSIS + ?? + + USAGE + char *SLtt_tgetstr (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_tgetnum (char *); + + SYNOPSIS + ?? + + USAGE + int SLtt_tgetnum (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_tgetflag (char *); + + SYNOPSIS + ?? + + USAGE + int SLtt_tgetflag (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +char *SLtt_tigetent (char *); + + SYNOPSIS + ?? + + USAGE + char *SLtt_tigetent (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +char *SLtt_tigetstr (char *, char **); + + SYNOPSIS + ?? + + USAGE + char *SLtt_tigetstr (char *, char **); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLtt_tigetnum (char *, char **); + + SYNOPSIS + ?? + + USAGE + int SLtt_tigetnum (char *, char **); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLtt_Char_Type SLtt_get_color_object (int); + + SYNOPSIS + ?? + + USAGE + SLtt_Char_Type SLtt_get_color_object (int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_set_color_object (int, SLtt_Char_Type); + + SYNOPSIS + ?? + + USAGE + void SLtt_set_color_object (int, SLtt_Char_Type); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_set_color (int, char *, char *, char *); + + SYNOPSIS + ?? + + USAGE + void SLtt_set_color (int, char *, char *, char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_set_mono (int, char *, SLtt_Char_Type); + + SYNOPSIS + ?? + + USAGE + void SLtt_set_mono (int, char *, SLtt_Char_Type); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_add_color_attribute (int, SLtt_Char_Type); + + SYNOPSIS + ?? + + USAGE + void SLtt_add_color_attribute (int, SLtt_Char_Type); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLtt_set_color_fgbg (int, SLtt_Char_Type, SLtt_Char_Type); + + SYNOPSIS + ?? + + USAGE + void SLtt_set_color_fgbg (int, SLtt_Char_Type, SLtt_Char_Type); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLkp_define_keysym (char *, unsigned int); + + SYNOPSIS + ?? + + USAGE + int SLkp_define_keysym (char *, unsigned int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLkp_init (void); + + SYNOPSIS + ?? + + USAGE + int SLkp_init (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLkp_getkey (void); + + SYNOPSIS + ?? + + USAGE + int SLkp_getkey (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLscroll_find_top (SLscroll_Window_Type *); + + SYNOPSIS + ?? + + USAGE + int SLscroll_find_top (SLscroll_Window_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLscroll_find_line_num (SLscroll_Window_Type *); + + SYNOPSIS + ?? + + USAGE + int SLscroll_find_line_num (SLscroll_Window_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +unsigned int SLscroll_next_n (SLscroll_Window_Type *, unsigned int); + + SYNOPSIS + ?? + + USAGE + unsigned int SLscroll_next_n (SLscroll_Window_Type *, unsigned int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +unsigned int SLscroll_prev_n (SLscroll_Window_Type *, unsigned int); + + SYNOPSIS + ?? + + USAGE + unsigned int SLscroll_prev_n (SLscroll_Window_Type *, unsigned int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLscroll_pageup (SLscroll_Window_Type *); + + SYNOPSIS + ?? + + USAGE + int SLscroll_pageup (SLscroll_Window_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLscroll_pagedown (SLscroll_Window_Type *); + + SYNOPSIS + ?? + + USAGE + int SLscroll_pagedown (SLscroll_Window_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLSig_Fun_Type *SLsignal (int, SLSig_Fun_Type *); + + SYNOPSIS + ?? + + USAGE + SLSig_Fun_Type *SLsignal (int, SLSig_Fun_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLSig_Fun_Type *SLsignal_intr (int, SLSig_Fun_Type *); + + SYNOPSIS + ?? + + USAGE + SLSig_Fun_Type *SLsignal_intr (int, SLSig_Fun_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLsig_block_signals (void); + + SYNOPSIS + ?? + + USAGE + int SLsig_block_signals (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLsig_unblock_signals (void); + + SYNOPSIS + ?? + + USAGE + int SLsig_unblock_signals (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLsystem (char *); + + SYNOPSIS + ?? + + USAGE + int SLsystem (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLadd_at_handler (long *, char *); + + SYNOPSIS + ?? + + USAGE + void SLadd_at_handler (long *, char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLang_define_case(int *, int *); + + SYNOPSIS + ?? + + USAGE + void SLang_define_case(int *, int *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLang_init_case_tables (void); + + SYNOPSIS + ?? + + USAGE + void SLang_init_case_tables (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +unsigned char *SLang_regexp_match(unsigned char *, unsigned int, SLRegexp_Type *); + + SYNOPSIS + ?? + + USAGE + unsigned char *SLang_regexp_match(unsigned char *, unsigned int, SLRegexp_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLang_regexp_compile (SLRegexp_Type *); + + SYNOPSIS + ?? + + USAGE + int SLang_regexp_compile (SLRegexp_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +char *SLregexp_quote_string (char *, char *, unsigned int); + + SYNOPSIS + ?? + + USAGE + char *SLregexp_quote_string (char *, char *, unsigned int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLcmd_execute_string (char *, SLcmd_Cmd_Table_Type *); + + SYNOPSIS + ?? + + USAGE + int SLcmd_execute_string (char *, SLcmd_Cmd_Table_Type *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLsearch_init (char *, int, int, SLsearch_Type *); + + SYNOPSIS + ?? + + USAGE + int SLsearch_init (char *, int, int, SLsearch_Type *); + + DESCRIPTION + ?? + /* This routine must first be called before any search can take place. + * The second parameter specifies the direction of the search: greater than + * zero for a forwrd search and less than zero for a backward search. The + * third parameter specifies whether the search is case sensitive or not. + * The last parameter is a pointer to a structure that is filled by this + * function and it is this structure that must be passed to SLsearch. + */ + + SEE ALSO + ?? +-------------------------------------------------------------- + +unsigned char *SLsearch (unsigned char *, unsigned char *, SLsearch_Type *); + + SYNOPSIS + ?? + + USAGE + unsigned char *SLsearch (unsigned char *, unsigned char *, SLsearch_Type *); + + DESCRIPTION + ?? + /* To use this routine, you must first call 'SLsearch_init'. Then the first + * two parameters p1 and p2 serve to define the region over which the search + * is to take place. The third parameter is the structure that was previously + * initialized by SLsearch_init. + * + * The routine returns a pointer to the match if found otherwise it returns + * NULL. + */ + + SEE ALSO + ?? +-------------------------------------------------------------- + +SLcomplex_abs + + SYNOPSIS + Returns the norm of a complex number + + USAGE + double SLcomplex_abs (double *z) + + DESCRIPTION + The `SLcomplex_abs' function returns the absolute value or the + norm of the complex number given by `z'. + + SEE ALSO + SLcomplex_times +-------------------------------------------------------------- + +double *SLcomplex_times (double *, double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_times (double *, double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_divide (double *, double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_divide (double *, double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_sin (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_sin (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_cos (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_cos (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_tan (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_tan (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_asin (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_asin (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_acos (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_acos (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_atan (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_atan (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_exp (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_exp (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_log (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_log (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_log10 (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_log10 (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_sqrt (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_sqrt (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_sinh (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_sinh (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_cosh (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_cosh (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_tanh (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_tanh (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_pow (double *, double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_pow (double *, double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double SLmath_hypot (double x, double y); + + SYNOPSIS + ?? + + USAGE + double SLmath_hypot (double x, double y); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_acosh (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_acosh (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +double *SLcomplex_atanh (double *, double *); + + SYNOPSIS + ?? + + USAGE + double *SLcomplex_atanh (double *, double *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +char *SLdebug_malloc (unsigned long); + + SYNOPSIS + ?? + + USAGE + char *SLdebug_malloc (unsigned long); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +char *SLdebug_calloc (unsigned long, unsigned long); + + SYNOPSIS + ?? + + USAGE + char *SLdebug_calloc (unsigned long, unsigned long); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +char *SLdebug_realloc (char *, unsigned long); + + SYNOPSIS + ?? + + USAGE + char *SLdebug_realloc (char *, unsigned long); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLdebug_free (char *); + + SYNOPSIS + ?? + + USAGE + void SLdebug_free (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLmalloc_dump_statistics (void); + + SYNOPSIS + ?? + + USAGE + void SLmalloc_dump_statistics (void); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +char *SLstrcpy(register char *, register char *); + + SYNOPSIS + ?? + + USAGE + char *SLstrcpy(register char *, register char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLstrcmp(register char *, register char *); + + SYNOPSIS + ?? + + USAGE + int SLstrcmp(register char *, register char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +char *SLstrncpy(char *, register char *, register int); + + SYNOPSIS + ?? + + USAGE + char *SLstrncpy(char *, register char *, register int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLmemset (char *, char, int); + + SYNOPSIS + ?? + + USAGE + void SLmemset (char *, char, int); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLexpand_escaped_string (register char *, register char *, register char *); + + SYNOPSIS + ?? + + USAGE + void SLexpand_escaped_string (register char *, register char *, register char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +void SLmake_lut (unsigned char *, unsigned char *, unsigned char); + + SYNOPSIS + ?? + + USAGE + void SLmake_lut (unsigned char *, unsigned char *, unsigned char); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + +int SLang_guess_type (char *); + + SYNOPSIS + ?? + + USAGE + int SLang_guess_type (char *); + + DESCRIPTION + ?? + + SEE ALSO + ?? +-------------------------------------------------------------- + diff --git a/libslang/doc/text/cslang.txt b/libslang/doc/text/cslang.txt new file mode 100644 index 0000000..18eab6a --- /dev/null +++ b/libslang/doc/text/cslang.txt @@ -0,0 +1,2989 @@ + S-Lang Library C Programmer's Guide, V1.4.9 + John E. Davis, davis@space.mit.edu + Mar 23, 2003 + ____________________________________________________________ + + Table of Contents + + Preface + + 1. A Brief History of S-Lang + 2. Acknowledgements + 2. Introduction + 2. Interpreter Interface + 3. Embedding the Interpreter + 4. Calling the Interpreter + 4.1 Loading Files + 4.2 Loading Strings + + 5. Intrinsic Functions + 5.1 Restrictions on Intrinsic Functions + 5.2 Adding a New Intrinsic + 5.3 More Complicated Intrinsics + + 6. Intrinsic Variables + 7. Aggregate Data Objects + 7.1 Arrays + 7.2 Structures + 7.2.1 Interpreter Structures + 7.2.2 Intrinsic Structures + 7.2.2 Keyboard Interface + + 8. Initializing the Keyboard Interface + 9. Resetting the Keyboard Interface + 10. Initializing the SLkp Routines + 11. Setting the Interrupt Handler + 12. Reading Keyboard Input with SLang_getkey + 13. Reading Keyboard Input with SLkp_getkey + 14. Buffering Input + 15. Global Variables + 15. Screen Management + 16. Initialization + 17. Resetting SLsmg + 18. Handling Screen Resize Events + 19. SLsmg Functions + 19.1 Positioning the cursor + 19.2 Writing to the Display + 19.3 Erasing the Display + 19.4 Setting Character Attributes + 19.5 Lines and Alternate Character Sets + 19.6 Miscellaneous Functions + + 20. Variables + 21. Hints for using SLsmg + 21. Signal Functions + 21. Searching Functions + 22. Regular Expressions + 23. Simple Searches + 24. Initialization + 25. SLsearch + 25. Copyright + A. The GNU Public License + B. The Artistic License + + + ______________________________________________________________________ + + 1. Preface + + + + S-Lang is an interpreted language that was designed from the start to + be easily embedded into a program to provide it with a powerful + extension language. Examples of programs that use S-Lang as an + extension language include the jed text editor, the slrn newsreader, + and sldxe (unreleased), a numerical computation program. For this + reason, S-Lang does not exist as a separate application and many of + the examples in this document are presented in the context of one of + the above applications. + + S-Lang is also a programmer's library that permits a programmer to + develop sophisticated platform-independent software. In addition to + providing the S-Lang extension language, the library provides + facilities for screen management, keymaps, low-level terminal I/O, + etc. However, this document is concerned only with the extension + language and does not address these other features of the S-Lang + library. For information about the other components of the library, + the reader is referred to the The S-Lang Library Reference. + + + 1.1. A Brief History of S-Lang + + + + I first began working on S-Lang sometime during the fall of 1992. At + that time I was writing a text editor (jed), which I wanted to endow + with a macro language. It occured to me that an application- + independent language that could be embedded into the editor would + prove more useful because I could envision embedding it into other + programs. As a result, S-Lang was born. + + S-Lang was originally a stack language that supported a postscript- + like syntax. For that reason, I named it S-Lang, where the S was + supposed to emphasize its stack-based nature. About a year later, I + began to work on a preparser that would allow one to write using a + more traditional infix syntax making it easier to use for those + unfamiliar with stack based languages. Currently, the syntax of the + language resembles C, nevertheless some postscript-like features still + remain, e.g., the `%' character is still used as a comment delimiter. + + + + 1.2. Acknowledgements + + + + Since I first released S-Lang, I have received a lot feedback about + the library and the language from many people. This has given me the + opportunity and pleasure to interact with several people to make the + library portable and easy to use. In particular, I would like to + thank the following individuals: + + Luchesar Ionkov for his comments and criticisms of + the syntax of the language. He was the person who made me realize + that the low-level byte-code engine should be totally type- + independent. He also improved the tokenizer and preparser and + impressed upon me that the language needed a grammar. + + Mark Olesen for his many patches to + various aspects of the library and his support on AIX. He also + contributed a lot to the pre-processing (SLprep) routines. + + John Burnell for the OS/2 port of the video and + keyboard routines. He also made value suggestions regarding the + interpreter interface. + + Darrel Hankerson for cleaning up and + unifying some of the code and the makefiles. + + Dominik Wujastyk who was always willing to test + new releases of the library. + + Michael Elkins for his work on the curses + emulation. + + Ulli Horlacher and Oezguer Kesim for the S-Lang newsgroup and mailing list. + + Hunter Goatley, Andy Harper , and Martin P.J. + Zinser for their VMS support. + + Dave Sims and Chin Huang for + Windows 95 and Windows NT support. + + Lloyd Zusman and Rich Roth for + creating and maintaining www.s-lang.org. + + I am also grateful to many other people who send in bug-reports and + bug-fixes, for without such community involvement, S-Lang would not be + as well-tested and stable as it is. Finally, I would like to thank my + wife for her support and understanding while I spent long weekend + hours developing the library. + + + + 2. Introduction + + + + S-Lang is a C programmer's library that includes routines for the + rapid development of sophisticated, user friendly, multi-platform + applications. The S-Lang library includes the following: + + + o Low level tty input routines for reading single characters at a + time. + + o Keymap routines for defining keys and manipulating multiple + keymaps. + + o A high-level keyprocessing interface (SLkp) for handling function + and arrow keys. + + o High level screen management routines for manipulating both + monochrome and color terminals. These routines are very efficient. + (SLsmg) + + o Low level terminal-independent routines for manipulating the + display of a terminal. (SLtt) + + o Routines for reading single line input with line editing and recall + capabilities. (SLrline) + + o Searching functions: both ordinary searches and regular expression + searches. (SLsearch) + + o An embedded stack-based language interpreter with a C-like syntax. + + + The library is currently available for OS/2, MSDOS, Unix, and VMS + systems. For the most part, the interface to library routines has + been implemented in such a way that it appears to be platform + independent from the point of view of the application. In addition, + care has been taken to ensure that the routines are ``independent'' of + one another as much as possible. For example, although the keymap + routines require keyboard input, they are not tied to S-Lang's + keyboard input routines--- one can use a different keyboard getkey + routine if one desires. This also means that linking to only part of + the S-Lang library does not pull the whole library into the + application. Thus, S-Lang applications tend to be relatively small in + comparison to programs that use libraries with similar capabilities. + + + + 3. Interpreter Interface + + + + The S-Lang library provides an interpreter that when embedded into an + application, makes the application extensible. Examples of programs + that embed the interpreter include the jed editor and the slrn + newsreader. + + Embedding the interpreter is easy. The hard part is to decide what + application specific built-in or intrinsic functions should be + provided by the application. The S-Lang library provides some pre- + defined intrinsic functions, such as string processing functions, and + simple file input-output routines. However, the basic philosophy + behind the interpreter is that it is not a standalone program and it + derives much of its power from the application that embeds it. + + + 3.1. Embedding the Interpreter + + + + Only one function needs to be called to embed the S-Lang interpreter + into an application: SLang_init_slang. This function initializes the + interpreter's data structures and adds some intrinsic functions: + + + if (-1 == SLang_init_slang ()) + exit (EXIT_FAILURE); + + + + This function does not provide file input output intrinsic nor does it + provide mathematical functions. To make these as well as some posix + system calls available use + + + if ((-1 == SLang_init_slang ()) /* basic interpreter functions */ + || (-1 == SLang_init_slmath ()) /* sin, cos, etc... */ + || (-1 == SLang_init_stdio ()) /* stdio file I/O */ + || (-1 == SLang_init_posix_dir ()) /* mkdir, stat, etc. */ + || (-1 == SLang_init_posix_process ()) /* getpid, umask, etc. */ + ) + exit (EXIT_FAILURE); + + + + If you intend to enable all intrinsic functions, then it is simpler to + initialize the interpreter via + + + if (-1 == SLang_init_all ()) + exit (EXIT_FAILURE); + + + + See the \slang-run-time-library for more information about the intrin- + sic functions. + + + + 3.2. Calling the Interpreter + + + + There are several ways of calling the interpreter. The two most + common method is to load a file containing S-Lang code, or to load a + string. + + + 3.2.1. Loading Files + + The SLang_load_file and SLns_load_file functions may be used to + interpret a file. Both these functions return zero if successful, or + -1 upon failure. If either of these functions fail, the interpreter + will accept no more code unless the error state is cleared. This is + done by calling SLang_restart function to set the interpreter to its + default state, and setting SLang_Error to 0, e.g., + + + if (-1 == SLang_load_file ("site.sl")) + { + /* Clear the error and rest the interpreter */ + SLang_restart (1); + SLang_Error = 0; + } + + + + When a file is loaded via SLang_load_file, any non-public variables + and functions defined in the file will be placed into a namespace that + is local to the file itself. The SLns_load_file function may be used + to load a file using a specified namespace, e.g., + + + if (-1 == SLns_load_file ("site.sl", "NS")) + { + SLang_restart (1); + SLang_Error = 0; + } + + + + will load site.sl into a namespace called NS. If such a namespace + does not exist, then it will be created. + + Both the SLang_load_file and SLns_load_file functions search for files + along an application-specified search path. This path may be set + using the SLpath_set_load_path function, as well as from interpeted + code via the set_slang_load_path function. By default, no search path + is defined. + + Files are searched as follows: If the name begins with the equivalent + of "./" or "../", then it is searched for with respect to the current + directory, and not along the load-path. If no such file exists, then + an error will be generated. Otherwise, the file is searched for in + each of the directories of the load-path by concatenating the path + element with the specified file name. The first such file found to + exist by this process will be loaded. If a matching file still has + not been found, and the file name lacks an extension, then the path is + searched with ".sl" and ".slc" appended to the filename. If two such + files are found (one ending with ".sl" and the other with ".slc"), + then the more recent of the two will be used. If no matching file has + been found by this process, then the search will cease and an error + generated. + The search path is a delimiter separated list of directories that + specify where the interpreter looks for files. By default, the value + of the delimiter is OS-dependent following the convention of the + underlying OS. For example, on Unix the delimiter is represented by a + colon, on DOS/Windows it is a semi-colon, and on VMS it is a space. + The SLpath_set_delimiter and SLpath_get_delimiter may be used to set + and query the delimiter's value, respectively. + + + 3.2.2. Loading Strings + + There are several other mechanisms for interacting with the + interpreter. For example, the SLang_load_string function loads a + string into the interpreter and interprets it: + + + if (-1 == SLang_load_string ("message (\"hello\");")) + { + SLang_restart (1); + SLang_Error = 0; + } + + + + Similarly, the SLns_load_string function may be used to load a string + into a specified namespace. + + Typically, an interactive application will load a file via + SLang_load_file and then go into a loop that consists of reading lines + of input and sending them to the interpreter, e.g., + + + while (EOF != fgets (buf, sizeof (buf), stdin)) + { + if (-1 == SLang_load_string (buf)) + SLang_restart (1); + SLang_Error = 0; + } + + + + Finally, some applications such as jed and slrn use another method of + interacting with the interpreter. They read key sequences from the + keyboard and map those key sequences to interpreter functions via the + S-Lang keymap interface. + + + + 3.3. Intrinsic Functions + + + + An intrinsic function is simply a function that is written in C and is + made available to the interpreter as a built-in function. For this + reason, the words `intrinsic' and `built-in' are often used + interchangeably. + + Applications are expected to add application specific functions to the + interpreter. For example, jed adds nearly 300 editor-specific + intrinsic functions. The application designer should think carefully + about what intrinsic functions to add to the interpreter. + + + 3.3.1. Restrictions on Intrinsic Functions + + + + When implementing intrinsic functions, it is necessary to follow a few + rules to cooperate with the interpreter. + + The C version of an intrinsic function takes only pointer arguments. + This is because when the interpreter calls an intrinsic function, it + passes values to the function by reference and not by value. For + example, intrinsic with the declarations: + + + int intrinsic_0 (void); + int intrinsic_1 (char *s); + void intrinsic_2 (char *s, int *i); + void intrinsic_3 (int *i, double *d, double *e); + + + + are all valid. However, + + + int invalid_1 (char *s, int len); + + + + is not valid since the len parameter is not a pointer. + + The return value of an intrinsic function must be one of the following + types: void, char, short, int, long, double, char *, as well as + unsigned versions of the integer types. A function such as + + + int *invalid (void); + + + + is not permitted since int* is not a valid return-type for an intrin- + sic function. Any other type of value can be passed back to the + interpreter by explicitly pushing the object onto the interpreter's + stack via the appropriate "push" function. + + The current implementation limits the number of arguments of an + intrinsic function to 7. The "pop" functions can be used to allow the + function to take an arbitrary number as seen from an interpreter + script. + + Another restriction is that the intrinsic function should regard all + its parameters as pointers to constant objects and make no attempt to + modify the value to which they point. For example, + + + void truncate (char *s) + { + s[0] = 0; + } + + + + is illegal since the function modifies the string s. + + 3.3.2. Adding a New Intrinsic + + + + There are two basic mechanisms for adding an intrinsic function to the + interpreter: SLadd_intrinsic_function and SLadd_intrin_fun_table. + Functions may be added to a specified namespace via + SLns_add_intrinsic_function and SLns_add_intrin_fun_table functions. + + As an specific example, consider a function that will cause the + program to exit via the exit C library function. It is not possible + to make this function an intrinsic because it does not meet the + specifications for an intrinsic function that were described earlier. + However, one can call exit from a function that is suitable, e.g., + + + void intrin_exit (int *code) + { + exit (*code); + } + + + + This function may be made available to the interpreter as an intrinsic + via the SLadd_intrinsic_function routine: + + + if (-1 == SLadd_intrinsic_function ("exit", (FVOID_STAR) intrin_exit, + SLANG_VOID_TYPE, 1, + SLANG_INT_TYPE)) + exit (EXIT_FAILURE); + + + + This statement basically tells the interpreter that intrin_exit is a + function that returns nothing and takes a single argument: a pointer + to an integer (SLANG_INT_TYPE). A user can call this function from + within the interpreter via + + + message ("Calling the exit function"); + exit (0); + + + + After printing a message, this will cause the intrin_exit function to + execute, which in turn calls exit. + + The most convenient mechanism for adding new intrinsic functions is to + create a table of SLang_Intrin_Fun_Type objects and add the table via + the SLadd_intrin_fun_table function. The table will look like: + + + + SLang_Intrin_Fun_Type My_Intrinsics [] = + { + /* table entries */ + MAKE_INTRINSIC_N(...), + MAKE_INTRINSIC_N(...), + . + . + MAKE_INTRINSIC_N(...), + SLANG_END_INTRIN_FUN_TABLE + }; + + + + Construction of the table entries may be facilitated using a set of + MAKE_INTRINSIC macros defined in slang.h. The main macro is called + MAKE_INTRINSIC_N and takes 11 arguments: + + + MAKE_INTRINSIC_N(name, funct-ptr, return-type, num-args, + arg-1-type, arg-2-type, ... arg-7-type) + + + + Here name is the name of the intrinsic function that the interpreter + is to give to the function. func-ptr is a pointer to the intrinsic + function taking num-args and returning ret-type. The final 7 argu- + ments specifiy the argument types. For example, the intrin_exit + intrinsic described above may be added to the table using + + + MAKE_INTRINSIC_N("exit", intrin_exit, SLANG_VOID_TYPE, 1, + SLANG_INT_TYPE, 0,0,0,0,0,0) + + + + While MAKE_INTRINSIC_N is the main macro for constructing table + entries, slang.h defines other macros that may prove useful. In + particular, an entry for the intrin_exit function may also be created + using any of the following forms: + + + MAKE_INTRINSIC_1("exit", intrin_exit, SLANG_VOID_TYPE, SLANG_INT_TYPE) + MAKE_INTRINSIC_I("exit", intrin_exit, SLANG_VOID_TYPE) + + + + See slang.h for related macros. You are also encouraged to look at, + e.g., slang/src/slstd.c for a more extensive examples. + + The table may be added via the SLadd_intrin_fun_table function, e.g., + + + if (-1 == SLadd_intrin_fun_table (My_Intrinsics, NULL)) + { + /* an error occurred */ + } + + + + Please note that there is no need to load a given table more than + once, and it is considered to be an error on the part of the + application it adds the same table multiple times. For performance + reasons, no checking is performed by the library to see if a table has + already been added. + + Earlier it was mentioned that intrinsics may be added to a specified + namespace. To this end, one must first get a pointer to the namespace + via the SLns_create_namespace function. The following example + illustrates how this function is used to add the My_Intrinsics table + to a namespace called my: + + + SLang_NameSpace_Type *ns = SLns_create_namespace ("my"); + if (ns == NULL) + return -1; + + return SLns_add_intrin_fun_table (ns, My_Intrinsics, "__MY__")); + + + + 3.3.3. More Complicated Intrinsics + + + The intrinsic functions described in the previous example were + functions that took a fixed number of arguments. In this section we + explore more complex intrinsics such as those that take a variable + number of arguments. + + Consider a function that takes two double precision numbers and + returns the lesser: + + + double intrin_min (double *a, double *b) + { + if (*a < *b) return *a; + return *b; + } + + + + This function may be added to a table of intrinsics using + + + MAKE_INTRINSIC_2("vmin", intrin_min, SLANG_DOUBLE_TYPE, + SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE) + + + + It is useful to extend this function to take an arbitray number of + arguments and return the lesser. Consider the following variant: + + + + double intrin_min_n (int *num_ptr) + { + double min_value, x; + unsigned int num = (unsigned int) *num_ptr; + + if (-1 == SLang_pop_double (&min_value, NULL, NULL)) + return 0.0; + num--; + + while (num > 0) + { + num--; + if (-1 == SLang_pop_double (&x, NULL, NULL)) + return 0.0; + if (x < min_value) min_value = x; + } + return min_value; + } + + + + Here the number to compare is passed to the function and the actual + numbers are removed from the stack via the SLang_pop_double function. + A suitable table entry for it is + + + MAKE_INTRINSIC_I("vmin", intrin_min_n, SLANG_DOUBLE_TYPE) + + + + This function would be used in an interpreter script via a statement + such as + + + variable xmin = vmin (x0, x1, x2, x3, x4, 5); + + + + which computes the smallest of 5 values. + + The problem with this intrinsic function is that the user must + explicitly specify how many numbers to compare. It would be more + convenient to simply use + + + variable xmin = vmin (x0, x1, x2, x3, x4); + + + + An intrinsic function can query the value of the variable + SLang_Num_Function_Args to obtain the necessary information: + + + + double intrin_min (void) + { + double min_value, x; + + unsigned int num = SLang_Num_Function_Args; + + if (-1 == SLang_pop_double (&min_value, NULL, NULL)) + return 0.0; + num--; + + while (num > 0) + { + num--; + if (-1 == SLang_pop_double (&x, NULL, NULL)) + return 0.0; + if (x < min_value) min_value = x; + } + return min_value; + } + + + + This may be declared as an intrinsic using: + + + MAKE_INTRINSIC_0("vmin", intrin_min, SLANG_DOUBLE_TYPE) + + + + 3.4. Intrinsic Variables + + + + It is possible to access an application's global variables from within + the interpreter. The current implementation supports the access of + variables of type int, char *, and double. + + There are two basic methods of making an intrinsic variable available + to the interpreter. The most straight forward method is to use the + function SLadd_intrinsic_variable: + + + int SLadd_intrinsic_variable (char *name, VOID_STAR addr, + unsigned char data_type, + int read_only); + + + + For example, suppose that I is an integer variable, e.g., + + + int I; + + + + One can make it known to the interpreter as I_Variable via a statement + such as + + + if (-1 == SLadd_intrinsic_variable ("I_Variable", &I, + SLANG_INT_TYPE, 0)) + exit (EXIT_FAILURE); + + + + Similarly, if S is declared as + + + char *S; + + + + then + + + if (-1 == SLadd_intrinsic_variable ("S_Variable", &S, + SLANG_STRING_TYPE, 1)) + exit (EXIT_FAILURE); + + + + makes S available as a read-only variable with the name S_Variable. + Note that if a pointer variable is made available to the interpreter, + its value is managed by the interpreter and not the application. For + this reason, it is recommended that such variables be declared as + read-only. + + It is important to note that if S were declared as an array of + characters, e.g., + + + char S[256]; + + + + then it would not be possible to make it directly available to the + interpreter. However, one could create a pointer to it, i.e., + + + char *S_Ptr = S; + + + + and make S_Ptr available as a read-only variable. + + One should not make the mistake of trying to use the same address for + different variables as the following example illustrates: + + + + int do_not_try_this (void) + { + static char *names[3] = {"larry", "curly", "moe"}; + unsigned int i; + + for (i = 0; i < 3; i++) + { + int value; + if (-1 == SLadd_intrinsic_variable (names[i], (VOID_STAR) &value, + SLANG_INT_TYPE, 1)) + return -1; + } + return 0; + } + + + + Not only does this piece of code create intrinsic variables that use + the same address, it also uses the address of a local variable that + will go out of scope. + + The most convenient method for adding many intrinsic variables to the + interpreter is to create an array of SLang_Intrin_Var_Type objects and + then add the array via SLadd_intrin_var_table. For example, the array + + + static SLang_Intrin_Var_Type Intrin_Vars [] = + { + MAKE_VARIABLE("I_Variable", &I, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("S_Variable", &S_Ptr, SLANG_STRING_TYPE, 1), + SLANG_END_TABLE + }; + + + + may be added via + + + if (-1 == SLadd_intrin_var_table (Intrin_Vars, NULL)) + exit (EXIT_FAILURE); + + + + It should be rather obvious that the arguments to the MAKE_VARIABLE + macro correspond to the parameters of the SLadd_intrinsic_variable + function. + + Finally, variables may be added to a specific namespace via the + SLns_add_intrin_var_table and SLns_add_intrinsic_variable functions. + + + + 3.5. Aggregate Data Objects + + + An aggregate data object is an object that can contain more than one + data value. The S-Lang interpreter supports several such objects: + arrays, structure, and associative arrays. In the following sections, + information about interacting with these objects is given. + + + + 3.5.1. Arrays + + + An intrinsic function may interact with an array in several different + ways. For example, an intrinsic may create an array and return it. + The basic functions for manipulating arrays include: + + + SLang_create_array + SLang_pop_array_of_type + SLang_push_array + SLang_free_array + SLang_get_array_element + SLang_set_array_element + + + + The use of these functions will be illustrated via a few simple exam- + ples. + + The first example shows how to create an return an array of strings to + the interpreter. In particular, the names of the four seasons of the + year will be returned: + + + void months_of_the_year (void) + { + static char *seasons[4] = + { + "Spring", "Summer", "Autumn", "Winter" + }; + SLang_Array_Type *at; + int i, four; + + four = 4; + at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &four, 1); + if (at == NULL) + return; + + /* Now set the elements of the array */ + for (i = 0; i < 4; i++) + { + if (-1 == SLang_set_array_element (at, &i, &seasons[i])) + { + SLang_free_array (at); + return; + } + } + + (void) SLang_push_array (at, 0); + SLang_free_array (at); + } + + + + This example illustrates several points. First of all, the SLang_cre- + ate_array function was used to create a 1 dimensional array of 4 + strings. Since this function could fail, its return value was + checked. Then the SLang_set_array_element function was used to set + the elements of the newly created array. Note that the address con- + taining the value of the array element was passed and not the value of + the array element itself. That is, + + + SLang_set_array_element (at, &i, seasons[i]) + + + + was not used. The return value from this function was also checked + because it too could also fail. Finally, the array was pushed onto + the interpreter's stack and then it was freed. It is important to + understand why it was freed. This is because arrays are reference- + counted. When the array was created, it was returned with a reference + count of 1. When it was pushed, the reference count was bumped up to + 2. Then since it was nolonger needed by the function, + SLang_free_array was called to decrement the reference count back to + 1. For convenience, the second argument to SLang_push_array deter- + mines whether or not it is to also free the array. So, instead of the + two function calls: + + + (void) SLang_push_array (at, 0); + SLang_free_array (at); + + + + it is preferable to combine them as + + + (void) SLang_push_array (at, 1); + + + + The second example returns a diagonal array of a specified size to the + stack. A diagonal array is a 2-d array with all elements zero except + for those along the diagonal, which have a value of one: + + + void make_diagonal_array (int n) + { + SLang_Array_Type *at; + int dims[2]; + int i, one; + + dims[0] = dims[1] = n; + at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, dims, 2); + if (at == NULL) + return; + + one = 1; + for (i = 0; i < n; i++) + { + dims[0] = dims[1] = i; + if (-1 == SLang_set_array_element (at, dims, &one)) + { + SLang_free_array (at); + return; + } + } + + (void) SLang_push_array (at, 1); + } + + + + In this example, only the diagonal elements of the array were set. + This is bacause when the array was created, all its elements were set + to zero. + + Now consider an example that acts upon an existing array. In + particular, consider one that computes the trace of a 2-d matrix, + i.e., the sum of the diagonal elements: + + + double compute_trace (void) + { + SLang_Array_Type *at; + double trace; + int dims[2]; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE)) + return 0.0; + + /* We want a 2-d square matrix. If the matrix is 1-d and has only one + element, then return that element. */ + trace = 0.0; + if (((at->num_dims == 1) && (at->dims[0] == 1)) + || ((at->num_dims == 2) && (at->dims[0] == at->dims[1]))) + { + double dtrace; + int n = at->dims[0]; + + for (i = 0; i < n; i++) + { + dims[0] = dims[1] = i; + (void) SLang_get_array_element (at, &dims, &dtrace); + trace += dtrace; + } + } + else SLang_verror (SL_TYPE_MISMATCH, "Expecting a square matrix"); + + SLang_free_array (at); + return trace; + } + + + + In this example, SLang_pop_array_of_type was used to pop an array of + doubles from the stack. This function will make implicit typecasts in + order to return an array of the requested type. + + + + 3.5.2. Structures + + + + For the purposes of this section, we shall differentiate structures + according to whether or not they correspond to an application defined + C structure. Those that do are called intrinsic structures, and those + do not are called S-Lang interpreter structures. + + + 3.5.2.1. Interpreter Structures + + + The following simple example shows one method that may be used to + create and return a structure with a string and integer field to the + interpreter's stack: + + int push_struct_example (char *string_value, int int_value) + { + char *field_names[2]; + unsigned char field_types[2]; + VOID_STAR field_values[2]; + + field_names[0] = "string_field"; + field_types[0] = SLANG_STRING_TYPE; + field_values[0] = &string_value; + + field_names[1] = "int_field"; + field_types[1] = SLANG_INT_TYPE; + field_values[1] = &int_value; + + if (-1 == SLstruct_create_struct (2, field_names, + field_types, field_values)) + return -1; + return 0; + } + + + + Here, SLstruct_create_struct is used to push a structure with the + specified field names and values onto the interpreter's stack. + + A simpler mechanism exists provided that one has already defined a C + structure with a description of how the structure is laid out. For + example, consider a C structure defined by + + + typedef struct + { + char *s; + int i; + } + SI_Type; + + + + Its layout may be specified via a table of SLang_CStruct_Field_Type + entries: + + + SLang_CStruct_Field_Type SI_Type_Layout [] = + { + MAKE_CSTRUCT_FIELD(SI_Type, s, "string_field", SLANG_STRING_TYPE, 0), + MAKE_CSTRUCT_FIELD(SI_Type, i, "int_field", SLANG_INT_TYPE, 0), + SLANG_END_CSTRUCT_TABLE + }; + + + + Here, MAKE_CSTRUCT_FIELD is a macro taking 5 arguments: + + + MAKE_CSTRUCT_FIELD(C-structure-type, + C-field-name, + slang-field-name, + slang-data-type, + is-read-only) + + + + The first argument is the structure type, the second is the name of a + field of the structure, the third is a string that specifies the name + of the corresponding field of the S-Lang structure, the fourth argu- + ment specifies the field's type, and the last argument specifies + whether or not the field should be regarded as read-only. + + Once the layout of the structure has been specified, pushing a S-Lang + version of the structure is trival: + + + int push_struct_example (char *string_value, int int_value) + { + SI_Type si; + + si.s = string_value; + si.i = int_value; + return SLang_push_cstruct ((VOID_STAR)&si, SI_Type_Layout); + } + + + + This mechanism of structure creation also permits a S-Lang structure + to be passed to an intrinsic function through the use of the + SLang_pop_cstruct routine, e.g., + + + void print_si_struct (void) + { + SI_Type si; + if (-1 == SLang_pop_cstruct ((VOID_STAR)&si, SI_Type_Layout)) + return; + printf ("si.i=%d", si.i); + printf ("si.s=%s", si.s); + SLang_free_cstruct ((VOID_STAR)&si, SI_Type_Layout); + } + + + + Assuming print_si_struct exists as an intrinsic function, the S-Lang + code + + + variable s = struct {string_field, int_field}; + s.string_field = "hello"; + s.int_field = 20; + print_si_struct (s); + + + + would result in the display of + + + si.i=20; + si.s=hello + + + + Note that the SLang_free_cstruct function was called after the con- + tents of si were nolonger needed. This was necessary because + SLang_pop_cstruct allocated memory to set the char *s field of si. + Calling SLang_free_cstruct frees up such memory. + + Now consider the following: + + + typedef struct + { + pid_t pid; + gid_t group; + } + X_t; + + + + How should the layout of this structure be defined? One might be + tempted to use: + + + SLang_CStruct_Field_Type X_t_Layout [] = + { + MAKE_CSTRUCT_FIELD(X_t, pid, "pid", SLANG_INT_TYPE, 0), + MAKE_CSTRUCT_FIELD(X_t, group, "group", SLANG_INT_TYPE, 0), + SLANG_END_CSTRUCT_TABLE + }; + + + + However, this assumes pid_t and gid_t have been typedefed as ints. + But what if gid_t is a short? In such a case, using + + + MAKE_CSTRUCT_FIELD(X_t, group, "group", SLANG_SHORT_TYPE, 0), + + + + would be the appropriate entry for the group field. Of course, one + has no way of knowing how gid_t is declared on other systems. For + this reason, it is preferable to use the MAKE_CSTRUCT_INT_FIELD macro + in cases involving integer valued fields, e.g., + + + SLang_CStruct_Field_Type X_t_Layout [] = + { + MAKE_CSTRUCT_INT_FIELD(X_t, pid, "pid", 0), + MAKE_CSTRUCT_INT_FIELD(X_t, group, "group", 0), + SLANG_END_CSTRUCT_TABLE + }; + + + + Before leaving this section, it is important to mention that access to + character array fields is not permitted via this interface. That is, + a structure such as + + + typedef struct + { + char name[32]; + } + Name_Type; + + + + is not supported since char name[32] is not a SLANG_STRING_TYPE + object. Always keep in mind that a SLANG_STRING_TYPE object is a char + *. + + + 3.5.2.2. Intrinsic Structures + + + Here we show how to make intrinsic structures available to the + interpreter. + + The simplest interface is to structure pointers and not to the actual + structures themselves. The latter would require the interpreter to be + involved with the creation and destruction of the structures. Dealing + with the pointers themselves is far simpler. + + As an example, consider an object such as + + + typedef struct _Window_Type + { + char *title; + int row; + int col; + int width; + int height; + } Window_Type; + + + + which defines a window object with a title, size (width, height), and + location (row, col). + + We can make variables of type Window_Type available to the interpreter + via a table as follows: + + + static SLang_IStruct_Field_Type Window_Type_Field_Table [] = + { + MAKE_ISTRUCT_FIELD(Window_Type, title, "title", SLANG_STRING_TYPE, 1), + MAKE_ISTRUCT_FIELD(Window_Type, row, "row", SLANG_INT_TYPE, 0), + MAKE_ISTRUCT_FIELD(Window_Type, col, "col", SLANG_INT_TYPE, 0), + MAKE_ISTRUCT_FIELD(Window_Type, width, "width", SLANG_INT_TYPE, 0), + MAKE_ISTRUCT_FIELD(Window_Type, height, "height", SLANG_INT_TYPE, 0), + SLANG_END_ISTRUCT_TABLE + }; + + + + More precisely, this defines the layout of the Window_Type structure. + Here, the title has been declared as a read-only field. Using + + + MAKE_ISTRUCT_FIELD(Window_Type, title, "title", SLANG_STRING_TYPE, 0), + + + + would allow read-write access. + + Now suppose that My_Window is a pointer to a Window_Type object, i.e., + + + + Window_Type *My_Window; + + + + We can make this variable available to the interpreter via the + SLadd_istruct_table function: + + + if (-1 == SLadd_istruct_table (Window_Type_Field_Table, + (VOID_STAR) &My_Window, + "My_Win")) + exit (1); + + + + This creates a S-Lang interpreter variable called My_Win whose value + corresponds to the My_Win structure. This would permit one to access + the fields of My_Window via S-Lang statements such as + + + define set_width_and_height (w,h) + { + My_Win.width = w; + My_Win.height = h; + } + + + + It is extremely important to understand that the interface described + in this section does not allow the interpreter to create new instances + of Window_Type objects. The interface merely defines an association + or correspondence between an intrinsic structure pointer and a S-Lang + variable. For example, if the value of My_Window is NULL, then My_Win + would also be NULL. + + One should be careful in allowing read/write access to character + string fields. If read/write access is allowed, then the application + should always use the SLang_create_slstring and SLang_free_slstring + functions to set the character string field of the structure. + + + + 4. Keyboard Interface + + + + S-Lang's keyboard interface has been designed to allow an application + to read keyboard input from the user in a system-independent manner. + The interface consists of a set of low routines for reading single + character data as well as a higher level interface (SLkp) which + utilize S-Lang's keymap facility for reading multi-character + sequences. + + To initialize the interface, one must first call the function + SLang_init_tty. Before exiting the program, the function + SLang_reset_tty must be called to restore the keyboard interface to + its original state. Once initialized, the low-level SLang_getkey + function may be used to read simgle keyboard characters from the + terminal. An application using the higher-level SLkp interface will + read charcters using the SLkp_getkey function. + + In addition to these basic functions, there are also functions to + ``unget'' keyboard characters, flush the input, detect pending-input + with a timeout, etc. These functions are defined below. + + + + 4.1. Initializing the Keyboard Interface + + + + The function SLang_init_tty must be called to initialize the terminal + for single character input. This puts the terminal in a mode usually + referred to as ``raw'' mode. + + The prototype for the function is: + + + int SLang_init_tty (int abort_char, int flow_ctrl, int opost); + + + + It takes three parameters that are used to specify how the terminal is + to be initialized. + + The first parameter, abort_char, is used to specify the interrupt + character (SIGINT). Under MSDOS, this value corresponds to the scan + code of the character that will be used to generate the interrupt. + For example, under MSDOS, 34 should be used to make Ctrl-G generate an + interrupt signal since 34 is the scan code for G. On other systems, + the value of abort_char will simply be the ascii value of the control + character that will be used to generate the interrupt signal, e.g., 7 + for Ctrl-G. If -1 is passed, the interrupt character will not be + changed. + + Pressing the interrupt character specified by the first argument will + generate a signal (SIGINT) that may or not be caught by the + application. It is up to the application to catch this signal. S- + Lang provides the function Slang_set_abort_signal to make it easy to + facilitate this task. + + The second parameter is used to specify whether or not flow control + should be used. If this parameter is zero, flow control is enabled + otherwise it is disabled. Disabling flow control is necessary to pass + certain characters to the application (e.g., Ctrl-S and Ctrl-Q). For + some systems such as MSDOS, this parameter is meaningless. + + The third parameter, opost, is used to turn output processing on or + off. If opost is zero, output processing is not turned on otherwise, + output processing is turned on. + + The SLang_init_tty function returns -1 upon failure. In addition, + after it returns, the S-Lang global variable SLang_TT_Baud_Rate will + be set to the baud rate of the terminal if this value can be + determined. + + Example: + + + if (-1 == SLang_init_tty (7, 0, 0)) /* For MSDOS, use 34 as scan code */ + { + fprintf (stderr, "Unable to initialize the terminal.\n"); + exit (1); + } + SLang_set_abort_signal (NULL); + + + + Here the terminal is initialized such that flow control and output + processing are turned off. In addition, the character Ctrl-G (-- For + MSDOS systems, use the scan code 34 instead of 7 for Ctrl-G--) has + been specified to be the interrupt character. The function + SLang_set_abort_signal is used to install the default S-Lang interrupt + signal handler. + + + + 4.2. Resetting the Keyboard Interface + + + + The function SLang_reset_tty must be called to reset the terminal to + the state it was in before the call to SLang_init_tty. The prototype + for this function is: + + + void SLang_reset_tty (void); + + + + Usually this function is only called before the program exits. How- + ever, if the program is suspended it should also be called just before + suspension. + + + + 4.3. Initializing the SLkp Routines + + + + Extra initialization of the higher-level SLkp functions are required + because they are layered on top of the lower level routines. Since + the SLkp_getkey function is able to process function and arrow keys in + a terminal independent manner, it is necessary to call the + SLtt_get_terminfo function to get information about the escape + character sequences that the terminal's function keys send. Once that + information is available, the SLkp_init function can construct the + proper keymaps to process the escape sequences. + + This part of the initialization process for an application using this + interface will look something like: + + + + SLtt_get_terminfo (); + if (-1 == SLkp_init ()) + { + SLang_doerror ("SLkp_init failed."); + exit (1); + } + if (-1 == SLang_init_tty (-1, 0, 1)) + { + SLang_doerror ("SLang_init_tty failed."); + exit (1); + } + + + + It is important to check the return status of the SLkp_init function + which can failed if it cannot allocate enough memory for the keymap. + + + + 4.4. Setting the Interrupt Handler + + + + The function SLang_set_abort_signal may be used to associate an + interrupt handler with the interrupt character that was previously + specified by the SLang_init_tty function call. The prototype for this + function is: + + + void SLang_set_abort_signal (void (*)(int)); + + + + This function returns nothing and takes a single parameter which is a + pointer to a function taking an integer value and returning void. If + a NULL pointer is passed, the default S-Lang interrupt handler will be + used. The S-Lang default interrupt handler under Unix looks like: + + + static void default_sigint (int sig) + { + SLsignal_intr (SIGINT, default_sigint); + SLKeyBoard_Quit = 1; + if (SLang_Ignore_User_Abort == 0) SLang_Error = USER_BREAK; + } + + + + It simply sets the global variable SLKeyBoard_Quit to one and if the + variable SLang_Ignore_User_Abort is non-zero, SLang_Error is set to + indicate a user break condition. (The function SLsignal_intr is simi- + lar to the standard C signal function except that it will interrupt + system calls. Some may not like this behavior and may wish to call + this SLang_set_abort_signal with a different handler.) + Although the function expressed above is specific to Unix, the + analogous routines for other operating systems are equivalent in + functionality even though the details of the implementation may vary + drastically (e.g., under MSDOS, the hardware keyboard interrupt int 9h + is hooked). + + + + 4.5. Reading Keyboard Input with SLang_getkey + + + + After initializing the keyboard via SLang_init_tty, the S-Lang + function SLang_getkey may be used to read characters from the terminal + interface. In addition, the function SLang_input_pending may be used + to determine whether or not keyboard input is available to be read. + + These functions have prototypes: + + + unsigned int SLang_getkey (void); + int SLang_input_pending (int tsecs); + + + + The SLang_getkey function returns a single character from the termi- + nal. Upon failure, it returns 0xFFFF. If the interrupt character + specified by the SLang_init_tty function is pressed while this func- + tion is called, the function will return the value of the interrupt + character and set the S-Lang global variable SLKeyBoard_Quit to a non- + zero value. In addition, if the default S-Lang interrupt handler has + been specified by a NULL argument to the SLang_set_abort_signal func- + tion, the global variable SLang_Error will be set to USER_BREAK unless + the variable SLang_Ignore_User_Abort is non-zero. + + The SLang_getkey function waits until input is available to be read. + The SLang_input_pending function may be used to determine whether or + not input is ready. It takes a single parameter that indicates the + amount of time to wait for input before returning with information + regarding the availability of input. This parameter has units of one + tenth (1/10) of a second, i.e., to wait one second, the value of the + parameter should be 10. Passing a value of zero causes the function + to return right away. SLang_input_pending returns a positive integer + if input is available or zero if input is not available. It will + return -1 if an error occurs. + + Here is a simple example that reads keys from the terminal until one + presses Ctrl-G or until 5 seconds have gone by with no input: + + + + #include + #include "slang.h" + int main () + { + int abort_char = 7; /* For MSDOS, use 34 as scan code */ + unsigned int ch; + + if (-1 == SLang_init_tty (abort_char, 0, 1)) + { + fprintf (stderr, "Unable to initialize the terminal.\n"); + exit (-1); + } + SLang_set_abort_signal (NULL); + while (1) + { + fputs ("\nPress any key. To quit, press Ctrl-G: ", stdout); + fflush (stdout); + if (SLang_input_pending (50) == 0) /* 50/10 seconds */ + { + fputs ("Waited too long! Bye\n", stdout); + break; + } + + ch = SLang_getkey (); + if (SLang_Error == USER_BREAK) + { + fputs ("Ctrl-G pressed! Bye\n", stdout); + break; + } + putc ((int) ch, stdout); + } + SLang_reset_tty (); + return 0; + } + + + + 4.6. Reading Keyboard Input with SLkp_getkey + + + + Unlike the low-level function SLang_getkey, the SLkp_getkey function + can read a multi-character sequence associated with function keys. + The SLkp_getkey function uses SLang_getkey and S-Lang's keymap + facility to process escape sequences. It returns a single integer + which describes the key that was pressed: + + + int SLkp_getkey (void); + + + + That is, the SLkp_getkey function simple provides a mapping between + keys and integers. In this context the integers are called keysyms. + + For single character input such as generated by the a key on the + keyboard, the function returns the character that was generated, e.g., + 'a'. For single characters, SLkp_getkey will always return an keysym + whose value ranges from 0 to 256. For keys that generate multiple + character sequences, e.g., a function or arrow key, the function + returns an keysym whose value is greater that 256. The actual values + of these keysyms are represented as macros defined in the slang.h + include file. For example, the up arrow key corresponds to the keysym + whose value is SL_KEY_UP. + + Since it is possible for the user to enter a character sequence that + does not correspond to any key. If this happens, the special keysym + SL_KEY_ERR will be returned. + + Here is an example of how SLkp_getkey may be used by a file viewer: + + + switch (SLkp_getkey ()) + { + case ' ': + case SL_KEY_NPAGE: + next_page (); + break; + case 'b': + case SL_KEY_PPAGE: + previous_page (); + break; + case '\r': + case SL_KEY_DOWN: + next_line (); + break; + . + . + case SL_KEY_ERR: + default: + SLtt_beep (); + } + + + + Unlike its lower-level counterpart, SLang_getkey, there do not yet + exist any functions in the library that are capable of ``ungetting'' + keysyms. In particular, the SLang_ungetkey function will not work. + + + + 4.7. Buffering Input + + + + S-Lang has several functions pushing characters back onto the input + stream to be read again later by SLang_getkey. It should be noted + that none of the above functions are designed to push back keysyms + read by the SLkp_getkey function. These functions are declared as + follows: + + + void SLang_ungetkey (unsigned char ch); + void SLang_ungetkey_string (unsigned char *buf, int buflen); + void SLang_buffer_keystring (unsigned char *buf, int buflen); + + + + SLang_ungetkey is the most simple of the three functions. It takes a + single character a pushes it back on to the input stream. The next + call to SLang_getkey will return this character. This function may be + used to peek at the character to be read by first reading it and then + putting it back. + SLang_ungetkey_string has the same function as SLang_ungetkey except + that it is able to push more than one character back onto the input + stream. Since this function can push back null (ascii 0) characters, + the number of characters to push is required as one of the parameters. + + The last of these three functions, SLang_buffer_keystring can handle + more than one charater but unlike the other two, it places the + characters at the end of the keyboard buffer instead of at the + beginning. + + Note that the use of each of these three functions will cause + SLang_input_pending to return right away with a non-zero value. + + Finally, the S-Lang keyboard interface includes the function + SLang_flush_input with prototype + + + void SLang_flush_input (void); + + + + It may be used to discard all input. + + Here is a simple example that looks to see what the next key to be + read is if one is available: + + + int peek_key () + { + int ch; + if (SLang_input_pending (0) == 0) return -1; + ch = SLang_getkey (); + SLang_ungetkey (ch); + return ch; + } + + + + 4.8. Global Variables + + + Although the following S-Lang global variables have already been + mentioned earlier, they are gathered together here for completeness. + + int SLang_Ignore_User_Abort; If non-zero, pressing the interrupt + character will not result in SLang_Error being set to USER_BREAK. + + volatile int SLKeyBoard_Quit; This variable is set to a non-zero value + when the interrupt character is pressed. If the interrupt character is + pressed when SLang_getkey is called, the interrupt character will be + returned from SLang_getkey. + + int SLang_TT_Baud_Rate; On systems which support it, this variable is + set to the value of the terminal's baud rate after the call to + SLang_init_tty. + + + + 5. Screen Management + + + + The S-Lang library provides two interfaces to terminal independent + routines for manipulating the display on a terminal. The highest + level interface, known as the SLsmg interface is discussed in this + section. It provides high level screen management functions more + manipulating the display in an optimal manner and is similar in spirit + to the curses library. The lowest level interface, or the SLtt + interface, is used by the SLsmg routines to actually perform the task + of writing to the display. This interface is discussed in another + section. Like the keyboard routines, the SLsmg routines are platform + independent and work the same on MSDOS, OS/2, Unix, and VMS. + + The screen management, or SLsmg, routines are initialized by function + SLsmg_init_smg. Once initialized, the application uses various SLsmg + functions to write to a virtual display. This does not cause the + physical terminal display to be updated immediately. The physical + display is updated to look like the virtual display only after a call + to the function SLsmg_refresh. Before exiting, the application using + these routines is required to call SLsmg_reset_smg to reset the + display system. + + The following subsections explore S-Lang's screen management system in + greater detail. + + + 5.1. Initialization + + + The function SLsmg_init_smg must be called before any other SLsmg + function can be used. It has the simple prototype: + + + int SLsmg_init_smg (void); + + + + It returns zero if successful or -1 if it cannot allocate space for + the virtual display. + + For this routine to properly initialize the virtual display, the + capabilities of the terminal must be known as well as the size of the + physical display. For these reasons, the lower level SLtt routines + come into play. In particular, before the first call to + SLsmg_init_smg, the application is required to call the function + SLtt_get_terminfo before calling SLsmg_init_smg. + + The SLtt_get_terminfo function sets the global variables + SLtt_Screen_Rows and SLtt_Screen_Cols to the values appropriate for + the terminal. It does this by calling the SLtt_get_screen_size + function to query the terminal driver for the appropriate values for + these variables. From this point on, it is up to the application to + maintain the correct values for these variables by calling the + SLtt_get_screen_size function whenever the display size changes, e.g., + in response to a SIGWINCH signal. Finally, if the application is going + to read characters from the keyboard, it is also a good idea to + initialize the keyboard routines at this point as well. + + + 5.2. Resetting SLsmg + + + + Before the program exits or suspends, the function SLsmg_reset_tty + should be called to shutdown the display system. This function has + the prototype + + + void SLsmg_reset_smg (void); + + + + This will deallocate any memory allocated for the virtual screen and + reset the terminal's display. + + Basically, a program that uses the SLsmg screen management functions + and S-Lang's keyboard interface will look something like: + + + #include "slang.h" + int main () + { + SLtt_get_terminfo (); + SLang_init_tty (-1, 0, 0); + SLsmg_init_smg (); + + /* do stuff .... */ + + SLsmg_reset_smg (); + SLang_reset_tty (); + return 0; + } + + + + If this program is compiled and run, all it will do is clear the + screen and position the cursor at the bottom of the display. In the + following sections, other SLsmg functions will be introduced which may + be used to make this simple program do much more. + + + 5.3. Handling Screen Resize Events + + The function SLsmg_reinit_smg is designed to be used in conjunction + with resize events. + + Under Unix-like operating systems, when the size of the display + changes, the application will be sent a SIGWINCH signal. To properly + handle this signal, the SLsmg routines must be reinitialized to use + the new display size. This may be accomplished by calling + SLtt_get_screen_size to get the new size, followed by SLsmg_reinit_smg + to reinitialize the SLsmg interface to use the new size. Keep in mind + that these routines should not be called from within the signal + handler. The following code illustrates the main ideas involved in + handling such events: + + + + static volatile int Screen_Size_Changed; + static sigwinch_handler (int sig) + { + Screen_Size_Changed = 1; + SLsignal (SIGWINCH, sigwinch_handler); + } + + int main (int argc, char **argv) + { + SLsignal (SIGWINCH, sigwinch_handler); + SLsmg_init_smg (); + . + . + /* Now enter main loop */ + while (not_done) + { + if (Screen_Size_Changed) + { + SLtt_get_screen_size (); + SLsmg_reinit_smg (); + redraw_display (); + } + . + . + } + return 0; + } + + + + 5.4. SLsmg Functions + + + + In the previous sections, functions for initializing and shutting down + the SLsmg routines were discussed. In this section, the rest of the + SLsmg functions are presented. These functions act only on the + virtual display. The physical display is updated when the + SLsmg_refresh function is called and not until that time. This + function has the simple prototype: + + + void SLsmg_refresh (void); + + + + 5.4.1. Positioning the cursor + + + The SLsmg_gotorc function is used to position the cursor at a given + row and column. The prototype for this function is: + + + void SLsmg_gotorc (int row, int col); + + + + The origin of the screen is at the top left corner and is given the + coordinate (0, 0), i.e., the top row of the screen corresponds to row + = 0 and the first column corresponds to col = 0. The last row of the + screen is given by row = SLtt_Screen_Rows - 1. + + It is possible to change the origin of the coordinate system by using + the function SLsmg_set_screen_start with prototype: + + + void SLsmg_set_screen_start (int *r, int *c); + + + + This function takes pointers to the new values of the first row and + first column. It returns the previous values by modifying the values + of the integers at the addresses specified by the parameter list. A + NULL pointer may be passed to indicate that the origin is to be set to + its initial value of 0. For example, + + + int r = 10; + SLsmg_set_screen_start (&r, NULL); + + + + sets the origin to (10, 0) and after the function returns, the vari- + able r will have the value of the previous row origin. + + + 5.4.2. Writing to the Display + + + SLsmg has several routines for outputting text to the virtual display. + The following points should be understood: + + o The text is output at the position of the cursor of the virtual + display and the cursor is advanced to the position that corresponds + to the end of the text. + + + o Text does not wrap at the boundary of the display--- it is + trucated. This behavior seems to be more useful in practice since + most programs that would use screen management tend to be line + oriented. + + + o Control characters are displayed in a two character sequence + representation with ^ as the first character. That is, Ctrl-X is + output as ^X. + + + o The newline character does not cause the cursor to advance to the + next row. Instead, when a newline character is encountered when + outputting text, the output routine will return. That is, + outputting a string containing a newline character will only + display the contents of the string up to the newline character. + + + Although the some of the above items might appear to be too + restrictive, in practice this is not seem to be the case. In fact, + the design of the output routines was influenced by their actual use + and modified to simplify the code of the application utilizing them. + + void SLsmg_write_char (char ch); Write a single character to the + virtual display. + + + void SLsmg_write_nchars (char *str, int len); Write len characters + pointed to by str to the virtual display. + + void SLsmg_write_string (char *str); Write the null terminated string + given by pointer str to the virtual display. This function is a + wrapper around SLsmg_write_nchars. + + void SLsmg_write_nstring (char *str, int n); Write the null terminated + string given by pointer str to the virtual display. At most, only n + characters are written. If the length of the string is less than n, + then the string will be padded with blanks. This function is a + wrapper around SLsmg_write_nchars. + + void SLsmg_printf (char *fmt, ...); This function is similar to printf + except that it writes to the SLsmg virtual display. + + void SLsmg_vprintf (char *, va_list); Like SLsmg_printf but uses a + variable argument list. + + + 5.4.3. Erasing the Display + + + The following functions may be used to fill portions of the display + with blank characters. The attributes of blank character are the + current attributes. (See below for a discussion of character + attributes) + + void SLsmg_erase_eol (void); Erase line from current position to the + end of the line. + + void SLsmg_erase_eos (void); Erase from the current position to the + end of the screen. + + void SLsmg_cls (void); Clear the entire virtual display. + + + 5.4.4. Setting Character Attributes + + + Character attributes define the visual characteristics the character + possesses when it is displayed. Visual characteristics include the + foreground and background colors as well as other attributes such as + blinking, bold, and so on. Since SLsmg takes a different approach to + this problem than other screen management libraries an explanation of + this approach is given here. This approach has been motivated by + experience with programs that require some sort of screen management. + + Most programs that use SLsmg are composed of specific textual objects + or objects made up of line drawing characters. For example, consider + an application with a menu bar with drop down menus. The menus might + be enclosed by some sort of frame or perhaps a shadow. The basic idea + is to associate an integer to each of the objects (e.g., menu bar, + shadow, current menu item, etc.) and create a mapping from the integer + to the set of attributes. In the terminology of SLsmg, the integer is + simply called an object. + + For example, the menu bar might be associated with the object 1, the + drop down menu could be object 2, the shadow could be object 3, and so + on. + + The range of values for the object integer is restricted from 0 up to + and including 255 on all systems except MSDOS where the maximum + allowed integer is 15 (-- This difference is due to memory constraints + imposed by MSDOS. This restriction might be removed in a future + version of the library.--) . The object numbered zero should not be + regarding as an object at all. Rather it should be regarded as all + other objects that have not explicitly been given an object number. + SLsmg, or more precisely SLtt, refers to the attributes of this + special object as the default or normal attributes. + + The SLsmg routines know nothing about the mapping of the color to the + attributes associated with the color. The actual mapping takes place + at a lower level in the SLtt routines. Hence, to map an object to the + actual set of attributes requires a call to any of the following SLtt + routines: + + + void SLtt_set_color (int obj, char *name, char *fg, char *bg); + void SLtt_set_color_object (int obj, SLtt_Char_Type attr); + void SLtt_set_mono (int obj, char *, SLtt_Char_Type attr); + + + + Only the first of these routines will be discussed briefly here. The + latter two functions allow more fine control over the object to + attribute mapping (such as assigning a ``blink'' attribute to the + object). For a more full explanation on all of these routines see the + section about the SLtt interface. + + The SLtt_set_color function takes four parameters. The first + parameter, obj, is simply the integer of the object for which + attributes are to be assigned. The second parameter is currently + unused by these routines. The third and forth parameters, fg and bg, + are the names of the foreground and background color to be used + associated with the object. The strings that one can use for the + third and fourth parameters can be any one of the 16 colors: + + + "black" "gray" + "red" "brightred" + "green" "brightgreen" + "brown" "yellow" + "blue" "brightblue" + "magenta" "brightmagenta" + "cyan" "brightcyan" + "lightgray" "white" + + + + The value of the foreground parameter fg can be anyone of these six- + teen colors. However, on most terminals, the background color will + can only be one of the colors listed in the first column (-- This is + also true on the Linux console. However, it need not be the case and + hopefully the designers of Linux will someday remove this restric- + tion.--) . + + Of course not all terminals are color terminals. If the S-Lang global + variable SLtt_Use_Ansi_Colors is non-zero, the terminal is assumed to + be a color terminal. The SLtt_get_terminfo will try to determine + whether or not the terminal supports colors and set this variable + accordingly. It does this by looking for the capability in the + terminfo/termcap database. Unfortunately many Unix databases lack + this information and so the SLtt_get_terminfo routine will check + whether or not the environment variable COLORTERM exists. If it + exists, the terminal will be assumed to support ANSI colors and + SLtt_Use_Ansi_Colors will be set to one. Nevertheless, the + application should provide some other mechanism to set this variable, + e.g., via a command line parameter. + + When the SLtt_Use_Ansi_Colors variable is zero, all objects with + numbers greater than one will be displayed in inverse video (-- This + behavior can be modified by using the SLtt_set_mono function call.--) + . + + With this background, the SLsmg functions for setting the character + attributes can now be defined. These functions simply set the object + attributes that are to be assigned to subsequent characters written to + the virtual display. For this reason, the new attribute is called the + current attribute. + + void SLsmg_set_color (int obj); Set the current attribute to those of + object obj. + + void SLsmg_normal_video (void); This function is equivalent to + SLsmg_set_color (0). + + void SLsmg_reverse_video (void); This function is equivalent to + SLsmg_set_color (1). On monochrome terminals, it is equivalent to + setting the subsequent character attributes to inverse video. + + Unfortunately there does not seem to be a standard way for the + application or, in particular, the library to determine which color + will be used by the terminal for the default background. Such + information would be useful in initializing the foreground and + background colors associated with the default color object (0). FOr + this reason, it is up to the application to provide some means for the + user to indicate what these colors are for the particular terminal + setup. To facilitate this, the SLtt_get_terminfo function checks for + the existence of the COLORFGBG environment variable. If this variable + exists, its value will be used to initialize the colors associated + with the default color object. Specifically, the value is assumed to + consist of a foreground color name and a background color name + separated by a semicolon. For example, if the value of COLORTERM is + lightgray;blue, the default color object will be initialized to + represent a lightgray foreground upon a blue background. + + + 5.4.5. Lines and Alternate Character Sets + + The S-Lang screen management library also includes routines for + turning on and turning off alternate character sets. This is + especially useful for drawing horizontal and vertical lines. + + void SLsmg_set_char_set (int flag); If flag is non-zero, subsequent + write functions will use characters from the alternate character set. + If flag is zero, the default, or, ordinary character set will be used. + + void SLsmg_draw_hline (int len); Draw a horizontal line from the + current position to the column that is len characters to the right. + + void SLsmg_draw_vline (int len); Draw a horizontal line from the + current position to the row that is len rows below. + + void SLsmg_draw_box (int r, int c, int dr, int dc); Draw a box whose + upper right corner is at row r and column c. The box spans dr rows + and dc columns. The current position will be left at row r and column + c. + + + 5.4.6. Miscellaneous Functions + + + void SLsmg_touch_lines (int r, int n); Mark screen rows numbered r, r + + 1, ... r + (n - 1) as modified. When SLsmg_refresh is called, these + rows will be completely redrawn. + unsigned short SLsmg_char_at(void); Returns the character and its + attributes object number at the current cursor position. The + character itself occupies the lower byte and the object attributes + number forms the upper byte. The object returned by this function + call should not be written back out via any of the functions that + write characters or character strings. + + + + 5.5. Variables + + + + The following S-Lang global variables are used by the SLsmg interface. + Some of these have been previously discussed. + + int SLtt_Screen_Rows; int SLtt_Screen_Cols; The number of rows and + columns of the physical display. If either of these numbers changes, + the functions SLsmg_reset_smg and SLsmg_init_smg should be called + again so that the SLsmg routines can re-adjust to the new size. + + int SLsmg_Tab_Width; Set this variable to the tab width that will be + used when expanding tab characters. The default is 8. + + int SLsmg_Display_Eight_Bit This variable determines how characters + with the high bit set are to be output. Specifically, a character + with the high bit set with a value greater than or equal to this value + is output as is; otherwise, it will be output in a 7-bit + representation. The default value for this variable is 128 for MSDOS + and 160 for other systems (ISO-Latin). + + int SLtt_Use_Ansi_Colors; If this value is non-zero, the terminal is + assumed to support ANSI colors otherwise it is assumed to be + monochrome. The default is 0. + + int SLtt_Term_Cannot_Scroll; If this value is zero, the SLsmg will + attempt to scroll the physical display to optimize the update. If it + is non-zero, the screen management routines will not perform this + optimization. For some applications, this variable should be set to + zero. The default value is set by the SLtt_get_terminfo function. + + + + 5.6. Hints for using SLsmg + + + This section discusses some general design issues that one must face + when writing an application that requires some sort of screen + management. + + + + 6. Signal Functions + + + + Almost all non-trivial programs must worry about signals. This is + especially true for programs that use the S-Lang terminal input/output + and screen management routines. Unfortunately, there is no fixed way + to handle signals; otherwise, the Unix kernel would take care of all + issues regarding signals and the application programmer would never + have to worry about them. For this reason, none of the routines in + the S-Lang library catch signals; however, some of the routines block + the delivery of signals during crucial moments. It is up to the + application programmer to install handlers for the various signals of + interest. + + For the interpreter, the most important signal to worry about is + SIGINT. This signal is usually generated when the user presses Ctrl-C + at the keyboard. The interpreter checks the value of the SLang_Error + variable to determine whether or not it should abort the interpreting + process and return control back to the application. This means that + if SIGINT is to be used to abort the interpreter, a signal handler for + SIGINT should be installed. The handler should set the value of + SLang_Error to SL_USER_BREAK. + + Applications that use the tty getkey routines or the screen management + routines must worry about signals such as: + + + SIGINT interrupt + SIGTSTP stop + SIGQUIT quit + SIGTTOU background write + SIGTTIN background read + SIGWINCH window resize + + + + It is important that handlers be established for these signals while + the either the SLsmg routines or the getkey routines are initialized. + The SLang_init_tty, SLang_reset_tty, SLsmg_init_smg, and + SLsmg_reset_smg functions block these signals from occuring while they + are being called. + + Since a signal can be delivered at any time, it is important for the + signal handler to call only functions that can be called from a signal + handler. This usually means that such function must be re-entrant. In + particular, the SLsmg routines are not re-entrant; hence, they should + not be called when a signal is being processed unless the application + can ensure that the signal was not delivered while an SLsmg function + was called. This statement applies to many other functions such as + malloc, or, more generally, any function that calls malloc. The + upshot is that the signal handler should not attempt to do too much + except set a global variable for the application to look at while not + in a signal handler. + + The S-Lang library provides two functions for blocking and unblocking + the above signals: + + + int SLsig_block_signals (void); + int SLsig_unblock_signals (void); + + + + It should be noted that for every call to SLsig_block_signals, a cor- + responding call should be made to SLsig_unblock_signals, e.g., + + + void update_screen () + { + SLsig_block_signals (); + + /* Call SLsmg functions */ + . + . + SLsig_unblock_signals (); + } + + + + See demo/pager.c for examples. + + + + 7. Searching Functions + + + + The S-Lang library incorporates two types of searches: Regular + expression pattern matching and ordinary searching. + + + 7.1. Regular Expressions + + + + !!! No documentation available yet !!! + + + + 7.2. Simple Searches + + + The routines for ordinary searching are defined in the slsearch.c + file. To use these routines, simply include "slang.h" in your program + and simply call the appropriate routines. + + The searches can go in either a forward or backward direction and can + either be case or case insensitive. The region that is searched may + contain null characters (ASCII 0) however, the search string cannot in + the current implementation. In addition the length of the string to + be found is currently limited to 256 characters. + + Before searching, the function SLsearch_init must first be called to + `preprocess' the search string. + + + + 7.3. Initialization + + + The function SLsearch_init must be called before a search can take + place. Its prototype is: + + + int SLsearch_init (char *key, int dir, int case_sens, SLsearch_Type *st); + + + + Here key is the string to be searched for. dir specifies the direc- + tion of the search: a value greater than zero is used for searching + forward and a value less than zero is used for searching backward. + The parameter case_sens specifies whether the search is case sensitive + or not. A non-zero value indicates that case is important. st is a + pointer to a structure of type SLsearch_Type defined in "slang.h". + This structure is initialized by this routine and must be passed to + SLsearch when the search is actually performed. + + This routine returns the length of the string to be searched for. + + + + 7.4. SLsearch + + + + Prototype: unsigned char *SLsearch (unsigned char *pmin, + unsigned char *pmax, + SLsearch_Type *st); + + + + This function performs the search defined by a previous call to + SLsearch_init over a region specified by the pointers pmin and pmax. + + It returns a pointer to the start of the match if successful or it + will return NULL if a match was not found. + + + + A. Copyright + + The S-Lang library is distributed under two copyrights: the GNU Genral + Public License, and the Artistic License. Any program that uses the + interpreter must adhere to rules of one of these licenses. + + + A.1. The GNU Public License + + + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + + + The licenses for most software are designed to take away your freedom + to share and change it. By contrast, the GNU General Public License + is intended to guarantee your freedom to share and change free soft- + ware--to make sure the software is free for all its users. This Gen- + eral Public License applies to most of the Free Software Foundation's + software and to any other program whose authors commit to using it. + (Some other Free Software Foundation software is covered by the GNU + Library General Public License instead.) You can apply it to your + programs, too. + + When we speak of free software, we are referring to freedom, not + price. Our General Public Licenses are designed to make sure that you + have the freedom to distribute copies of free software (and charge for + this service if you wish), that you receive source code or can get it + if you want it, that you can change the software or use pieces of it + in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid + anyone to deny you these rights or to ask you to surrender the rights. + These restrictions translate to certain responsibilities for you if + you distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether + gratis or for a fee, you must give the recipients all the rights that + you have. You must make sure that they, too, receive or can get the + source code. And you must show them these terms so they know their + rights. + + We protect your rights with two steps: (1) copyright the software, and + (2) offer you this license which gives you legal permission to copy, + distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain + that everyone understands that there is no warranty for this free + software. If the software is modified by someone else and passed on, + we want its recipients to know that what they have is not the + original, so that any problems introduced by others will not reflect + on the original authors' reputations. + + Finally, any free program is threatened constantly by software + patents. We wish to avoid the danger that redistributors of a free + program will individually obtain patent licenses, in effect making the + program proprietary. To prevent this, we have made it clear that any + patent must be licensed for everyone's free use or not licensed at + all. + + The precise terms and conditions for copying, distribution and + modification follow. + + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + + + 0. This License applies to any program or other work which contains a + notice placed by the copyright holder saying it may be distributed + under the terms of this General Public License. The "Program", below, + refers to any such program or work, and a "work based on the Program" + means either the Program or any derivative work under copyright law: + that is to say, a work containing the Program or a portion of it, + either verbatim or with modifications and/or translated into another + language. (Hereinafter, translation is included without limitation in + the term "modification".) Each licensee is addressed as "you". + + Activities other than copying, distribution and modification are not + covered by this License; they are outside its scope. The act of + running the Program is not restricted, and the output from the Program + is covered only if its contents constitute a work based on the Program + (independent of having been made by running the Program). Whether + that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's source + code as you receive it, in any medium, provided that you conspicuously + and appropriately publish on each copy an appropriate copyright notice + and disclaimer of warranty; keep intact all the notices that refer to + this License and to the absence of any warranty; and give any other + recipients of the Program a copy of this License along with the + Program. + + You may charge a fee for the physical act of transferring a copy, and + you may at your option offer warranty protection in exchange for a + fee. + + 2. You may modify your copy or copies of the Program or any portion of + it, thus forming a work based on the Program, and copy and distribute + such modifications or work under the terms of Section 1 above, + provided that you also meet all of these conditions: + + + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + + + + These requirements apply to the modified work as a whole. If identi- + fiable sections of that work are not derived from the Program, and can + be reasonably considered independent and separate works in themselves, + then this License, and its terms, do not apply to those sections when + you distribute them as separate works. But when you distribute the + same sections as part of a whole which is a work based on the Program, + the distribution of the whole must be on the terms of this License, + whose permissions for other licensees extend to the entire whole, and + thus to each and every part regardless of who wrote it. + + Thus, it is not the intent of this section to claim rights or contest + your rights to work written entirely by you; rather, the intent is to + exercise the right to control the distribution of derivative or + collective works based on the Program. + + In addition, mere aggregation of another work not based on the Program + with the Program (or with a work based on the Program) on a volume of + a storage or distribution medium does not bring the other work under + the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, + under Section 2) in object code or executable form under the terms of + Sections 1 and 2 above provided that you also do one of the following: + + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + + + + The source code for a work means the preferred form of the work for + making modifications to it. For an executable work, complete source + code means all the source code for all modules it contains, plus any + associated interface definition files, plus the scripts used to con- + trol compilation and installation of the executable. However, as a + special exception, the source code distributed need not include any- + thing that is normally distributed (in either source or binary form) + with the major components (compiler, kernel, and so on) of the operat- + ing system on which the executable runs, unless that component itself + accompanies the executable. + + If distribution of executable or object code is made by offering + access to copy from a designated place, then offering equivalent + access to copy the source code from the same place counts as + distribution of the source code, even though third parties are not + compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program + except as expressly provided under this License. Any attempt + otherwise to copy, modify, sublicense or distribute the Program is + void, and will automatically terminate your rights under this License. + However, parties who have received copies, or rights, from you under + this License will not have their licenses terminated so long as such + parties remain in full compliance. + + 5. You are not required to accept this License, since you have not + signed it. However, nothing else grants you permission to modify or + distribute the Program or its derivative works. These actions are + prohibited by law if you do not accept this License. Therefore, by + modifying or distributing the Program (or any work based on the + Program), you indicate your acceptance of this License to do so, and + all its terms and conditions for copying, distributing or modifying + the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the + Program), the recipient automatically receives a license from the + original licensor to copy, distribute or modify the Program subject to + these terms and conditions. You may not impose any further + restrictions on the recipients' exercise of the rights granted herein. + You are not responsible for enforcing compliance by third parties to + this License. + + 7. If, as a consequence of a court judgment or allegation of patent + infringement or for any other reason (not limited to patent issues), + conditions are imposed on you (whether by court order, agreement or + otherwise) that contradict the conditions of this License, they do not + excuse you from the conditions of this License. If you cannot + distribute so as to satisfy simultaneously your obligations under this + License and any other pertinent obligations, then as a consequence you + may not distribute the Program at all. For example, if a patent + license would not permit royalty-free redistribution of the Program by + all those who receive copies directly or indirectly through you, then + the only way you could satisfy both it and this License would be to + refrain entirely from distribution of the Program. + + If any portion of this section is held invalid or unenforceable under + any particular circumstance, the balance of the section is intended to + apply and the section as a whole is intended to apply in other + circumstances. + + It is not the purpose of this section to induce you to infringe any + patents or other property right claims or to contest validity of any + such claims; this section has the sole purpose of protecting the + integrity of the free software distribution system, which is + implemented by public license practices. Many people have made + generous contributions to the wide range of software distributed + through that system in reliance on consistent application of that + system; it is up to the author/donor to decide if he or she is willing + to distribute software through any other system and a licensee cannot + impose that choice. + + This section is intended to make thoroughly clear what is believed to + be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in + certain countries either by patents or by copyrighted interfaces, the + original copyright holder who places the Program under this License + may add an explicit geographical distribution limitation excluding + those countries, so that distribution is permitted only in or among + countries not thus excluded. In such case, this License incorporates + the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new + versions of the General Public License from time to time. Such new + versions will be similar in spirit to the present version, but may + differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the Program + specifies a version number of this License which applies to it and + "any later version", you have the option of following the terms and + conditions either of that version or of any later version published by + the Free Software Foundation. If the Program does not specify a + version number of this License, you may choose any version ever + published by the Free Software Foundation. + + 10. If you wish to incorporate parts of the Program into other free + programs whose distribution conditions are different, write to the + author to ask for permission. For software which is copyrighted by + the Free Software Foundation, write to the Free Software Foundation; + we sometimes make exceptions for this. Our decision will be guided by + the two goals of preserving the free status of all derivatives of our + free software and of promoting the sharing and reuse of software + generally. + + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY + FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN + OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES + PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED + OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS + TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE + PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, + REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING + WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR + REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, + INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING + OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED + TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY + YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER + PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE + POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest + possible use to the public, the best way to achieve this is to make it + free software which everyone can redistribute and change under these + terms. + + To do so, attach the following notices to the program. It is safest + to attach them to the start of each source file to most effectively + convey the exclusion of warranty; and each file should have at least + the "copyright" line and a pointer to where the full notice is found. + + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + + + Also add information on how to contact you by electronic and paper + mail. + + If the program is interactive, make it output a short notice like this + when it starts in an interactive mode: + + + Gnomovision version 69, Copyright (C) 19yy name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + + + + The hypothetical commands `show w' and `show c' should show the appro- + priate parts of the General Public License. Of course, the commands + you use may be called something other than `show w' and `show c'; they + could even be mouse-clicks or menu items--whatever suits your program. + + You should also get your employer (if you work as a programmer) or + your school, if any, to sign a "copyright disclaimer" for the program, + if necessary. Here is a sample; alter the names: + + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + + + + This General Public License does not permit incorporating your program + into proprietary programs. If your program is a subroutine library, + you may consider it more useful to permit linking proprietary applica- + tions with the library. If this is what you want to do, use the GNU + Library General Public License instead of this License. + + + A.2. The Artistic License + + + + The "Artistic License" + + Preamble + + + + The intent of this document is to state the conditions under which a + Package may be copied, such that the Copyright Holder maintains some + semblance of artistic control over the development of the package, + while giving the users of the package the right to use and distribute + the Package in a more-or-less customary fashion, plus the right to + make reasonable modifications. + + Definitions: + + + "Package" refers to the collection of files distributed by the + Copyright Holder, and derivatives of that collection of files + created through textual modification. + + "Standard Version" refers to such a Package if it has not been + modified, or has been modified in accordance with the wishes + of the Copyright Holder as specified below. + + "Copyright Holder" is whoever is named in the copyright or + copyrights for the package. + + "You" is you, if you're thinking about copying or distributing + this Package. + + "Reasonable copying fee" is whatever you can justify on the + basis of media cost, duplication charges, time of people involved, + and so on. (You will not be required to justify it to the + Copyright Holder, but only to the computing community at large + as a market that must bear the fee.) + + "Freely Available" means that no fee is charged for the item + itself, though there may be fees involved in handling the item. + It also means that recipients of the item may redistribute it + under the same conditions they received it. + + + + 1. You may make and give away verbatim copies of the source form of + the Standard Version of this Package without restriction, provided + that you duplicate all of the original copyright notices and associ- + ated disclaimers. + + 2. You may apply bug fixes, portability fixes and other modifications + derived from the Public Domain or from the Copyright Holder. A + Package modified in such a way shall still be considered the Standard + Version. + + 3. You may otherwise modify your copy of this Package in any way, + provided that you insert a prominent notice in each changed file + stating how and when you changed that file, and provided that you do + at least ONE of the following: + + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or + an equivalent medium, or placing the modifications on a major archive + site such as uunet.uu.net, or by allowing the Copyright Holder to include + your modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and provide + a separate manual page for each non-standard executable that clearly + documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + + + + 4. You may distribute the programs of this Package in object code or + executable form, provided that you do at least ONE of the following: + + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where + to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), together + with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + + + + 5. You may charge a reasonable copying fee for any distribution of + this Package. You may charge any fee you choose for support of this + Package. You may not charge a fee for this Package itself. However, + you may distribute this Package in aggregate with other (possibly com- + mercial) programs as part of a larger (possibly commercial) software + distribution provided that you do not advertise this Package as a + product of your own. You may embed this Package's interpreter within + an executable of yours (by linking); this shall be construed as a mere + form of aggregation, provided that the complete Standard Version of + the interpreter is so embedded. + + 6. The scripts and library files supplied as input to or produced as + output from the programs of this Package do not automatically fall + under the copyright of this Package, but belong to whomever generated + them, and may be sold commercially, and may be aggregated with this + Package. If such scripts or library files are aggregated with this + Package via the so-called "undump" or "unexec" methods of producing a + binary executable image, then distribution of such an image shall + neither be construed as a distribution of this Package nor shall it + fall under the restrictions of Paragraphs 3 and 4, provided that you + do not represent such an executable image as a Standard Version of + this Package. + 7. C subroutines (or comparably compiled subroutines in other + languages) supplied by you and linked into this Package in order to + emulate subroutines and variables of the language defined by this + Package shall not be considered part of this Package, but are the + equivalent of input as in Paragraph 6, provided these subroutines do + not change the language in any way that would cause it to fail the + regression tests for the language. + + 8. Aggregation of this Package with a commercial distribution is + always permitted provided that the use of this Package is embedded; + that is, when no overt attempt is made to make this Package's + interfaces visible to the end user of the commercial distribution. + Such use shall not be construed as a distribution of this Package. + + 9. The name of the Copyright Holder may not be used to endorse or + promote products derived from this software without specific prior + written permission. + + 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + + + + Table of Contents + + + 1. Preface . . . . . . . . . . . . . . . . . . . . . . . . . . . . 2 + 1.1. A Brief History of S-Lang . . . . . . . . . . . . . . . . . . 2 + 1.2. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . 2 + 2. Introduction . . . . . . . . . . . . . . . . . . . . . . . . . 4 + 3. Interpreter Interface . . . . . . . . . . . . . . . . . . . . . 5 + 3.1. Embedding the Interpreter . . . . . . . . . . . . . . . . . . 5 + 3.2. Calling the Interpreter . . . . . . . . . . . . . . . . . . . 6 + 3.2.1. Loading Files . . . . . . . . . . . . . . . . . . . . . . . 6 + 3.2.2. Loading Strings . . . . . . . . . . . . . . . . . . . . . . 7 + 3.3. Intrinsic Functions . . . . . . . . . . . . . . . . . . . . . 7 + 3.3.1. Restrictions on Intrinsic Functions . . . . . . . . . . . . 8 + 3.3.2. Adding a New Intrinsic . . . . . . . . . . . . . . . . . . 9 + 3.3.3. More Complicated Intrinsics . . . . . . . . . . . . . . . . 11 + 3.4. Intrinsic Variables . . . . . . . . . . . . . . . . . . . . . 13 + 3.5. Aggregate Data Objects . . . . . . . . . . . . . . . . . . . 15 + 3.5.1. Arrays . . . . . . . . . . . . . . . . . . . . . . . . . . 16 + 3.5.2. Structures . . . . . . . . . . . . . . . . . . . . . . . . 18 + 3.5.2.1. Interpreter Structures . . . . . . . . . . . . . . . . . 18 + 3.5.2.2. Intrinsic Structures . . . . . . . . . . . . . . . . . . 22 + 4. Keyboard Interface . . . . . . . . . . . . . . . . . . . . . . 24 + 4.1. Initializing the Keyboard Interface . . . . . . . . . . . . . 24 + 4.2. Resetting the Keyboard Interface . . . . . . . . . . . . . . 25 + 4.3. Initializing the SLkp Routines . . . . . . . . . . . . . . . 25 + 4.4. Setting the Interrupt Handler . . . . . . . . . . . . . . . . 26 + 4.5. Reading Keyboard Input with SLang_getkey . . . . . . . . . . 27 + 4.6. Reading Keyboard Input with SLkp_getkey . . . . . . . . . . . 28 + 4.7. Buffering Input . . . . . . . . . . . . . . . . . . . . . . . 29 + 4.8. Global Variables . . . . . . . . . . . . . . . . . . . . . . 30 + 5. Screen Management . . . . . . . . . . . . . . . . . . . . . . . 31 + 5.1. Initialization . . . . . . . . . . . . . . . . . . . . . . . 31 + 5.2. Resetting SLsmg . . . . . . . . . . . . . . . . . . . . . . . 31 + 5.3. Handling Screen Resize Events . . . . . . . . . . . . . . . . 32 + 5.4. SLsmg Functions . . . . . . . . . . . . . . . . . . . . . . . 33 + 5.4.1. Positioning the cursor . . . . . . . . . . . . . . . . . . 33 + 5.4.2. Writing to the Display . . . . . . . . . . . . . . . . . . 34 + 5.4.3. Erasing the Display . . . . . . . . . . . . . . . . . . . . 35 + 5.4.4. Setting Character Attributes . . . . . . . . . . . . . . . 35 + 5.4.5. Lines and Alternate Character Sets . . . . . . . . . . . . 37 + 5.4.6. Miscellaneous Functions . . . . . . . . . . . . . . . . . . 37 + 5.5. Variables . . . . . . . . . . . . . . . . . . . . . . . . . . 38 + 5.6. Hints for using SLsmg . . . . . . . . . . . . . . . . . . . . 38 + 6. Signal Functions . . . . . . . . . . . . . . . . . . . . . . . 39 + 7. Searching Functions . . . . . . . . . . . . . . . . . . . . . . 41 + 7.1. Regular Expressions . . . . . . . . . . . . . . . . . . . . . 41 + 7.2. Simple Searches . . . . . . . . . . . . . . . . . . . . . . . 41 + 7.3. Initialization . . . . . . . . . . . . . . . . . . . . . . . 41 + 7.4. SLsearch . . . . . . . . . . . . . . . . . . . . . . . . . . 41 + A. Copyright . . . . . . . . . . . . . . . . . . . . . . . . . . . 43 + A.1. The GNU Public License . . . . . . . . . . . . . . . . . . . 43 + A.2. The Artistic License . . . . . . . . . . . . . . . . . . . . 49 + + + diff --git a/libslang/doc/text/slang.txt b/libslang/doc/text/slang.txt new file mode 100644 index 0000000..6867293 --- /dev/null +++ b/libslang/doc/text/slang.txt @@ -0,0 +1,5642 @@ + A Guide to the S-Lang Language + John E. Davis, davis@space.mit.edu + Mar 23, 2003 + ____________________________________________________________ + + Table of Contents + + + + Preface + + 1. A Brief History of S-Lang + 2. Acknowledgements + 2. Introduction + 3. Language Features + 4. Data Types and Operators + 5. Statements and Functions + 6. Error Handling + 7. Run-Time Library + 8. Input/Output + 9. Obtaining S-Lang + 9. Overview of the Language + 10. Variables and Functions + 11. Strings + 12. Referencing and Dereferencing + 13. Arrays + 14. Structures and User-Defined Types + 15. Namespaces + 15. Data Types and Literal Constants + 16. Predefined Data Types + 16.1 Integers + 16.2 Floating Point Numbers + 16.3 Complex Numbers + 16.4 Strings + 16.5 Null_Type + 16.6 Ref_Type + 16.7 Array_Type and Struct_Type + 16.8 DataType_Type Type + + 17. Typecasting: Converting from one Type to Another + + 17. Identifiers + + 17. Variables + + 17. Operators + 18. Unary Operators + 19. Binary Operators + 19.1 Arithmetic Operators + 19.2 Relational Operators + 19.3 Boolean Operators + 19.4 Bitwise Operators + 19.5 Namespace operator + 19.6 Operator Precedence + 19.7 Binary Operators and Functions Returning Multiple Values + + 20. Mixing Integer and Floating Point Arithmetic + 21. Short Circuit Boolean Evaluation + 21. Statements + 22. Variable Declaration Statements + 23. Assignment Statements + 24. Conditional and Looping Statements + 24.1 Conditional Forms + 24.1.1 if + 24.1.2 if-else + 24.1.3 !if + 24.1.4 orelse, andelse + 24.1.5 switch + 24.2 Looping Forms + 24.2.1 while + 24.2.2 do...while + 24.2.3 for + 24.2.4 loop + 24.2.5 for + 24.2.6 forever + 24.2.7 foreach + + 25. break, return, continue + + 25. Functions + 26. Declaring Functions + 27. Parameter Passing Mechanism + 28. Referencing Variables + 29. Functions with a Variable Number of Arguments + 30. Returning Values + 31. Multiple Assignment Statement + 32. Exit-Blocks + 32. Name Spaces + 32. Arrays + 33. Creating Arrays + 33.1 Range Arrays + 33.2 Creating arrays via the dereference operator + + 34. Reshaping Arrays + 35. Indexing Arrays + 36. Arrays and Variables + 37. Using Arrays in Computations + 37. Associative Arrays + 37. Structures and User-Defined Types + 38. Defining a Structure + 39. Accessing the Fields of a Structure + 40. Linked Lists + 41. Defining New Types + 41. Error Handling + 42. Error-Blocks + 43. Clearing Errors + 43. Loading Files: evalfile and autoload + 43. File Input/Output + 44. Input/Output via stdio + 44.1 Stdio Overview + 44.2 Stdio Examples + + 45. POSIX I/O + 46. Advanced I/O techniques + 46.1 Example: Reading /var/log/wtmp + 46.1 Debugging + 46.1 Regular Expressions + + 47. S-Lang RE Syntax + 48. Differences between S-Lang and egrep REs + 48. Future Directions + 48. Copyright + A. The GNU Public License + B. The Artistic License + + + ______________________________________________________________________ + + + + 1. Preface + + + + S-Lang is an interpreted language that was designed from the start to + be easily embedded into a program to provide it with a powerful + extension language. Examples of programs that use S-Lang as an + extension language include the jed text editor, the slrn newsreader, + and sldxe (unreleased), a numerical computation program. For this + reason, S-Lang does not exist as a separate application and many of + the examples in this document are presented in the context of one of + the above applications. + + S-Lang is also a programmer's library that permits a programmer to + develop sophisticated platform-independent software. In addition to + providing the S-Lang extension language, the library provides + facilities for screen management, keymaps, low-level terminal I/O, + etc. However, this document is concerned only with the extension + language and does not address these other features of the S-Lang + library. For information about the other components of the library, + the reader is referred to the The S-Lang Library Reference. + + + 1.1. A Brief History of S-Lang + + + + I first began working on S-Lang sometime during the fall of 1992. At + that time I was writing a text editor (jed), which I wanted to endow + with a macro language. It occured to me that an application- + independent language that could be embedded into the editor would + prove more useful because I could envision embedding it into other + programs. As a result, S-Lang was born. + + S-Lang was originally a stack language that supported a postscript- + like syntax. For that reason, I named it S-Lang, where the S was + supposed to emphasize its stack-based nature. About a year later, I + began to work on a preparser that would allow one to write using a + more traditional infix syntax making it easier to use for those + unfamiliar with stack based languages. Currently, the syntax of the + language resembles C, nevertheless some postscript-like features still + remain, e.g., the `%' character is still used as a comment delimiter. + + + + 1.2. Acknowledgements + + + + Since I first released S-Lang, I have received a lot feedback about + the library and the language from many people. This has given me the + opportunity and pleasure to interact with several people to make the + library portable and easy to use. In particular, I would like to + thank the following individuals: + + Luchesar Ionkov for his comments and criticisms of + the syntax of the language. He was the person who made me realize + that the low-level byte-code engine should be totally type- + independent. He also improved the tokenizer and preparser and + impressed upon me that the language needed a grammar. + + Mark Olesen for his many patches to + various aspects of the library and his support on AIX. He also + contributed a lot to the pre-processing (SLprep) routines. + + John Burnell for the OS/2 port of the video and + keyboard routines. He also made value suggestions regarding the + interpreter interface. + + Darrel Hankerson for cleaning up and + unifying some of the code and the makefiles. + + Dominik Wujastyk who was always willing to test + new releases of the library. + + Michael Elkins for his work on the curses + emulation. + + Ulli Horlacher and Oezguer Kesim for the S-Lang newsgroup and mailing list. + + Hunter Goatley, Andy Harper , and Martin P.J. + Zinser for their VMS support. + + Dave Sims and Chin Huang for + Windows 95 and Windows NT support. + + Lloyd Zusman and Rich Roth for + creating and maintaining www.s-lang.org. + + I am also grateful to many other people who send in bug-reports and + bug-fixes, for without such community involvement, S-Lang would not be + as well-tested and stable as it is. Finally, I would like to thank my + wife for her support and understanding while I spent long weekend + hours developing the library. + + + + 2. Introduction + + + + S-Lang is a powerful interpreted language that may be embedded into an + application to make the application extensible. This enables the + application to be used in ways not envisioned by the programmer, thus + providing the application with much more flexibility and power. + Examples of applications that take advantage of the interpreter in + this way include the jed editor and the slrn newsreader. + + + 2.1. Language Features + + + The language features both global and local variables, branching and + looping constructs, user-defined functions, structures, datatypes, and + arrays. In addition, there is limited support for pointer types. The + concise array syntax rivals that of commercial array-based numerical + computing environments. + + + 2.2. Data Types and Operators + + + + The language provides built-in support for string, integer (signed and + unsigned long and short), double precision floating point, and double + precision complex numbers. In addition, it supports user defined + structure types, multi-dimensional array types, and associative + arrays. To facilitate the construction of sophisticated data + structures such as linked lists and trees, a `reference' type was + added to the language. The reference type provides much of the same + flexibility as pointers in other languages. Finally, applications + embedding the interpreter may also provide special application + specific types, such as the Mark_Type that the jed editor provides. + + The language provides standard arithmetic operations such as addition, + subtraction, multiplication, and division. It also provides support + for modulo arithmetic as well as operations at the bit level, e.g., + exclusive-or. Any binary or unary operator may be extended to work + with any data type. For example, the addition operator (+) has been + extended to work between string types to permit string concatenation. + + The binary and unary operators work transparently with array types. + For example, if a and b are arrays, then a + b produces an array whose + elements are the result of element by element addition of a and b. + This permits one to do vector operations without explicitly looping + over the array indices. + + + + 2.3. Statements and Functions + + + + The S-Lang language supports several types of looping constructs and + conditional statements. The looping constructs include while, + do...while, for, forever, loop, foreach, and _for. The conditional + statements include if, if-then-else, and !if. + + User defined functions may be defined to return zero, one, or more + values. Functions that return zero values are similar to `procedures' + in languages such as PASCAL. The local variables of a function are + always created on a stack allowing one to create recursive functions. + Parameters to a function are always passed by value and never by + reference. However, the language supports a reference data type that + allows one to simulate pass by reference. + + Unlike many interpreted languages, S-Lang allows functions to be + dynamically loaded (function autoloading). It also provides + constructs specifically designed for error handling and recovery as + well as debugging aids (e.g., function tracebacks). + + Functions and variables may be declared as private belonging to a + namespace associated with the compilation unit that defines the + function or variable. The ideas behind the namespace implementation + stems from the C language and should be quite familiar to any one + familiar with C. + + + + 2.4. Error Handling + + + + The S-Lang language defines a construct called an error-block that may + be used for error handling and recovery. When a non-fatal run-time + error is encountered, any error blocks that have been defined are + executed as the run-time stack unwinds. An error block can optionally + clear the error and the program will continue running after the + statement that triggered the error. This mechanism is somewhat + similar to try-catch in C++. + + + + 2.5. Run-Time Library + + + + Functions that compose the S-Lang run-time library are called + intrinsics. Examples of S-Lang intrinsic functions available to every + S-Lang application include string manipulation functions such as + strcat, strchop, and strcmp. The S-Lang library also provides + mathematical functions such as sin, cos, and tan; however, not all + applications enable the use of these intrinsics. For example, to + conserve memory, the 16 bit version of the jed editor does not provide + support for any mathematics other than simple integer arithmetic, + whereas other versions of the editor do support these functions. + + Most applications embedding the languages will also provide a set of + application specific intrinsic functions. For example, the jed editor + adds over 100 application specific intrinsic functions to the + language. Consult your application specific documentation to see what + additional intrinsics are supported. + + + + 2.6. Input/Output + + + The language supports C-like stdio input/output functions such as + fopen, fgets, fputs, and fclose. In addition it provides two + functions, message and error, for writing to the standard output + device and standard error. Specific applications may provide other + I/O mechanisms, e.g., the jed editor supports I/O to files via the + editor's buffers. + + 2.7. Obtaining S-Lang + + + + Comprehensive information about the library may be obtained via the + World Wide Web from http://www.s-lang.org. + + S-Lang as well as some programs that embed it are freely available via + anonymous ftp in the United States from + + o ftp://space.mit.edu/pub/davis. + + It is also available outside the United States from the following + mirror sites: + + o ftp://ftp.uni-stuttgart.de/pub/unix/misc/slang/ + + o ftp://ftp.fu-berlin.de/pub/unix/news/slrn/ + + o ftp://ftp.ntua.gr/pub/lang/slang/ + + The Usenet newsgroup alt.lang.s-lang was created for S-Lang + programmers to exchange information and share macros for the various + programs the embed the language. The newsgroup comp.editors can be a + useful resource for S-Lang macros for the jed editor. Similarly, slrn + users will find news.software.readers to be a valuable source of + information. + + Finally, two mailing lists dealing with the S-Lang library have been + created: + + o slang-announce@babayaga.math.fu-berlin.de + + o slang-workers@babayaga.math.fu-berlin.de + + The first list is for announcements of new releases of the library, + while the second list is intended for those who use the library for + their own code development. To subscribe to the announcement list, + send an email to slang-announce-subscribe@babayaga.math.fu- + berlin.de and include the word subscribe in the body of the + message. To subscribe to the developers list, use the address + slang-workers-subscribe@babayaga.math.fu-berlin.de. + + + + 3. Overview of the Language + + + + This purpose of this section is to give the reader a feel for the S- + Lang language, its syntax, and its capabilities. The information and + examples presented in this section should be sufficient to provide the + reader with the necessary background to understand the rest of the + document. + + + 3.1. Variables and Functions + + + + S-Lang is different from many other interpreted languages in the sense + that all variables and functions must be declared before they can be + used. + + Variables are declared using the variable keyword, e.g., + + + variable x, y, z; + + + + declares three variables, x, y, and z. Note the semicolon at the end + of the statement. All S-Lang statements must end in a semi-colon. + + Unlike compiled languages such as C, it is not necessary to specify + the data type of a S-Lang variable. The data type of a S-Lang + variable is determined upon assignment. For example, after execution + of the statements + + + x = 3; + y = sin (5.6); + z = "I think, therefore I am."; + + + + x will be an integer, y will be a double, and z will be a string. In + fact, it is even possible to re-assign x to a string: + + + x = "x was an integer, but now is a string"; + + + + Finally, one can combine variable declarations and assignments in the + same statement: + + + variable x = 3, y = sin(5.6), z = "I think, therefore I am."; + + + + Most functions are declared using the define keyword. A simple + example is + + + + define compute_average (x, y) + { + variable s = x + y; + return s / 2.0; + } + + + + which defines a function that simply computes the average of two num- + bers and returns the result. This example shows that a function con- + sists of three parts: the function name, a parameter list, and the + function body. + + The parameter list consists of a comma separated list of variable + names. It is not necessary to declare variables within a parameter + list; they are implicitly declared. However, all other local + variables used in the function must be declared. If the function + takes no parameters, then the parameter list must still be present, + but empty: + + + define go_left_5 () + { + go_left (5); + } + + + + The last example is a function that takes no arguments and returns no + value. Some languages such as PASCAL distinguish such objects from + functions that return values by calling these objects procedures. + However, S-Lang, like C, does not make such a distinction. + + The language permits recursive functions, i.e., functions that call + themselves. The way to do this in S-Lang is to first declare the + function using the form: + + define function-name (); + + + It is not necessary to declare a parameter list when declaring a func- + tion in this way. + + The most famous example of a recursive function is the factorial + function. Here is how to implement it using S-Lang: + + + define factorial (); % declare it for recursion + + define factorial (n) + { + if (n < 2) return 1; + return n * factorial (n - 1); + } + + + + This example also shows how to mix comments with code. S-Lang uses + the `%' character to start a comment and all characters from the com- + ment character to the end of the line are ignored. + + + + 3.2. Strings + + + + Perhaps the most appealing feature of any interpreted language is that + it frees the user from the responsibility of memory management. This + is particularly evident when contrasting how S-Lang handles string + variables with a lower level language such as C. Consider a function + that concatenates three strings. An example in S-Lang is: + + + define concat_3_strings (a, b, c) + { + return strcat (a, strcat (b, c)); + } + + + + This function uses the built-in strcat function for concatenating two + strings. In C, the simplest such function would look like: + + + char *concat_3_strings (char *a, char *b, char *c) + { + unsigned int len; + char *result; + len = strlen (a) + strlen (b) + strlen (c); + if (NULL == (result = (char *) malloc (len + 1))) + exit (1); + strcpy (result, a); + strcat (result, b); + strcat (result, c); + return result; + } + + + + Even this C example is misleading since none of the issues of memory + management of the strings has been dealt with. The S-Lang language + hides all these issues from the user. + + Binary operators have been defined to work with the string data type. + In particular the + operator may be used to perform string + concatenation. That is, one can use the + operator as an alternative + to strcat: + + + define concat_3_strings (a, b, c) + { + return a + b + c; + } + + + + See section ??? for more information about string variables. + + + + 3.3. Referencing and Dereferencing + + + The unary prefix operator, &, may be used to create a reference to an + object, which is similar to a pointer in other languages. References + are commonly used as a mechanism to pass a function as an argument to + another function as the following example illustrates: + + + define compute_functional_sum (funct) + { + variable i, s; + + s = 0; + for (i = 0; i < 10; i++) + { + s += (@funct)(i); + } + return s; + } + + variable sin_sum = compute_functional_sum (&sin); + variable cos_sum = compute_functional_sum (&cos); + + + + Here, the function compute_functional_sum applies the function speci- + fied by the parameter funct to the first 10 integers and returns the + sum. The two statements following the function definition show how + the sin and cos functions may be used. + + Note the @ operator in the definition of compute_functional_sum. It + is known as the dereference operator and is the inverse of the + reference operator. + + Another use of the reference operator is in the context of the fgets + function. For example, + + + define read_nth_line (file, n) + { + variable fp, line; + fp = fopen (file, "r"); + + while (n > 0) + { + if (-1 == fgets (&line, fp)) + return NULL; + n--; + } + return line; + } + + + + uses the fgets function to read the nth line of a file. In particu- + lar, a reference to the local variable line is passed to fgets, and + upon return line will be set to the character string read by fgets. + + Finally, references may be used as an alternative to multiple return + values by passing information back via the parameter list. The + example involving fgets presented above provided an illustration of + this. Another example is + + + + define set_xyz (x, y, z) + { + @x = 1; + @y = 2; + @z = 3; + } + variable X, Y, Z; + set_xyz (&X, &Y, &Z); + + + + which, after execution, results in X set to 1, Y set to 2, and Z set + to 3. A C programmer will note the similarity of set_xyz to the fol- + lowing C implementation: + + + void set_xyz (int *x, int *y, int *z) + { + *x = 1; + *y = 2; + *z = 3; + } + + + + 3.4. Arrays + + + The S-Lang language supports multi-dimensional arrays of all + datatypes. For example, one can define arrays of references to + functions as well as arrays of arrays. Here are a few examples of + creating arrays: + + + variable A = Integer_Type [10]; + variable B = Integer_Type [10, 3]; + variable C = [1, 3, 5, 7, 9]; + + + + The first example creates an array of 10 integers and assigns it to + the variable A. The second example creates a 2-d array of 30 integers + arranged in 10 rows and 3 columns and assigns the result to B. In the + last example, an array of 5 integers is assigned to the variable C. + However, in this case the elements of the array are initialized to the + values specified. This is known as an inline-array. + + S-Lang also supports something called an range-array. An example of + such an array is + + + variable C = [1:9:2]; + + + + This will produce an array of 5 integers running from 1 through 9 in + increments of 2. + + Arrays are passed by reference to functions and never by value. This + permits one to write functions which can initialize arrays. For + example, + + + define init_array (a) + { + variable i, imax; + + imax = length (a); + for (i = 0; i < imax; i++) + { + a[i] = 7; + } + } + + variable A = Integer_Type [10]; + init_array (A); + + + + creates an array of 10 integers and initializes all its elements to 7. + + There are more concise ways of accomplishing the result of the + previous example. These include: + + + variable A = [7, 7, 7, 7, 7, 7, 7, 7, 7, 7]; + variable A = Integer_Type [10]; A[[0:9]] = 7; + variable A = Integer_Type [10]; A[*] = 7; + + + + The second and third methods use an array of indices to index the + array A. In the second, the range of indices has been explicitly + specified, whereas the third example uses a wildcard form. See sec- + tion ??? for more information about array indexing. + + Although the examples have pertained to integer arrays, the fact is + that S-Lang arrays can be of any type, e.g., + + + variable A = Double_Type [10]; + variable B = Complex_Type [10]; + variable C = String_Type [10]; + variable D = Ref_Type [10]; + + + + create 10 element arrays of double, complex, string, and reference + types, respectively. The last example may be used to create an array + of functions, e.g., + + + D[0] = &sin; + D[1] = &cos; + + + + The language also defines unary, binary, and mathematical operations + on arrays. For example, if A and B are integer arrays, then A + B is + an array whose elements are the sum of the elements of A and B. A + trivial example that illustrates the power of this capability is + + variable X, Y; + X = [0:2*PI:0.01]; + Y = 20 * sin (X); + + + + which is equivalent to the highly simplified C code: + + + double *X, *Y; + unsigned int i, n; + + n = (2 * PI) / 0.01 + 1; + X = (double *) malloc (n * sizeof (double)); + Y = (double *) malloc (n * sizeof (double)); + for (i = 0; i < n; i++) + { + X[i] = i * 0.01; + Y[i] = 20 * sin (X[i]); + } + + + + 3.5. Structures and User-Defined Types + + + + A structure is similar to an array in the sense that it is a container + object. However, the elements of an array must all be of the same + type (or of Any_Type), whereas a structure is heterogeneous. As an + example, consider + + + variable person = struct + { + first_name, last_name, age + }; + variable bill = @person; + bill.first_name = "Bill"; + bill.last_name = "Clinton"; + bill.age = 51; + + + + In this example a structure consisting of the three fields has been + created and assigned to the variable person. Then an instance of this + structure has been created using the dereference operator and assigned + to bill. Finally, the individual fields of bill were initialized. + This is an example of an anonymous structure. + + A named structure is really a new data type and may be created using + the typedef keyword: + + + + typedef struct + { + first_name, last_name, age + } + Person_Type; + + variable bill = @Person_Type; + bill.first_name = "Bill"; + bill.last_name = "Clinton"; + bill.age = 51; + + + + The big advantage of creating a new type is that one can go on to cre- + ate arrays of the data type + + + variable People = Person_Type [100]; + People[0].first_name = "Bill"; + People[1].first_name = "Hillary"; + + + + The creation and initialization of a structure may be facilitated by a + function such as + + + define create_person (first, last, age) + { + variable person = @Person_Type; + person.first_name = first; + person.last_name = last; + person.age = age; + return person; + } + variable Bill = create_person ("Bill", "Clinton", 51); + + + + Other common uses of structures is the creation of linked lists, + binary trees, etc. For more information about these and other + features of structures, see section ???. + + + + 3.6. Namespaces + + + In addition to the global namespace, each compilation unit (e.g., a + file) is given a private namespace. A variable or function name that + is declared using the static keyword will be placed in the private + namespace associated with compilation unit. For example, + + + variable i; + static variable i; + + + + defines two variables called i. The first declaration defines i in + the global namespace, but the second declaration defines i in the pri- + vate namespace. + + The -> operator may be used in conjunction with the name of the + namespace to access objects in the name space. In the above example, + to access the variable i in the global namespace, one would use + Global->i. Unless otherwise specified, a private namespace has no + name and its objects may not be accessed from outside the compilation + unit. However, the implements function may be used give the private + namespace a name, allowing access to its objects. For example, if the + file t.sl contains + + + implements ("A"); + static variable i; + + + + then another file may access the variable i via A->i. + + + + 4. Data Types and Literal Constants + + + + The current implementation of the S-Lang language permits up to 256 + distinct data types, including predefined data types such as integer + and floating point, as well as specialized applications specific data + types. It is also possible to create new data types in the language + using the typedef mechanism. + + Literal constants are objects such as the integer 3 or the string + "hello". The actual data type given to a literal constant depends + upon the syntax of the constant. The following sections describe the + syntax of literals of specific data types. + + + 4.1. Predefined Data Types + + + + The current version of S-Lang defines integer, floating point, + complex, and string types. It also defines special purpose data types + such as Null_Type, DataType_Type, and Ref_Type. These types are + discussed below. + + + 4.1.1. Integers + + + + The S-Lang language supports both signed and unsigned characters, + short integer, long integer, and plain integer types. On most 32 bit + systems, there is no difference between an integer and a long integer; + however, they may differ on 16 and 64 bit systems. Generally + speaking, on a 16 bit system, plain integers are 16 bit quantities + with a range of -32767 to 32767. On a 32 bit system, plain integers + range from -2147483648 to 2147483647. + + An plain integer literal can be specified in one of several ways: + + o As a decimal (base 10) integer consisting of the characters 0 + through 9, e.g., 127. An integer specified this way cannot begin + with a leading 0. That is, 0127 is not the same as 127. + + o Using hexadecimal (base 16) notation consisting of the characters 0 + to 9 and A through F. The hexadecimal number must be preceded by + the characters 0x. For example, 0x7F specifies an integer using + hexadecimal notation and has the same value as decimal 127. + + o In Octal notation using characters 0 through 7. The Octal number + must begin with a leading 0. For example, 0177 and 127 represent + the same integer. + + Short, long, and unsigned types may be specified by using the + proper suffixes: L indicates that the integer is a long integer, h + indicates that the integer is a short integer, and U indicates that + it is unsigned. For example, 1UL specifies an unsigned long + integer. + + Finally, a character literal may be specified using a notation + containing a character enclosed in single quotes as 'a'. The value + of the character specified this way will lie in the range 0 to 256 + and will be determined by the ASCII value of the character in + quotes. For example, + + + i = '0'; + + + + assigns to i the character 48 since the '0' character has an ASCII + value of 48. + + Any integer may be preceded by a minus sign to indicate that it is a + negative integer. + + + + 4.1.2. Floating Point Numbers + + + + Single and double precision floating point literals must contain + either a decimal point or an exponent (or both). Here are examples of + specifying the same double precision point number: + + + 12. 12.0 12e0 1.2e1 120e-1 .12e2 0.12e2 + + + + Note that 12 is not a floating point number since it contains neither + a decimal point nor an exponent. In fact, 12 is an integer. + + One may append the f character to the end of the number to indicate + that the number is a single precision literal. + + + + 4.1.3. Complex Numbers + + + + The language implements complex numbers as a pair of double precision + floating point numbers. The first number in the pair forms the real + part, while the second number forms the imaginary part. That is, a + complex number may be regarded as the sum of a real number and an + imaginary number. + + Strictly speaking, the current implementation of the S-Lang does not + support generic complex literals. However, it does support imaginary + literals and a more generic complex number with a non-zero real part + may be constructed from the imaginary literal via addition of a real + number. + + An imaginary literal is specified in the same way as a floating point + literal except that i or j is appended. For example, + + + 12i 12.0i 12e0j + + + + all represent the same imaginary number. Actually, 12i is really an + imaginary integer except that S-Lang automatically promotes it to a + double precision imaginary number. + + A more generic complex number may be constructed from an imaginary + literal via addition, e.g., + + + 3.0 + 4.0i + + + + produces a complex number whose real part is 3.0 and whose imaginary + part is 4.0. + + The intrinsic functions Real and Imag may be used to retrieve the real + and imaginary parts of a complex number, respectively. + + + + 4.1.4. Strings + + + + A string literal must be enclosed in double quotes as in: + + + "This is a string". + + + + Although there is no imposed limit on the length of a string, string + literals must be less than 256 characters in length. It is possible + to go beyond this limit by string concatenation, e.g., + + + "This is the first part of a long string" + + "and this is the second half" + + + + Any character except a newline (ASCII 10) or the null character (ASCII + 0) may appear explicitly in a string literal. However, these charac- + ters may be used implicitly using the mechanism described below. + + The backslash character is a special character and is used to include + other special characters (such as a newline character) in the string. + The special characters recognized are: + + + \" -- double quote + \' -- single quote + \\ -- backslash + \a -- bell character (ASCII 7) + \t -- tab character (ASCII 9) + \n -- newline character (ASCII 10) + \e -- escape character (ASCII 27) + \xhhh -- character expressed in HEXADECIMAL notation + \ooo -- character expressed in OCTAL notation + \dnnn -- character expressed in DECIMAL + + + + For example, to include the double quote character as part of the + string, it must be preceded by a backslash character, e.g., + "This is a \"quote\"" + + + + Similarly, the next illustrates how a newline character may be + included: + + + "This is the first line\nand this is the second" + + + + 4.1.5. Null_Type + + + Objects of type Null_Type can have only one value: NULL. About the + only thing that you can do with this data type is to assign it to + variables and test for equality with other objects. Nevertheless, + Null_Type is an important and extremely useful data type. Its main + use stems from the fact that since it can be compared for equality + with any other data type, it is ideal to represent the value of an + object which does not yet have a value, or has an illegal value. + + As a trivial example of its use, consider + + + define add_numbers (a, b) + { + if (a == NULL) a = 0; + if (b == NULL) b = 0; + return a + b; + } + variable c = add_numbers (1, 2); + variable d = add_numbers (1, NULL); + variable e = add_numbers (1,); + variable f = add_numbers (,); + + + + It should be clear that after these statements have been executed, c + will have a value of 3. It should also be clear that d will have a + value of 1 because NULL has been passed as the second parameter. One + feature of the language is that if a parameter has been omitted from a + function call, the variable associated with that parameter will be set + to NULL. Hence, e and f will be set to 1 and 0, respectively. + + The Null_Type data type also plays an important role in the context of + structures. + + + 4.1.6. Ref_Type + + Objects of Ref_Type are created using the unary reference operator &. + Such objects may be dereferenced using the dereference operator @. + For example, + + + variable sin_ref = &sin; + variable y = (@sin_ref) (1.0); + + creates a reference to the sin function and assigns it to sin_ref. + The second statement uses the dereference operator to call the func- + tion that sin_ref references. + + The Ref_Type is useful for passing functions as arguments to other + functions, or for returning information from a function via its + parameter list. The dereference operator is also used to create an + instance of a structure. For these reasons, further discussion of + this important type can be found in section ??? and section ???. + + + 4.1.7. Array_Type and Struct_Type + + + Variables of type Array_Type and Struct_Type are known as container + objects. They are much more complicated than the simple data types + discussed so far and each obeys a special syntax. For these reasons + they are discussed in a separate chapters. See ???. + + + 4.1.8. DataType_Type Type + + + + S-Lang defines a type called DataType_Type. Objects of this type have + values that are type names. For example, an integer is an object of + type Integer_Type. The literals of DataType_Type include: + + + Char_Type (signed character) + UChar_Type (unsigned character) + Short_Type (short integer) + UShort_Type (unsigned short integer) + Integer_Type (plain integer) + UInteger_Type (plain unsigned integer) + Long_Type (long integer) + ULong_Type (unsigned long integer) + Float_Type (single precision real) + Double_Type (double precision real) + Complex_Type (complex numbers) + String_Type (strings, C strings) + BString_Type (binary strings) + Struct_Type (structures) + Ref_Type (references) + Null_Type (NULL) + Array_Type (arrays) + DataType_Type (data types) + + + + as well as the names of any other types that an application defines. + + The built-in function typeof returns the data type of its argument, + i.e., a DataType_Type. For instance typeof(7) returns Integer_Type + and typeof(Integer_Type) returns DataType_Type. One can use this + function as in the following example: + + + if (Integer_Type == typeof (x)) message ("x is an integer"); + + + + The literals of DataType_Type have other uses as well. One of the + most common uses of these literals is to create arrays, e.g., + x = Complex_Type [100]; + + + + creates an array of 100 complex numbers and assigns it to x. + + + + 4.2. Typecasting: Converting from one Type to Another + + + Occasionally, it is necessary to convert from one data type to + another. For example, if you need to print an object as a string, it + may be necessary to convert it to a String_Type. The typecast + function may be used to perform such conversions. For example, + consider + + + variable x = 10, y; + y = typecast (x, Double_Type); + + + + After execution of these statements, x will have the integer value 10 + and y will have the double precision floating point value 10.0. If + the object to be converted is an array, the typecast function will act + upon all elements of the array. For example, + + + variable x = [1:10]; % Array of integers + variable y = typecast (x, Double_Type); + + + + will create an array of 10 double precision values and assign it to y. + One should also realize that it is not always possible to perform a + typecast. For example, any attempt to convert an Integer_Type to a + Null_Type will result in a run-time error. + + Often the interpreter will perform implicit type conversions as + necessary to complete calculations. For example, when multiplying an + Integer_Type with a Double_Type, it will convert the Integer_Type to a + Double_Type for the purpose of the calculation. Thus, the example + involving the conversion of an array of integers to an array of + doubles could have been performed by multiplication by 1.0, i.e., + + + variable x = [1:10]; % Array of integers + variable y = 1.0 * x; + + + + The string intrinsic function is similar to the typecast function + except that it converts an object to a string representation. It is + important to understand that a typecast from some type to String_Type + is not the same as converting an object to its string operation. + That is, typecast(x,String_Type) is not equivalent to string(x). The + reason for this is that when given an array, the typecast function + acts on each element of the array to produce another array, whereas + the string function produces a a string. + The string function is useful for printing the value of an object. + This use is illustrated in the following simple example: + + + define print_object (x) + { + message (string (x)); + } + + + + Here, the message function has been used because it writes a string to + the display. If the string function was not used and the message + function was passed an integer, a type-mismatch error would have + resulted. + + + + 5. Identifiers + + + + The names given to variables, functions, and data types are called + identifiers. There are some restrictions upon the actual characters + that make up an identifier. An identifier name must start with a + letter ([A-Za-z]), an underscore character, or a dollar sign. The + rest of the characters in the name can be any combination of letters, + digits, dollar signs, or underscore characters. However, all + identifiers whose name begins with two underscore characters are + reserved for internal use by the interpreter and declarations of + objects with such names should be avoided. + + Examples of valid identifiers include: + + + mary _3 _this_is_ok + a7e1 $44 _44$_Three + + + + However, the following are not legal: + + + 7abc 2e0 #xx + + + + In fact, 2e0 actually specifies the real number 2.0. + + Although the maximum length of identifiers is unspecified by the + language, the length should be kept below 64 characters. + + The following identifiers are reserved by the language for use as + keywords: + + + !if _for do mod sign xor + ERROR_BLOCK abs do_while mul2 sqr public + EXIT_BLOCK and else not static private + USER_BLOCK0 andelse exch or struct + USER_BLOCK1 break for orelse switch + USER_BLOCK2 case foreach pop typedef + USER_BLOCK3 chs forever return using + USER_BLOCK4 continue if shl variable + __tmp define loop shr while + + + + In addition, the next major S-Lang release (v2.0) will reserve try and + catch, so it is probably a good idea to avoid those words until then. + + + + 6. Variables + + + + A variable must be declared before it can be used, otherwise an + undefined name error will be generated. A variable is declared using + the variable keyword, e.g, + + + variable x, y, z; + + + + declares three variables, x, y, and z. This is an example of a vari- + able declaration statement, and like all statements, it must end in a + semi-colon. + + Variables declared this way are untyped and inherit a type upon + assignment. The actual type checking is performed at run-time. For + example, + + + x = "This is a string"; + x = 1.2; + x = 3; + x = 2i; + + + + results in x being set successively to a string, a float, an integer, + and to a complex number (0+2i). Any attempt to use a variable before + it has acquired a type will result in an uninitialized variable error. + + It is legal to put executable code in a variable declaration list. + That is, + + + variable x = 1, y = sin (x); + + + + are legal variable declarations. This also provides a convenient way + of initializing a variable. + + Variables are classified as either global or local. A variable + declared inside a function is said to be local and has no meaning + outside the function. A variable is said to be global if it was + declared outside a function. Global variables are further classified + as being public, static, or private, according to the name space where + they were defined. See chapter ??? for more information about name + spaces. + + The following global variables are predefined by the language and are + mainly used as convenience variables: + + + $0 $1 $2 $3 $4 $5 $6 $7 $8 $9 + + + + An intrinsic variable is another type of global variable. Such + variables have a definite type which cannot be altered. Variables of + this type may also be defined to be read-only, or constant variables. + An example of an intrinsic variable is PI which is a read-only double + precision variable with a value of approximately + 3.14159265358979323846. + + + + 7. Operators + + + + S-Lang supports a variety of operators that are grouped into three + classes: assignment operators, binary operators, and unary operators. + + An assignment operator is used to assign a value to a variable. They + will be discussed more fully in the context of the assignment + statement in section ???. + + An unary operator acts only upon a single quantity while a binary + operation is an operation between two quantities. The boolean + operator not is an example of an unary operator. Examples of binary + operators include the usual arithmetic operators +, -, *, and /. The + operator given by - can be either an unary operator (negation) or a + binary operator (subtraction); the actual operation is determined from + the context in which it is used. + + Binary operators are used in algebraic forms, e.g., a + b. Unary + operators fall in one of two classes: postfix-unary or prefix-unary. + For example, in the expression -x, the minus sign is a prefix-unary + operator. + + Not all data types have binary or unary operations defined. For + example, while String_Type objects support the + operator, they do not + admit the * operator. + + + 7.1. Unary Operators + + + The unary operators operate only upon a single operand. They include: + not, ~, -, @, &, as well as the increment and decrement operators ++ + and --, respectively. + + The boolean operator not acts only upon integers and produces 0 if its + operand is non-zero, otherwise it produces 1. + + The bit-level not operator ~ performs a similar function, except that + it operates on the individual bits of its integer operand. + + The arithmetic negation operator - is the most well-known unary + operator. It simply reverses the sign of its operand. + + The reference (&) and dereference (@) operators will be discussed in + greater detail in section ???. Similarly, the increment (++) and + decrement (--) operators will be discussed in the context of the + assignment operator. + + + 7.2. Binary Operators + + + + The binary operators may be grouped according to several classes: + arithmetic operators, relational operators, boolean operators, and + bitwise operators. + + All binary and unary operators may be overloaded. For example, the + arithmetic plus operator has been overloaded by the String_Type data + type to permit concatenation between strings. + + + + 7.2.1. Arithmetic Operators + + + + The arithmetic operators include +, -, *, /, which perform addition, + subtraction, multiplication, and division, respectively. In addition + to these, S-Lang supports the mod operator as well as the power + operator ^. + + The data type of the result produced by the use of one of these + operators depends upon the data types of the binary participants. If + they are both integers, the result will be an integer. However, if + the operands are not of the same type, they will be converted to a + common type before the operation is performed. For example, if one is + a floating point value and the other is an integer, the integer will + be converted to a float. In general, the promotion from one type to + another is such that no information is lost, if possible. As an + example, consider the expression 8/5 which indicates division of the + integer 8 by the integer 5. The result will be the integer 1 and not + the floating point value 1.6. However, 8/5.0 will produce 1.6 because + 5.0 is a floating point number. + + + + 7.2.2. Relational Operators + + + + The relational operators are >, >=, <, <=, ==, and !=. These perform + the comparisons greater than, greater than or equal, less than, less + than or equal, equal, and not equal, respectively. The result of one + of these comparisons is the integer 1 if the comparison is true, or 0 + if the comparison is false. For example, 6 >= 5 returns 1, but 6 == 5 + produces 0. + + + + 7.2.3. Boolean Operators + + + There are only two boolean binary operators: or and and. These + operators are defined only for integers and produce an integer result. + The or operator returns 1 if either of its operands are non-zero, + otherwise it produces 0. The and operator produces 1 if and only if + both its operands are non-zero, otherwise it produces 0. + + Neither of these operators perform the so-called boolean short-circuit + evaluation. For example, consider the expression: + + + (x != 0) and (1/x > 10) + + + + Here, if x were to have a value of zero, a division by zero error + would occur because even though x!=0 evaluates to zero, the and opera- + tor is not short-circuited and the 1/x expression would still be eval- + uated. Although these operators are not short-circuited, S-Lang does + have another mechanism of performing short-circuit boolean evaluation + via the orelse and andelse expressions. See below for information + about these constructs. + + + 7.2.4. Bitwise Operators + + + + The bitwise binary operators are defined only with integer operands + and are used for bit-level operations. Operators that fall in this + class include &, |, shl, shr, and xor. The & operator performs a + boolean AND operation between the corresponding bits of the operands. + Similarly, the | operator performs the boolean OR operation on the + bits. The bit-shifting operators shl and shr shift the bits of the + first operand by the number given by the second operand to the left or + right, respectively. Finally, the xor performs an EXCLUSIVE-OR + operation. + + These operators are commonly used to manipulate variables whose + individual bits have distinct meanings. In particular, & is usually + used to test bits, | can be used to set bits, and xor may be used to + flip a bit. + + As an example of using & to perform tests on bits, consider the + following: The jed text editor stores some of the information about a + buffer in a bitmapped integer variable. The value of this variable + may be retrieved using the jed intrinsic function getbuf_info, which + actually returns four quantities: the buffer flags, the name of the + buffer, directory name, and file name. For the purposes of this + section, only the buffer flags are of interest and can be retrieved + via a function such as + + + define get_buffer_flags () + { + variable flags; + (,,,flags) = getbuf_info (); + return flags; + } + + + + The buffer flags is a bitmapped quantity where the 0th bit indicates + whether or not the buffer has been modified, the first bit indicates + whether or not autosave has been enabled for the buffer, and so on. + Consider for the moment the task of determining if the buffer has been + modified. This can be determined by looking at the zeroth bit, if it + is 0 the buffer has not been modified, otherwise it has. Thus we can + create the function, + + + define is_buffer_modified () + { + variable flags = get_buffer_flags (); + return (flags & 1); + } + + + + where the integer 1 has been used since it has all of its bits set to + 0, except for the zeroth one, which is set to 1. (At this point, it + should also be apparent that bits are numbered from zero, thus an 8 + bit integer consists of bits 0 to 7, where 0 is the least significant + bit and 7 is the most significant one.) Similarly, we can create + another function + + + + define is_autosave_on () + { + variable flags = get_buffer_flags (); + return (flags & 2); + } + + + + to determine whether or not autosave has been turned on for the + buffer. + + The shl operator may be used to form the integer with only the nth bit + set. For example, 1 shl 6 produces an integer with all bits set to + zero except the sixth bit, which is set to one. The following example + exploits this fact: + + + define test_nth_bit (flags, nth) + { + return flags & (1 shl nth); + } + + + + 7.2.5. Namespace operator + + The operator -> is used to in conjunction with the name of a namespace + to access an object within the namespace. For example, if A is the + name of a namespace containing the variable v, then A->v refers to + that variable. + + + 7.2.6. Operator Precedence + + + + 7.2.7. Binary Operators and Functions Returning Multiple Values + + + Care must be exercised when using binary operators with an operand the + returns multiple values. In fact, the current implementation of the + S-Lang language will produce incorrect results if both operands of a + binary expression return multiple values. At most, only one of + operands of a binary expression can return multiple values, and that + operand must be the first one, not the second. For example, + + + define read_line (fp) + { + variable line, status; + + status = fgets (&line, fp); + if (status == -1) + return -1; + return (line, status); + } + + + + defines a function, read_line that takes a single argument, a handle + to an open file, and returns one or two values, depending upon the + return value of fgets. Now consider + + + while (read_line (fp) > 0) + { + text = (); + % Do something with text + . + . + } + + + + Here the relational binary operator > forms a comparison between one + of the return values (the one at the top of the stack) and 0. In + accordance with the above rule, since read_line returns multiple val- + ues, it occurs as the left binary operand. Putting it on the right as + in + + + while (0 < read_line (fp)) % Incorrect + { + text = (); + % Do something with text + . + . + } + + + + violates the rule and will result in the wrong answer. + + + + 7.3. Mixing Integer and Floating Point Arithmetic + + + If a binary operation (+, -, * , /) is performed on two integers, the + result is an integer. If at least one of the operands is a float, the + other is converted to float and the result is float. For example: + + + 11 / 2 --> 5 (integer) + 11 / 2.0 --> 5.5 (float) + 11.0 / 2 --> 5.5 (float) + 11.0 / 2.0 --> 5.5 (float) + + + + Finally note that only integers may be used as array indices, loop + control variables, and bit operations. The conversion functions, int + and float, may be used convert between floats and ints where appropri- + ate, e.g., + + + int (1.5) --> 1 (integer) + float(1.5) --> 1.5 (float) + float (1) --> 1.0 (float) + + 7.4. Short Circuit Boolean Evaluation + + + The boolean operators or and and are not short circuited as they are + in some languages. S-Lang uses orelse and andelse expressions for + short circuit boolean evaluation. However, these are not binary + operators. Expressions of the form: + + expr-1 and expr-2 and ... expr-n + + + can be replaced by the short circuited version using andelse: + + andelse {expr-1} {expr-2} ... {expr-n} + + + A similar syntax holds for the orelse operator. For example, consider + the statement: + + + if ((x != 0) and (1/x > 10)) do_something (); + + + + Here, if x were to have a value of zero, a division by zero error + would occur because even though x!=0 evaluates to zero, the and opera- + tor is not short circuited and the 1/x expression would be evaluated + causing division by zero. For this case, the andelse expression could + be used to avoid the problem: + + + if (andelse + {x != 0} + {1 / x > 10}) do_something (); + + + + 8. Statements + + + + Loosely speaking, a statement is composed of expressions that are + grouped according to the syntax or grammar of the language to express + a complete computation. Statements are analogous to sentences in a + human language and expressions are like phrases. All statements in + the S-Lang language must end in a semi-colon. + + A statement that occurs within a function is executed only during + execution of the function. However, statements that occur outside the + context of a function are evaluated immediately. + + The language supports several different types of statements such as + assignment statements, conditional statements, and so forth. These + are described in detail in the following sections. + + + 8.1. Variable Declaration Statements + + Variable declarations were already discussed in chapter ???. For the + sake of completeness, a variable declaration is a statement of the + form + + variable variable-declaration-list ; + + + where the variable-declaration-list is a comma separated list of one + or more variable names with optional initializations, e.g., + + + variable x, y = 2, z; + + + + 8.2. Assignment Statements + + + + Perhaps the most well known form of statement is the assignment + statement. Statements of this type consist of a left-hand side, an + assignment operator, and a right-hand side. The left-hand side must + be something to which an assignment can be performed. Such an object + is called an lvalue. + + The most common assignment operator is the simple assignment operator + =. Simple of its use include + + + x = 3; + x = some_function (10); + x = 34 + 27/y + some_function (z); + x = x + 3; + + + + In addition to the simple assignment operator, S-Lang also supports + the assignment operators += and -=. Internally, S-Lang transforms + + + a += b; + + + to + + + a = a + b; + + + + Similarly, a -= b is transformed to a = a - b. It is extremely impor- + tant to realize that, in general, a+b is not equal to b+a. This means + that a+=b is not the same as a=b+a. As an example consider + + + a = "hello"; a += "world"; + + + + After execution of these two statements, a will have the value "hel- + loworld" and not "worldhello". + + Since adding or subtracting 1 from a variable is quite common, S-Lang + also supports the unary increment and decrement operators ++, and --, + respectively. That is, for numeric data types, + + + x = x + 1; + x += 1; + x++; + + + + are all equivalent. Similarly, + + + x = x - 1; + x -= 1; + x--; + + + + are also equivalent. + + Strictly speaking, ++ and -- are unary operators. When used as x++, + the ++ operator is said to be a postfix-unary operator. However, when + used as ++x it is said to be a prefix-unary operator. The current + implementation does not distinguish between the two forms, thus x++ + and ++x are equivalent. The reason for this equivalence is that + assignment expressions do not return a value in the S-Lang language as + they do in C. Thus one should exercise care and not try to write C- + like code such as + + + x = 10; + while (--x) do_something (x); % Ok in C, but not in S-Lang + + + + The closest valid S-Lang form involves a comma-expression: + + + + x = 10; + while (x--, x) do_something (x); % Ok in S-Lang and in C + + + + S-Lang also supports a multiple-assignment statement. It is discussed + in detail in section ???. + + + + 8.3. Conditional and Looping Statements + + + + S-Lang supports a wide variety of conditional and looping statements. + These constructs operate on statements grouped together in blocks. A + block is a sequence of S-Lang statements enclosed in braces and may + contain other blocks. However, a block cannot include function + declarations. In the following, statement-or-block refers to either a + single S-Lang statement or to a block of statements, and integer- + expression is an integer-valued expression. next-statement represents + the statement following the form under discussion. + + + 8.3.1. Conditional Forms + + + + 8.3.1.1. if + + The simplest condition statement is the if statement. It follows the + syntax + + if (integer-expression) statement-or-block next-statement + + + If integer-expression evaluates to a non-zero result, then the state- + ment or group of statements implied statement-or-block will get exe- + cuted. Otherwise, control will proceed to next-statement. + + An example of the use of this type of conditional statement is + + + if (x != 0) + { + y = 1.0 / x; + if (x > 0) z = log (x); + } + + + + This example illustrates two if statements where the second if state- + ment is part of the block of statements that belong to the first. + + + 8.3.1.2. if-else + + Another form of if statement is the if-else statement. It follows the + syntax: + + if (integer-expression) statement-or-block-1 else statement-or-block-2 + next-statement + + Here, if expression returns non-zero, statement-or-block-1 will get + executed and control will pass on to next-statement. However, if + expression returns zero, statement-or-block-2 will get executed before + continuing with next-statement. A simple example of this form is + + + if (x > 0) z = log (x); else error ("x must be positive"); + + + + Consider the more complex example: + + + if (city == "Boston") + if (street == "Beacon") found = 1; + else if (city == "Madrid") + if (street == "Calle Mayor") found = 1; + else found = 0; + + + + This example illustrates a problem that beginners have with if-else + statements. The grammar presented above shows that the this example + is equivalent to + + + if (city == "Boston") + { + if (street == "Beacon") found = 1; + else if (city == "Madrid") + { + if (street == "Calle Mayor") found = 1; + else found = 0; + } + } + + + + It is important to understand the grammar and not be seduced by the + indentation! + + + 8.3.1.3. !if + + + One often encounters if statements similar to + + if (integer-expression == 0) statement-or-block + + + or equivalently, + + if (not(integer-expression)) statement-or-block + + + The !if statement was added to the language to simplify the handling + of such statements. It obeys the syntax + + !if (integer-expression) statement-or-block + + + and is functionally equivalent to + + if (not (expression)) statement-or-block + + + + 8.3.1.4. orelse, andelse + + + These constructs were discussed earlier. The syntax for the orelse + statement is: + + orelse {integer-expression-1} ... {integer-expression-n} + + + This causes each of the blocks to be executed in turn until one of + them returns a non-zero integer value. The result of this statement + is the integer value returned by the last block executed. For exam- + ple, + + + orelse { 0 } { 6 } { 2 } { 3 } + + + + returns 6 since the second block is the first to return a non-zero + result. The last two block will not get executed. + + The syntax for the andelse statement is: + + andelse {integer-expression-1} ... {integer-expression-n} + + + Each of the blocks will be executed in turn until one of them returns + a zero value. The result of this statement is the integer value + returned by the last block executed. For example, + + + andelse { 6 } { 2 } { 0 } { 4 } + + + + returns 0 since the third block will be the last to execute. + + + 8.3.1.5. switch + + The switch statement deviates the most from its C counterpart. The + syntax is: + + + switch (x) + { ... : ...} + . + . + { ... : ...} + + + + The `:' operator is a special symbol which means to test the top item + on the stack, and if it is non-zero, the rest of the block will get + executed and control will pass out of the switch statement. Other- + wise, the execution of the block will be terminated and the process + will be repeated for the next block. If a block contains no : opera- + tor, the entire block is executed and control will pass onto the next + statement following the switch statement. Such a block is known as + the default case. + + As a simple example, consider the following: + + + switch (x) + { x == 1 : message("Number is one.");} + { x == 2 : message("Number is two.");} + { x == 3 : message("Number is three.");} + { x == 4 : message("Number is four.");} + { x == 5 : message("Number is five.");} + { message ("Number is greater than five.");} + + + + Suppose x has an integer value of 3. The first two blocks will termi- + nate at the `:' character because each of the comparisons with x will + produce zero. However, the third block will execute to completion. + Similarly, if x is 7, only the last block will execute in full. + + A more familiar way to write the previous example used the case + keyword: + + + switch (x) + { case 1 : print("Number is one.");} + { case 2 : print("Number is two.");} + { case 3 : print("Number is three.");} + { case 4 : print("Number is four.");} + { case 5 : print("Number is five.");} + { print ("Number is greater than five.");} + + + + The case keyword is a more useful comparison operator because it can + perform a comparison between different data types while using == may + result in a type-mismatch error. For example, + + + switch (x) + { (x == 1) or (x == "one") : print("Number is one.");} + { (x == 2) or (x == "two") : print("Number is two.");} + { (x == 3) or (x == "three") : print("Number is three.");} + { (x == 4) or (x == "four") : print("Number is four.");} + { (x == 5) or (x == "five") : print("Number is five.");} + { print ("Number is greater than five.");} + + + + will fail because the == operation is not defined between strings and + integers. The correct way to write this to use the case keyword: + + + switch (x) + { case 1 or case "one" : print("Number is one.");} + { case 2 or case "two" : print("Number is two.");} + { case 3 or case "three" : print("Number is three.");} + { case 4 or case "four" : print("Number is four.");} + { case 5 or case "five" : print("Number is five.");} + { print ("Number is greater than five.");} + + + 8.3.2. Looping Forms + + + + 8.3.2.1. while + + The while statement follows the syntax + + while (integer-expression) statement-or-block next-statement + + + It simply causes statement-or-block to get executed as long as inte- + ger-expression evaluates to a non-zero result. For example, + + + i = 10; + while (i) + { + i--; + newline (); + } + + + + will cause the newline function to get called 10 times. However, + + + i = -10; + while (i) + { + i--; + newline (); + } + + + + would loop forever (or until i wraps from the most negative integer + value to the most positive and then decrements to zero). + + + If you are a C programmer, do not let the syntax of the language + seduce you into writing this example as you would in C: + + + i = 10; + while (i--) newline (); + + + + The fact is that expressions such as i-- do not return a value in S- + Lang as they do in C. If you must write this way, use the comma oper- + ator as in + + + i = 10; + while (i, i--) newline (); + + + + 8.3.2.2. do...while + + The do...while statement follows the syntax + + do statement-or-block while (integer-expression); + + + The main difference between this statement and the while statement is + that the do...while form performs the test involving integer-expres- + sion after each execution of statement-or-block rather than before. + This guarantees that statement-or-block will get executed at least + once. + + A simple example from the jed editor follows: + + + bob (); % Move to beginning of buffer + do + { + indent_line (); + } + while (down (1)); + + + + This will cause all lines in the buffer to get indented via the jed + intrinsic function indent_line. + + + 8.3.2.3. for + + Perhaps the most complex looping statement is the for statement; + nevertheless, it is a favorite of many programmers. This statement + obeys the syntax + + for (init-expression; integer-expression; end-expression) statement- + or-block next-statement + + + In addition to statement-or-block, its specification requires three + other expressions. When executed, the for statement evaluates init- + expression, then it tests integer-expression. If integer-expression + returns zero, control passes to next-statement. Otherwise, it exe- + cutes statement-or-block as long as integer-expression evaluates to a + non-zero result. After every execution of statement-or-block, end- + expression will get evaluated. + + This statement is almost equivalent to + + init-expression; while (integer-expression) { statement-or-block end- + expression; } + + + The reason that they are not fully equivalent involves what happens + when statement-or-block contains a continue statement. + + Despite the apparent complexity of the for statement, it is very easy + to use. As an example, consider + + + s = 0; + for (i = 1; i <= 10; i++) s += i; + + + + which computes the sum of the first 10 integers. + + + 8.3.2.4. loop + + The loop statement simply executes a block of code a fixed number of + times. It follows the syntax + + loop (integer-expression) statement-or-block next-statement + + + If the integer-expression evaluates to a positive integer, statement- + or-block will get executed that many times. Otherwise, control will + pass to next-statement. + + For example, + + + loop (10) newline (); + + + + will cause the function newline to get called 10 times. + + + 8.3.2.5. _.ds h for loop + + Like loop, the _for statement simply executes a block of code a fixed + number times. Unlike the loop statement, the _for loop is useful in + situations where the loop index is needed. It obeys the syntax + + _for (first-value, last-value, increment) block next-statement + + + Each time through the loop, the current value of the loop index is + pushed onto the stack. The first time through, the loop index will + have the value of first-value. The second time its value will be + first-value + increment, and so on. The loop will terminate when the + value of the loop index exceeds last-value. The current implementa- + tion requires the control parameters first-value, last-value, and + increment to be integered valued expressions. + + For example, it may be used to compute the sum of the first ten + integers: + + + s = 0; + _for (1, 10, 1) + { + i = (); + s += i; + } + + + + The execution speed of the _for loop is more than twice as fast as the + more powerful for loop making it a better choice for many situations. + + + 8.3.2.6. forever + + The forever statement is similar to the loop statement except that it + loops forever, or until a break or a return statement is executed. It + obeys the syntax + forever statement-or-block + + + A trivial example of this statement is + + + n = 10; + forever + { + if (n == 0) break; + newline (); + n--; + } + + + + 8.3.2.7. foreach + + The foreach statement is used to loop over one or more statements for + every element in a container object. A container object is a data + type that consists of other types. Examples include both ordinary and + associative arrays, structures, and strings. Every time through the + loop the current member of the object is pushed onto the stack. + + The simple type of foreach statement obeys the syntax + + foreach (container-object) statement-or-block + + + Here container-object can be an expression that returns a container + object. A simple example is + + + foreach (["apple", "peach", "pear"]) + { + fruit = (); + process_fruit (fruit); + } + + + + This example shows that if the container object is an array, then suc- + cessive elements of the array are pushed onto the stack prior to each + execution cycle. If the container object is a string, then successive + characters of the string are pushed onto the stack. + + What actually gets pushed onto the stack may be controlled via the + using form of the foreach statement. This more complex type of + foreach statement follows the syntax + + foreach ( container-object ) using ( control-list ) statement-or-block + + + The allowed values of control-list will depend upon the type of con- + tainer object. For associative arrays (Assoc_Type), control-list + specified whether keys, values, or both are pushed onto the stack. + For example, + + + + foreach (a) using ("keys") + { + k = (); + . + . + } + + + + results in the keys of the associative array a being pushed on the + list. However, + + + foreach (a) using ("values") + { + v = (); + . + . + } + + + + will cause the values to be used, and + + + foreach (a) using ("keys", "values") + { + (k,v) = (); + . + . + } + + + + will use both the keys and values of the array. + + Similarly, for linked-lists of structures, one may walk the list via + code like + + + foreach (linked_list) using ("next") + { + s = (); + . + . + } + + + + This foreach statement is equivalent + + + s = linked_list; + while (s != NULL) + { + . + . + s = s.next; + } + + + + Consult the type-specific documentation for a discussion of the using + control words, if any, appropriate for a given type. + + + 8.4. break, return, continue + + + S-Lang also includes the non-local transfer functions return, break, + and continue. The return statement causes control to return to the + calling function while the break and continue statements are used in + the context of loop structures. Consider: + + + define fun () + { + forever + { + s1; + s2; + .. + if (condition_1) break; + if (condition_2) return; + if (condition_3) continue; + .. + s3; + } + s4; + .. + } + + + + Here, a function fun has been defined that contains a forever loop + consisting of statements s1, s2,...,s3, and three if statements. As + long as the expressions condition_1, condition_2, and condition_3 + evaluate to zero, the statements s1, s2,...,s3 will be repeatedly exe- + cuted. However, if condition_1 returns a non-zero value, the break + statement will get executed, and control will pass out of the forever + loop to the statement immediately following the loop which in this + case is s4. Similarly, if condition_2 returns a non-zero number, the + return statement will cause control to pass back to the caller of fun. + Finally, the continue statement will cause control to pass back to the + start of the loop, skipping the statement s3 altogether. + + + + 9. Functions + + + + A function may be thought of as a group of statements that work + together to perform a computation. While there are no imposed limits + upon the number statements that may occur within a function, it is + considered poor programming practice if a function contains many + statements. This notion stems from the belief that a function should + have a simple, well defined purpose. + + + 9.1. Declaring Functions + + + + Like variables, functions must be declared before they can be used. + The define keyword is used for this purpose. For example, + + + define factorial (); + + + + is sufficient to declare a function named factorial. Unlike the vari- + able keyword used for declaring variables, the define keyword does not + accept a list of names. + + Usually, the above form is used only for recursive functions. In most + cases, the function name is almost always followed by a parameter list + and the body of the function: + + define function-name (parameter-list) { statement-list } + + + The function-name is an identifier and must conform to the naming + scheme for identifiers discussed in chapter ???. The parameter-list + is a comma-separated list of variable names that represent parameters + passed to the function, and may be empty if no parameters are to be + passed. The body of the function is enclosed in braces and consists + of zero or more statements (statement-list). + + The variables in the parameter-list are implicitly declared, thus, + there is no need to declare them via a variable declaration statement. + In fact any attempt to do so will result in a syntax error. + + + + 9.2. Parameter Passing Mechanism + + + + Parameters to a function are always passed by value and never by + reference. To see what this means, consider + + + define add_10 (a) + { + a = a + 10; + } + variable b = 0; + add_10 (b); + + + Here a function add_10 has been defined, which when executed, adds 10 + to its parameter. A variable b has also been declared and initialized + to zero before it is passed to add_10. What will be the value of b + after the call to add_10? If S-Lang were a language that passed + parameters by reference, the value of b would be changed to 10. How- + ever, S-Lang always passes by value, which means that b would retain + its value of zero after the function call. + + S-Lang does provide a mechanism for simulating pass by reference via + the reference operator. See the next section for more details. + + If a function is called with a parameter in the parameter list + omitted, the corresponding variable in the function will be set to + NULL. To make this clear, consider the function + + + define add_two_numbers (a, b) + { + if (a == NULL) a = 0; + if (b == NULL) b = 0; + return a + b; + } + + + + This function must be called with two parameters. However, we can + omit one or both of the parameters by calling it in one of the follow- + ing ways: + + + variable s = add_two_numbers (2,3); + variable s = add_two_numbers (2,); + variable s = add_two_numbers (,3); + variable s = add_two_numbers (,); + + + + The first example calls the function using both parameters; however, + at least one of the parameters was omitted in the other examples. The + interpreter will implicitly convert the last three examples to + + + variable s = add_two_numbers (2, NULL); + variable s = add_two_numbers (NULL, 3); + variable s = add_two_numbers (NULL, NULL); + + + + It is important to note that this mechanism is available only for + function calls that specify more than one parameter. That is, + + + variable s = add_10 (); + + + + is not equivalent to add_10(NULL). The reason for this is simple: the + parser can only tell whether or not NULL should be substituted by + looking at the position of the comma character in the parameter list, + and only function calls that indicate more than one parameter will use + a comma. A mechanism for handling single parameter function calls is + described in the next section. + 9.3. Referencing Variables + + + + One can achieve the effect of passing by reference by using the + reference (&) and dereference (@) operators. Consider again the add_10 + function presented in the previous section. This time we write it as + + + define add_10 (a) + { + @a = @a + 10; + } + variable b = 0; + add_10 (&b); + + + + The expression &b creates a reference to the variable b and it is the + reference that gets passed to add_10. When the function add_10 is + called, the value of a will be a reference to b. It is only by deref- + erencing this value that b can be accessed and changed. So, the + statement @a=@a+10; should be read `add 10' to the value of the object + that a references and assign the result to the object that a refer- + ences. + + The reader familiar with C will note the similarity between references + in S-Lang and pointers in C. + + One of the main purposes for references is that this mechanism allows + reference to functions to be passed to other functions. As a simple + example from elementary calculus, consider the following function + which returns an approximation to the derivative of another function + at a specified point: + + + define derivative (f, x) + { + variable h = 1e-6; + return ((@f)(x+h) - (@f)(x)) / h; + } + + + + It can be used to differentiate the function + + + define x_squared (x) + { + return x^2; + } + + + + at the point x = 3 via the expression derivative(&x_squared,3). + + + + 9.4. Functions with a Variable Number of Arguments + + + + S-Lang functions may be defined to take a variable number of + arguments. The reason for this is that the calling routine pushes the + arguments onto the stack before making a function call, and it is up + to the called function to pop the values off the stack and make + assignments to the variables in the parameter list. These details + are, for the most part, hidden from the programmer. However, they are + important when a variable number of arguments are passed. + + Consider the add_10 example presented earlier. This time it is + written + + + define add_10 () + { + variable x; + x = (); + return x + 10; + } + variable s = add_10 (12); % ==> s = 22; + + + + For the uninitiated, this example looks as if it is destined for dis- + aster. The add_10 function looks like it accepts zero arguments, yet + it was called with a single argument. On top of that, the assignment + to x looks strange. The truth is, the code presented in this example + makes perfect sense, once you realize what is happening. + + First, consider what happened when add_10 is called with the the + parameter 12. Internally, 12 is pushed onto the stack and then the + function called. Now, consider the function itself. x is a variable + local to the function. The strange looking assignment `x=()' simply + takes whatever is on the stack and assigns it to x. In other words, + after this statement, the value of x will be 12, since 12 will be at + the top of the stack. + + A generic function of the form + + + define function_name (x, y, ..., z) + { + . + . + } + + + + is internally transformed by the interpreter to + + + + define function_name () + { + variable x, y, ..., z; + z = (); + . + . + y = (); + x = (); + . + . + } + + + + before further parsing. (The add_10 function, as defined above, is + already in this form.) With this knowledge in hand, one can write a + function that accepts a variable number of arguments. Consider the + function: + + + define average_n (n) + { + variable x, y; + variable s; + + if (n == 1) + { + x = (); + s = x; + } + else if (n == 2) + { + y = (); + x = (); + s = x + y; + } + else error ("average_n: only one or two values supported"); + + return s / n; + } + variable ave1 = average_n (3.0, 1); % ==> 3.0 + variable ave2 = average_n (3.0, 5.0, 2); % ==> 4.0 + + + + Here, the last argument passed to average_n is an integer reflecting + the number of quantities to be averaged. Although this example works + fine, its principal limitation is obvious: it only supports one or two + values. Extending it to three or more values by adding more else if + constructs is rather straightforward but hardly worth the effort. + There must be a better way, and there is: + + + + define average_n (n) + { + variable s, x; + s = 0; + loop (n) + { + x = (); % get next value from stack + s += x; + } + return s / n; + } + + + + The principal limitation of this approach is that one must still pass + an integer that specifies how many values are to be averaged. + + Fortunately, a special variable exists that is local to every function + and contains the number of values that were passed to the function. + That variable has the name _NARGS and may be used as follows: + + + define average_n () + { + variable x, s = 0; + + if (_NARGS == 0) error ("Usage: ave = average_n (x, ...);"); + + loop (_NARGS) + { + x = (); + s += x; + } + return s / _NARGS; + } + + + + Here, if no arguments are passed to the function, a simple message + that indicates how it is to be used is printed out. + + + + 9.5. Returning Values + + + As stated earlier, the usual way to return values from a function is + via the return statement. This statement has the simple syntax + + return expression-list ; + + + where expression-list is a comma separated list of expressions. If + the function does not return any values, the expression list will be + empty. As an example of a function that can return multiple values, + consider + + + + define sum_and_diff (x, y) + { + variable sum, diff; + + sum = x + y; diff = x - y; + return sum, diff; + } + + + + which is a function returning two values. + + It is extremely important to note that the calling routine must + explicitly handle all values returned by a function. Although some + languages such as C do not have this restriction, S-Lang does and it + is a direct result of a S-Lang function's ability to return many + values and accept a variable number of parameters. Examples of + properly handling the above function include + + + variable s, d; + (s, d) = sum_and_diff (5, 4); % ignore neither + (s,) = sum_and_diff (5, 4); % ignore diff + (,) = sum_and_diff (5, 4); % ignore both sum and diff + + + + See the section below on assignment statements for more information + about this important point. + + + 9.6. Multiple Assignment Statement + + + + S-Lang functions can return more than one value, e.g., + + + define sum_and_diff (x, y) + { + return x + y, x - y; + } + + + + returns two values. It accomplishes this by placing both values on + the stack before returning. If you understand how S-Lang functions + handle a variable number of parameters (section ???), then it should + be rather obvious that one assigns such values to variables. One way + is to use, e.g., + + + sum_and_diff (9, 4); + d = (); + s = (); + + + + However, the most convenient way to accomplish this is to use a + multiple assignment statement such as + + + (s, d) = sum_and_diff (9, 4); + + + + The most general form of the multiple assignment statement is + + + ( var_1, var_2, ..., var_n ) = expression; + + + + In fact, internally the interpreter transforms this statement into the + form + + + expression; var_n = (); ... var_2 = (); var_1 = (); + + + + for further processing. + + If you do not care about one of return values, simply omit the + variable name from the list. For example, + + + (s, ) = sum_and_diff (9, 4); + + + + assigns the sum of 9 and 4 to s and the difference (9-4) will be + removed from the stack. + + As another example, the jed editor provides a function called down + that takes an integer argument and returns an integer. It is used to + move the current editing position down the number of lines specified + by the argument passed to it. It returns the number of lines it + successfully moved the editing position. Often one does not care + about the return value from this function. Although it is always + possible to handle the return value via + + + variable dummy = down (10); + + + + it is more convenient to use a multiple assignment expression and omit + the variable name, e.g., + + + () = down (10); + + + + Some functions return a variable number of values instead of a fixed + number. Usually, the value at the top of the stack will indicate the + actual number of return values. For such functions, the multiple + assignment statement cannot directly be used. To see how such + functions can be dealt with, consider the following function: + + + define read_line (fp) + { + variable line; + if (-1 == fgets (&line, fp)) + return -1; + return (line, 0); + } + + + + This function returns either one or two values, depending upon the + return value of fgets. Such a function may be handled as in the fol- + lowing example: + + + status = read_line (fp); + if (status != -1) + { + s = (); + . + . + } + + + + In this example, the last value returned by read_line is assigned to + status and then tested. If it is non-zero, the second return value is + assigned to s. In particular note the empty set of parenthesis in the + assignment to s. This simply indicates that whatever is on the top of + the stack when the statement is executed will be assigned to s. + + Before leaving this section it is important to reiterate the fact that + if a function returns a value, the caller must deal with that return + value. Otherwise, the value will continue to live onto the stack and + may eventually lead to a stack overflow error. Failing to handle the + return value of a function is the most common mistake that + inexperienced S-Lang programmers make. For example, the fflush + function returns a value that many C programmer's never check. + Instead of writing + + + fflush (fp); + + + + as one could in C, a S-Lang programmer should write + + + () = fflush (fp); + + + + in S-Lang. (Many good C programmer's write (void)fflush(fp) to indi- + cate that the return value is being ignored). + + + + 9.7. Exit-Blocks + + + + An exit-block is a set of statements that get executed when a + functions returns. They are very useful for cleaning up when a + function returns via an explicit call to return from deep within a + function. + + An exit-block is created by using the EXIT_BLOCK keyword according to + the syntax + + EXIT_BLOCK { statement-list } + + + where statement-list represents the list of statements that comprise + the exit-block. The following example illustrates the use of an exit- + block: + + + define simple_demo () + { + variable n = 0; + + EXIT_BLOCK { message ("Exit block called."); } + + forever + { + if (n == 10) return; + n++; + } + } + + + + Here, the function contains an exit-block and a forever loop. The + loop will terminate via the return statement when n is 10. Before it + returns, the exit-block will get executed. + + A function can contain multiple exit-blocks, but only the last one + encountered during execution will actually get executed. For example, + + + define simple_demo (n) + { + EXIT_BLOCK { return 1; } + + if (n != 1) + { + EXIT_BLOCK { return 2; } + } + return; + } + + + + If 1 is passed to this function, the first exit-block will get exe- + cuted because the second one would not have been encountered during + the execution. However, if some other value is passed, the second + exit-block would get executed. This example also illustrates that it + is possible to explicitly return from an exit-block, although nested + exit-blocks are illegal. + + + + 10. Name Spaces + + + + By default, all global variables and functions are defined in the + global namespace. In addition to the global namespace, every + compilation unit (e.g., a file containing S-Lang code) has an + anonymous namespace. Objects may be defined in the anonymous + namespace via the static declaration keyword. For example, + + + static variable x; + static define hello () { message ("hello"); } + + + + defines a variable x and a function hello in the anonymous namespace. + This is useful when one wants to define functions and variables that + are only to be used within the file, or more precisely the compilation + unit, that defines them. + + The implements function may be used to give the anonymous namespace a + name to allow access to its objects from outside the compilation unit + that defines them. For example, + + + implements ("foo"); + static variable x; + + + + allows the variable x to be accessed via foo->x, e.g., + + + if (foo->x == 1) foo->x = 2; + + + + The implements function does more than simply giving the anonymous + namespace a name. It also changes the default variable and function + declaration mode from public to static. That is, + + + implements ("foo"); + variable x; + + + + and + + + implements ("foo"); + static variable x; + + + + are equivalent. Then to create a public object within the namespace, + one must explicitly use the public keyword. + + Finally, the private keyword may be used to create an object that is + truly private within the compilation unit. For example, + implements ("foo"); + variable x; + private variable y; + + + + allows x to be accessed from outside the namespace via foo->x, however + y cannot be accessed. + + + + 11. Arrays + + + + An array is a container object that can contain many values of one + data type. Arrays are very useful objects and are indispensable for + certain types of programming. The purpose of this chapter is to + describe how arrays are defined and used in the S-Lang language. + + + 11.1. Creating Arrays + + + + The S-Lang language supports multi-dimensional arrays of all data + types. Since the Array_Type is a data type, one can even have arrays + of arrays. To create a multi-dimensional array of SomeType use the + syntax + + + SomeType [dim0, dim1, ..., dimN] + + + + Here dim0, dim1, ... dimN specify the size of the individual dimen- + sions of the array. The current implementation permits arrays consist + of up to 7 dimensions. When a numeric array is created, all its ele- + ments are initialized to zero. The initialization of other array + types depend upon the data type, e.g., String_Type and Struct_Type + arrays are initialized to NULL. + + As a concrete example, consider + + + a = Integer_Type [10]; + + + + which creates a one-dimensional array of 10 integers and assigns it to + a. Similarly, + + + b = Double_Type [10, 3]; + + + + creates a 30 element array of double precision numbers arranged in 10 + rows and 3 columns, and assigns it to b. + + + 11.1.1. Range Arrays + + + There is a more convenient syntax for creating and initializing a 1-d + arrays. For example, to create an array of ten integers whose + elements run from 1 through 10, one may simply use: + + + a = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]; + + + + Similarly, + + + b = [1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0, 10.0]; + + + + specifies an array of ten doubles. + + An even more compact way of specifying a numeric array is to use a + range-array. For example, + + + a = [0:9]; + + + + specifies an array of 10 integers whose elements range from 0 through + 9. The most general form of a range array is + + + [first-value : last-value : increment] + + + + where the increment is optional and defaults to 1. This creates an + array whose first element is first-value and whose successive values + differ by increment. last-value sets an upper limit upon the last + value of the array as described below. + + If the range array [a:b:c] is integer valued, then the interval + specified by a and b is closed. That is, the kth element of the array + x_k is given by x_k=a+ck and must satisfy a<=x_k<=b. Hence, the + number of elements in an integer range array is given by the + expression 1 + (b-a)/c. + + The situation is somewhat more complicated for floating point range + arrays. The interval specified by a floating point range array + [a:b:c] is semi-open such that b is not contained in the interval. In + particular, the kth element of [a:b:c] is given by x_k=a+kc such that + a<=x_k=0, and b [1,2,3,4,5] + [1.0:5.0:1.0] ==> [1.0, 2.0, 3.0, 4.0] + [5:1:-1] ==> [5,4,3,2,1] + [5.0:1.0:-1.0] ==> [5.0, 4.0, 3.0, 2.0]; + [1:1] ==> [1] + [1.0:1.0] ==> [] + [1:-3] ==> [] + + + + 11.1.2. Creating arrays via the dereference operator + + + + Another way to create an array is apply the dereference operator @ to + the DataType_Type literal Array_Type. The actual syntax for this + operation resembles a function call + + variable a = @Array_Type (data-type, integer-array); + + + where data-type is of type DataType_Type and integer-array is a 1-d + array of integers that specify the size of each dimension. For exam- + ple, + + + variable a = @Array_Type (Double_Type, [10, 20]); + + + + will create a 10 by 20 array of doubles and assign it to a. This + method of creating arrays derives its power from the fact that it is + more flexible than the methods discussed in this section. We shall + encounter it again in section ??? in the context of the array_info + function. + + + + 11.2. Reshaping Arrays + + + It is sometimes possible to change the `shape' of an array using the + reshape function. For example, a 1-d 10 element array may be reshaped + into a 2-d array consisting of 5 rows and 2 columns. The only + restriction on the operation is that the arrays must be commensurate. + The reshape function follows the syntax + + reshape (array-name, integer-array); + + + where array-name specifies the array to be reshaped to have the dimen- + sions given by integer-array, a 1-dimensional array of integers. It + is important to note that this does not create a new array, it simply + reshapes the existing array. Thus, + + + variable a = Double_Type [100]; + reshape (a, [10, 10]); + + + + turns a into a 10 by 10 array. + + + + 11.3. Indexing Arrays + + + An individual element of an array may be referred to by its index. + For example, a[0] specifies the zeroth element of the one dimensional + array a, and b[3,2] specifies the element in the third row and second + column of the two dimensional array b. As in C array indices are + numbered from 0. Thus if a is a one-dimensional array of ten + integers, the last element of the array is given by a[9]. Using a[10] + would result in a range error. + + A negative index may be used to index from the end of the array, with + a[-1] referring to the last element of a, a[-2] referring to the next + to the last element, and so on. + + One may use the indexed value like any other variable. For example, + to set the third element of an integer array to 6, use + + + a[2] = 6; + + + + Similarly, that element may be used in an expression, such as + + + y = a[2] + 7; + + + + Unlike other S-Lang variables which inherit a type upon assignment, + array elements already have a type. For example, an attempt to assign + a string value to an element of an integer array will result in a + type-mismatch error. + + One may use any integer expression to index an array. A simple + example that computes the sum of the elements of 10 element 1-d array + is + + + variable i, s; + s = 0; + for (i = 0; i < 10; i++) s += a[i]; + + + + However, if the built-in sum function is available (not all programs + using S-Lang support this), then it should be used to compute the sum + of an array, e.g., + + + s = sum(a); + + + + Unlike many other languages, S-Lang permits arrays to be indexed by + other integer arrays. Suppose that a is a 1-d array of 10 doubles. + Now consider: + + + i = [6:8]; + b = a[i]; + + + + Here, i is a 1-dimensional range array of three integers with i[0] + equal to 6, i[1] equal to 7, and i[2] equal to 8. The statement b = + a[i]; will create a 1-d array of three doubles and assign it to b. + The zeroth element of b, b[0] will be set to the sixth element of a, + or a[6], and so on. In fact, these two simple statements are equiva- + lent to + + b = Double_Type [3]; + b[0] = a[6]; + b[1] = a[7]; + b[2] = a[8]; + + + + except that using an array of indices is not only much more conve- + nient, but executes much faster. + + More generally, one may use an index array to specify which elements + are to participate in a calculation. For example, consider + + + a = Double_Type [1000]; + i = [0:499]; + j = [500:999]; + a[i] = -1.0; + a[j] = 1.0; + + + + This creates an array of 1000 doubles and sets the first 500 elements + to -1.0 and the last 500 to 1.0. Actually, one may do away with the i + and j variables altogether and use + + + a = Double_Type [1000]; + a [[0:499]] = -1.0; + a [[500:999]] = 1.0; + + + + It is important to understand the syntax used and, in particular, to + note that a[[0:499]] is not the same as a[0:499]. In fact, the latter + will generate a syntax error. + + Often, it is convenient to use a rubber range to specify indices. For + example, a[[500:]] specifies all elements of a whose index is greater + than or equal to 500. Similarly, a[[:499]] specifies the first 500 + elements of a. Finally, a[[:]] specifies all the elements of a; + however, using a[*] is more convenient. + + One should be careful when using index arrays with negative elements. + As pointed out above, a negative index is used to index from the end + of the array. That is, a[-1] refers to the last element of a. How + should a[[[0:-1]] be interpreted? By itself, [0:-1] is an empty + array; hence, one might expect a[[0:-1]] to refer to no elements. + However, when used in an array indexing context, [0:-1] is interpreted + as an array indexing the first through the last elements of the array. + While this is a very convenient mechanism to specifiy the last 3 + elements of an array using a[[-3:-1]], it is very easy to forget these + semantics. + + Now consider a multi-dimensional array. For simplicity, suppose that + a is a 100 by 100 array of doubles. Then the expression a[0, *] + specifies all elements in the zeroth row. Similarly, a[*, 7] + specifies all elements in the seventh column. Finally, a[[3:5][6:12]] + specifies the 3 by 7 region consisting of rows 3, 4, and 5, and + columns 6 through 12 of a. + + We conclude this section with a few examples. + + Here is a function that computes the trace (sum of the diagonal + elements) of a square 2 dimensional n by n array: + + + define array_trace (a, n) + { + variable s = 0, i; + for (i = 0; i < n; i++) s += a[i, i]; + return s; + } + + + + This fragment creates a 10 by 10 integer array, sets its diagonal ele- + ments to 5, and then computes the trace of the array: + + + a = Integer_Type [10, 10]; + for (j = 0; j < 10; j++) a[j, j] = 5; + the_trace = array_trace(a, 10); + + + + We can get rid of the for loop as follows: + + + j = Integer_Type [10, 2]; + j[*,0] = [0:9]; + j[*,1] = [0:9]; + a[j] = 5; + + + + Here, the goal was to construct a 2-d array of indices that correspond + to the diagonal elements of a, and then use that array to index a. To + understand how this works, consider the middle statements. They are + equivalent to the following for loops: + + + variable i; + for (i = 0; i < 10; i++) j[i, 0] = i; + for (i = 0; i < 10; i++) j[i, 1] = i; + + + + Thus, row n of j will have the value (n,n), which is precisely what + was sought. + + Another example of this technique is the function: + + + define unit_matrix (n) + { + variable a = Integer_Type [n, n]; + variable j = Integer_Type [n, 2]; + j[*,0] = [0:n - 1]; + j[*,1] = [0:n - 1]; + + a[j] = 1; + return a; + } + + This function creates an n by n unit matrix, that is a 2-d n by n + array whose elements are all zero except on the diagonal where they + have a value of 1. + + + + 11.4. Arrays and Variables + + + When an array is created and assigned to a variable, the interpreter + allocates the proper amount of space for the array, initializes it, + and then assigns to the variable a reference to the array. So, a + variable that represents an array has a value that is really a + reference to the array. This has several consequences, some good and + some bad. It is believed that the advantages of this representation + outweigh the disadvantages. First, we shall look at the positive + aspects. + + When a variable is passed to a function, it is always the value of the + variable that gets passed. Since the value of a variable representing + an array is a reference, a reference to the array gets passed. One + major advantage of this is rather obvious: it is a fast and efficient + way to pass the array. This also has another consequence that is + illustrated by the function + + + define init_array (a, n) + { + variable i; + + for (i = 0; i < n; i++) a[i] = some_function (i); + } + + + + where some_function is a function that generates a scalar value to + initialize the ith element. This function can be used in the follow- + ing way: + + + variable X = Double_Type [100000]; + init_array (X, 100000); + + + + Since the array is passed to the function by reference, there is no + need to make a separate copy of the 100000 element array. As pointed + out above, this saves both execution time and memory. The other + salient feature to note is that any changes made to the elements of + the array within the function will be manifested in the array outside + the function. Of course, in this case, this is a desirable side- + effect. + + To see the downside of this representation, consider: + + + variable a, b; + a = Double_Type [10]; + b = a; + a[0] = 7; + + + What will be the value of b[0]? Since the value of a is really a ref- + erence to the array of ten doubles, and that reference was assigned to + b, b also refers to the same array. Thus any changes made to the ele- + ments of a, will also be made implicitly to b. + + This begs the question: If the assignment of one variable which + represents an array, to another variable results in the assignment of + a reference to the array, then how does one make separate copies of + the array? There are several answers including using an index array, + e.g., b = a[*]; however, the most natural method is to use the + dereference operator: + + + variable a, b; + a = Double_Type [10]; + b = @a; + a[0] = 7; + + + + In this example, a separate copy of a will be created and assigned to + b. It is very important to note that S-Lang never implicitly derefer- + ences an object. So, one must explicitly use the dereference opera- + tor. This means that the elements of a dereferenced array are not + themselves dereferenced. For example, consider dereferencing an array + of arrays, e.g., + + + variable a, b; + a = Array_Type [2]; + a[0] = Double_Type [10]; + a[1] = Double_Type [10]; + b = @a; + + + + In this example, b[0] will be a reference to the array that a[0] ref- + erences because a[0] was not explicitly dereferenced. + + + 11.5. Using Arrays in Computations + + + + Many functions and operations work transparently with arrays. For + example, if a and b are arrays, then the sum a + b is an array whose + elements are formed from the sum of the corresponding elements of a + and b. A similar statement holds for all other binary and unary + operations. + + Let's consider a simple example. Suppose, that we wish to solve a set + of n quadratic equations whose coefficients are given by the 1-d + arrays a, b, and c. In general, the solution of a quadratic equation + will be two complex numbers. For simplicity, suppose that all we + really want is to know what subset of the coefficients, a, b, c, + correspond to real-valued solutions. In terms of for loops, we can + write: + + + + variable i, d, index_array; + index_array = Integer_Type [n]; + for (i = 0; i < n; i++) + { + d = b[i]^2 - 4 * a[i] * c[i]; + index_array [i] = (d >= 0.0); + } + + + + In this example, the array index_array will contain a non-zero value + if the corresponding set of coefficients has a real-valued solution. + This code may be written much more compactly and with more clarity as + follows: + + + variable index_array = ((b^2 - 4 * a * c) >= 0.0); + + + + S-Lang has a powerful built-in function called where. This function + takes an array of integers and returns a 2-d array of indices that + correspond to where the elements of the input array are non-zero. + This simple operation is extremely useful. For example, suppose a is a + 1-d array of n doubles, and it is desired to set to zero all elements + of the array whose value is less than zero. One way is to use a for + loop: + + + for (i = 0; i < n; i++) + if (a[i] < 0.0) a[i] = 0.0; + + + + If n is a large number, this statement can take some time to execute. + The optimal way to achieve the same result is to use the where func- + tion: + + + a[where (a < 0.0)] = 0; + + + + Here, the expression (a < 0.0) returns an array whose dimensions are + the same size as a but whose elements are either 1 or 0, according to + whether or not the corresponding element of a is less than zero. This + array of zeros and ones is then passed to where which returns a 2-d + integer array of indices that indicate where the elements of a are + less than zero. Finally, those elements of a are set to zero. + + As a final example, consider once more the example involving the set + of n quadratic equations presented above. Suppose that we wish to get + rid of the coefficients of the previous example that generated non- + real solutions. Using an explicit for loop requires code such as: + + + + variable i, j, nn, tmp_a, tmp_b, tmp_c; + + nn = 0; + for (i = 0; i < n; i++) + if (index_array [i]) nn++; + + tmp_a = Double_Type [nn]; + tmp_b = Double_Type [nn]; + tmp_c = Double_Type [nn]; + + j = 0; + for (i = 0; i < n; i++) + { + if (index_array [i]) + { + tmp_a [j] = a[i]; + tmp_b [j] = b[i]; + tmp_c [j] = c[i]; + j++; + } + } + a = tmp_a; + b = tmp_b; + c = tmp_c; + + + + Not only is this a lot of code, it is also clumsy and error-prone. + Using the where function, this task is trivial: + + + variable i; + i = where (index_array != 0); + a = a[i]; + b = b[i]; + c = c[i]; + + + + All the examples up to now assumed that the dimensions of the array + were known. Although the intrinsic function length may be used to get + the total number of elements of an array, it cannot be used to get the + individual dimensions of a multi-dimensional array. However, the + function array_info may be used to get information about an array, + such as its data type and size. The function returns three values: + the data type, the number of dimensions, and an integer array + containing the size of each dimension. It may be used to determine + the number of rows of an array as follows: + + + define num_rows (a) + { + variable dims, type, num_dims; + + (dims, num_dims, type) = array_info (a); + return dims[0]; + } + + + + The number of columns may be obtained in a similar manner: + + + define num_cols (a) + { + variable dims, type, num_dims; + + (dims, num_dims, type) = array_info (a); + if (num_dims > 1) return dims[1]; + return 1; + } + + + + Another use of array_info is to create an array that has the same + number of dimensions as another array: + + + define make_int_array (a) + { + variable dims, num_dims, type; + + (dims, num_dims, type) = array_info (a); + return @Array_Type (Integer_Type, dims); + } + + + + 12. Associative Arrays + + + + An associative array differs from an ordinary array in the sense that + its size is not fixed and that is indexed by a string, called the key. + For example, consider: + + + variable A = Assoc_Type [Integer_Type]; + A["alpha"] = 1; + A["beta"] = 2; + A["gamma"] = 3; + + + + Here, A represents an associative array of integers (Integer_Type) and + three keys have been added to the array. + + As the example suggests, an associative array may be created using one + of the following forms: + + Assoc_Type [type] Assoc_Type [type, default-value] Assoc_Type [] + + + The last form returns an associative array of Any_Type objects allow- + ing any type of object to may be stored in the array. + + The form involving a default-value is useful for associating a default + value for non-existent array members. This feature is explained in + more detail below. + + There are several functions that are specially designed to work with + associative arrays. These include: + + o assoc_get_keys, which returns an ordinary array of strings + containing the keys in the array. + + + o assoc_get_values, which returns an ordinary array of the values of + the associative array. + + + o assoc_key_exists, which can be used to determine whether or not a + key exists in the array. + + o assoc_delete_key, which may be used to remove a key (and its value) + from the array. + + To illustrate the use of an associative array, consider the problem of + counting the number of repeated occurrences of words in a list. Let + the word list be represented as an array of strings given by + word_list. The number of occurrences of each word may be stored in an + associative array as follows: + + + + variable a, word; + a = Assoc_Type [Integer_Type]; + foreach (word_list) + { + word = (); + if (0 == assoc_key_exists (a, word)) + a[word] = 0; + a[word]++; % same as a[word] = a[word] + 1; + } + + + + Note that assoc_key_exists was necessary to determine whether or not a + word was already added to the array in order to properly initialize + it. However, by creating the associative array with a default value + of 0, the above code may be simplified to + + + variable a, word; + a = Assoc_Type [Integer_Type, 0]; + foreach (word_list) + { + word = (); + a[word]++; + } + + + + 13. Structures and User-Defined Types + + + + A structure is a heterogeneous container object, i.e., it is an object + with elements whose values do not have to be of the same data type. + The elements or fields of a structure are named, and one accesses a + particular field of the structure via the field name. This should be + contrasted with an array whose values are of the same type, and whose + elements are accessed via array indices. + + A user-defined data type is a structure with a fixed set of fields + defined by the user. + + + 13.1. Defining a Structure + + + The struct keyword is used to define a structure. The syntax for this + operation is: + + struct {field-name-1, field-name-2, ... field-name-N}; + + + This creates and returns a structure with N fields whose names are + specified by field-name-1, field-name-2, ..., field-name-N. When a + structure is created, all its fields are initialized to NULL. + + For example, + + + variable t = struct { city_name, population, next }; + + + + creates a structure with three fields and assigns it to the variable + t. + + Alternatively, a structure may be created by dereferencing + Struct_Type. For example, the above structure may also be created + using one of the two forms: + + + t = @Struct_Type ("city_name", "population", "next"); + t = @Struct_Type (["city_name", "population", "next"]); + + + + These are useful when creating structures dynamically where one does + not know the name of the fields until run-time. + + Like arrays, structures are passed around via a references. Thus, in + the above example, the value of t is a reference to the structure. + This means that after execution of + + + variable u = t; + + + + both t and u refer to the same structure, since only the reference was + used in the assignment. To actually create a new copy of the struc- + ture, use the dereference operator, e.g., + variable u = @t; + + + + 13.2. Accessing the Fields of a Structure + + + The dot (.) operator is used to specify the particular field of + structure. If s is a structure and field_name is a field of the + structure, then s.field_name specifies that field of s. This + specification can be used in expressions just like ordinary variables. + Again, consider + + + variable t = struct { city_name, population, next }; + + + + described in the last section. Then, + + + t.city_name = "New York"; + t.population = 13000000; + if (t.population > 200) t = t.next; + + + + are all valid statements involving the fields of t. + + + 13.3. Linked Lists + + + One of the most important uses of structures is to create a dynamic + data structure such as a linked-list. A linked-list is simply a chain + of structures that are linked together such that one structure in the + chain is the value of a field of the previous structure in the chain. + To be concrete, consider the structure discussed earlier: + + + variable t = struct { city_name, population, next }; + + + + and suppose that we desire to create a list of such structures. The + purpose of the next field is to provide the link to the next structure + in the chain. Suppose that there exists a function, read_next_city, + that reads city names and populations from a file. Then we can create + the list via: + + + + define create_population_list () + { + variable city_name, population, list_root, list_tail; + variable next; + + list_root = NULL; + while (read_next_city (&city_name, &population)) + { + next = struct {city_name, population, next }; + + next.city_name = city_name; + next.population = population; + next.next = NULL; + + if (list_root == NULL) + list_root = next; + else + list_tail.next = next; + + list_tail = next; + } + return list_root; + } + + + + In this function, the variables list_root and list_tail represent the + beginning and end of the list, respectively. As long as read_next_city + returns a non-zero value, a new structure is created, initialized, and + then appended to the list via the next field of the list_tail struc- + ture. On the first time through the loop, the list is created via the + assignment to the list_root variable. + + This function may be used as follows: + + + variable Population_List = create_population_list (); + if (Population_List == NULL) error ("List is empty"); + + + + We can create other functions that manipulate the list. An example is + a function that finds the city with the largest population: + + + define get_largest_city (list) + { + variable largest; + + largest = list; + while (list != NULL) + { + if (list.population > largest.population) + largest = list; + list = list.next; + } + return largest.city_name; + } + + vmessage ("%s is the largest city in the list", + get_largest_city (Population_List))); + + + + The get_largest_city is a typical example of how one traverses a lin- + ear linked-list by starting at the head of the list and successively + moves to the next element of the list via the next field. + + In the previous example, a while loop was used to traverse the linked + list. It is faster to use a foreach loop for this: + + + define get_largest_city (list) + { + variable largest, elem; + + largest = list; + foreach (list) + { + elem = (); + if (item.population > largest.population) + largest = item; + } + return largest.city_name; + } + + + + Here a foreach loop has been used to walk the list via its next field. + If the field name was not next, then it would have been necessary to + use the using form of the foreach statement. For example, if the + field name implementing the linked list was next_item, then + + + foreach (list) using ("next_item") + { + elem = (); + . + . + } + + + + would have been used. In other words, unless otherwise indicated via + the using clause, foreach walks the list using a field named next. + + Now consider a function that sorts the list according to population. + To illustrate the technique, a bubble-sort will be used, not because + it is efficient, it is not, but because it is simple and intuitive. + + + + define sort_population_list (list) + { + variable changed; + variable node, next_node, last_node; + do + { + changed = 0; + node = list; + next_node = node.next; + last_node = NULL; + while (next_node != NULL) + { + if (node.population < next_node.population) + { + % swap node and next_node + node.next = next_node.next; + next_node.next = node; + if (last_node != NULL) + last_node.next = next_node; + + if (list == node) list = next_node; + node = next_node; + next_node = node.next; + changed++; + } + last_node = node; + node = next_node; + next_node = next_node.next; + } + } + while (changed); + + return list; + } + + + + Note the test for equality between list and node, i.e., + + + if (list == node) list = next_node; + + + + It is important to appreciate the fact that the values of these vari- + ables are references to structures, and that the comparison only com- + pares the references and not the actual structures they reference. If + it were not for this, the algorithm would fail. + + + 13.4. Defining New Types + + + A user-defined data type may be defined using the typedef keyword. In + the current implementation, a user-defined data type is essentially a + structure with a user-defined set of fields. For example, in the + previous section a structure was used to represent a city/population + pair. We can define a data type called Population_Type to represent + the same information: + + + + typedef struct + { + city_name, + population + } Population_Type; + + + + This data type can be used like all other data types. For example, an + array of Population_Type types can be created, + + + variable a = Population_Type[10]; + + + + and `populated' via expressions such as + + + a[0].city_name = "Boston"; + a[0].population = 2500000; + + + + The new type Population_Type may also be used with the typeof func- + tion: + + + if (Population_Type = typeof (a)) city = a.city_name; + + + + The dereference @ may be used to create an instance of the new type: + + + a = @Population_Type; + a.city_name = "Calcutta"; + a.population = 13000000; + + + + 14. Error Handling + + + + Many intrinsic functions signal errors in the event of failure. User + defined functions may also generate an error condition via the error + function. Depending upon the severity of the error, it can be caught + and cleared using a construct called an error-block. + + + 14.1. Error-Blocks + + + When the interpreter encounters a recoverable run-time error, it will + return to top-level by unwinding its function call stack. Any error- + blocks that it encounters as part of this unwinding process will get + executed. Errors such as syntax errors and memory allocation errors + are not recoverable, and error-blocks will not get executed when such + errors are encountered. + + An error-block is defined using the syntax + + + ERROR_BLOCK { statement-list } + + + + where statement-list represents a list of statements that comprise the + error-block. A simple example of an error-block is + + + define simple (a) + { + ERROR_BLOCK { message ("error-block executed"); } + if (a) error ("Triggering Error"); + message ("hello"); + } + + + + Executing this function via simple(0) will result in the message + "hello". However, calling it using simple(1) will generate an error + that will be caught, but not cleared, by the error-block and the + "error-block executed" message will result. + + Error-blocks are never executed unless triggered by an error. The + only exception to this is when the user explicitly indicates that the + error-block in scope should execute. This is indicated by the special + keyword EXECUTE_ERROR_BLOCK. For example, simple could be recoded as + + + define simple (a) + { + variable err_string = "error-block executed"; + ERROR_BLOCK { message (err_string); } + if (a) error ("Triggering Error"); + err_string = "hello"; + EXECUTE_ERROR_BLOCK; + } + + + + Please note that EXECUTE_ERROR_BLOCK does not initiate an error + condition; it simply causes the error-block to be executed and control + will pass onto the next statement following the EXECUTE_ERROR_BLOCK + statement. + + + 14.2. Clearing Errors + + + Once an error has been caught by an error-block, the error can be + cleared by the _clear_error function. After the error has been + cleared, execution will resume at the next statement at the level of + the error block following the statement that generated the error. For + example, consider: + + + define make_error () + { + error ("Error condition created."); + message ("This statement is not executed."); + } + + define test () + { + ERROR_BLOCK + { + _clear_error (); + } + make_error (); + message ("error cleared."); + } + + + + Calling test will trigger an error in the make_error function, but + will get cleared in the test function. The call-stack will unwind + from make_error back into test where the error-block will get exe- + cuted. As a result, execution resumes after the statement that makes + the call to make_error since this statement is at the same level as + the error-block that cleared the error. + + Here is another example that illustrates how multiple error-blocks + work: + + + + define example () + { + variable n = 0, s = ""; + variable str; + + ERROR_BLOCK { + str = sprintf ("s=%s,n=%d", s, n); + _clear_error (); + } + + forever + { + ERROR_BLOCK { + s += "0"; + _clear_error (); + } + + if (n == 0) error (""); + + ERROR_BLOCK { + s += "1"; + } + + if (n == 1) error (""); + n++; + } + return str; + } + + + + Here, three error-blocks have been declared. One has been declared + outside the forever loop and the other two have been declared inside + the forever loop. Each time through the loop, the variable n is + incremented and a different error-block is triggered. The error-block + that gets triggered is the last one encountered, since that will be + the one in scope. On the first time through the loop, n will be zero + and the first error-block in the loop will get executed. This error + block clears the error and execution resumes following the if state- + ment that triggered the error. The variable n will get incremented to + 1 and, on the second cycle through the loop the second if statement + will trigger an error causing the second error-block to execute. This + time, the error is not cleared and the call-stack unwinds out of the + forever loop, at which point the error-block outside the loop is in + scope, causing it to execute. This error-block prints out the values + of the variables s and n. It will clear the error and execution + resumes on the statement following the forever loop. The result of + this complicated series of events is that the function will return the + string "s=01,n=1". + + + + 15. Loading Files: evalfile and autoload + + + + 16. File Input/Output + + + + S-Lang provides built-in supports for two different I/O facilities. + The simplest interface is modeled upon the C language stdio streams + interface and consists of functions such as fopen, fgets, etc. The + other interface is modeled on a lower level POSIX interface consisting + of functions such as open, read, etc. In addition to permitting more + control, the lower level interface permits one to access network + objects as well as disk files. + + + 16.1. Input/Output via stdio + + + 16.1.1. Stdio Overview + + The stdio interface consists of the following functions: + + o fopen, which opens a file for read or writing. + + o fclose, which closes a file opened by fopen. + + o fgets, used to read a line from the file. + + o fputs, which writes text to the file. + + o fprintf, used to write formatted text to the file. + + o fwrite, which may be used to write objects to the file. + + o fread, which reads a specified number of objects from the file. + + o feof, which is used to test whether the file pointer is at the end + of the file. + + o ferror, which is used to see whether or not the stream associated + with the file has an error. + + + o clearerr, which clears the end-of-file and error indicators for the + stream. + + o fflush, used to force all buffered data associated with the stream + to be written out. + + o ftell, which is used to query the file position indicator of the + stream. + + + o fseek, which is used to set the position of the file position + indicator of the stream. + + o fgetslines, which reads all the lines in a text file and returns + them as an array of strings. + + In addition, the interface supports the popen and pclose functions on + systems where the corresponding C functions are available. + + Before reading or writing to a file, it must first be opened using the + fopen function. The only exceptions to this rule involves use of the + pre-opened streams: stdin, stdout, and stderr. fopen accepts two + arguments: a file name and a string argument that indicates how the + file is to be opened, e.g., for reading, writing, update, etc. It + returns a File_Type stream object that is used as an argument to all + other functions of the stdio interface. Upon failure, it returns + NULL. See the reference manual for more information about fopen. + + + 16.1.2. Stdio Examples + + + In this section, some simple examples of the use of the stdio + interface is presented. It is important to realize that all the + functions of the interface return something, and that return value + must be dealt with. + + The first example involves writing a function to count the number of + lines in a text file. To do this, we shall read in the lines, one by + one, and count them: + + + define count_lines_in_file (file) + { + variable fp, line, count; + + fp = fopen (file, "r"); % Open the file for reading + if (fp == NULL) + verror ("%s failed to open", file); + + count = 0; + while (-1 != fgets (&line, fp)) + count++; + + () = fclose (fp); + return count; + } + + + + Note that &line was passed to the fgets function. When fgets returns, + line will contain the line of text read in from the file. Also note + how the return value from fclose was handled. + + Although the preceding example closed the file via fclose, there is no + need to explicitly close a file because S-Lang will automatically + close the file when it is no longer referenced. Since the only + variable to reference the file is fp, it would have automatically been + closed when the function returned. + + Suppose that it is desired to count the number of characters in the + file instead of the number of lines. To do this, the while loop could + be modified to count the characters as follows: + + + while (-1 != fgets (&line, fp)) + count += strlen (line); + + + + The main difficulty with this approach is that it will not work for + binary files, i.e., files that contain null characters. For such + files, the file should be opened in binary mode via + + + fp = fopen (file, "rb"); + + + + and then the data read in using the fread function: + + + while (-1 != fread (&line, Char_Type, 1024, fp)) + count += bstrlen (line); + + + + The fread function requires two additional arguments: the type of + object to read (Char_Type in the case), and the number of such objects + to read. The function returns the number of objects actually read, or + -1 upon failure. The bstrlen function was used to compute the length + of line because for Char_Type or UChar_Type objects, the fread func- + tion assigns a binary string (BString_Type) to line. + + The foreach construct also works with File_Type objects. For example, + the number of characters in a file may be counted via + + + foreach (fp) using ("char") + { + ch = (); + count++; + } + + + + To count the number of lines, one can use: + + + foreach (fp) using ("line") + { + line = (); + num_lines++; + count += strlen (line); + } + + + + Often one is not interested in trailing whitespace in the lines of a + file. To have trailing whitespace automatically stripped from the + lines as they are read in, use the "wsline" form, e.g., + + + foreach (fp) using ("wsline") + { + line = (); + . + . + } + + + + Finally, it should be mentioned that none of these examples should be + used to count the number of bytes in a file when that information is + more readily accessible by another means. For example, it is + preferable to get this information via the stat_file function: + + + + define count_chars_in_file (file) + { + variable st; + + st = stat_file (file); + if (st == NULL) + error ("stat_file failed."); + return st.st_size; + } + + + + 16.2. POSIX I/O + + + + 16.3. Advanced I/O techniques + + + The previous examples illustrate how to read and write objects of a + single data-type from a file, e.g., + + + num = fread (&a, Double_Type, 20, fp); + + + + would result in a Double_Type[num] array being assigned to a if suc- + cessful. However, suppose that the binary data file consists of num- + bers in a specified byte-order. How can one read such objects with + the proper byte swapping? The answer is to use the fread function to + read the objects as Char_Type and then unpack the resulting string + into the specified data type, or types. This process is facilitated + using the pack and unpack functions. + + The pack function follows the syntax + + BString_Type pack (format-string, item-list); + + + and combines the objects in the item-list according to format-string + into a binary string and returns the result. Likewise, the unpack + function may be used to convert a binary string into separate data + objects: + + (variable-list) = unpack (format-string, binary-string); + + + The format string consists of one or more data-type specification + characters, and each may be followed by an optional decimal length + specifier. Specifically, the data-types are specified according to the + following table: + + + + c char + C unsigned char + h short + H unsigned short + i int + I unsigned int + l long + L unsigned long + j 16 bit int + J 16 unsigned int + k 32 bit int + K 32 bit unsigned int + f float + d double + F 32 bit float + D 64 bit float + s character string, null padded + S character string, space padded + x a null pad character + + + + A decimal length specifier may follow the data-type specifier. With + the exception of the s and S specifiers, the length specifier indi- + cates how many objects of that data type are to be packed or unpacked + from the string. When used with the s or S specifiers, it indicates + the field width to be used. If the length specifier is not present, + the length defaults to one. + + With the exception of c, C, s, S, and x, each of these may be prefixed + by a character that indicates the byte-order of the object: + + + > big-endian order (network order) + < little-endian order + = native byte-order + + + + The default is native byte order. + + Here are a few examples that should make this more clear: + + + a = pack ("cc", 'A', 'B'); % ==> a = "AB"; + a = pack ("c2", 'A', 'B'); % ==> a = "AB"; + a = pack ("xxcxxc", 'A', 'B'); % ==> a = "\0\0A\0\0B"; + a = pack ("h2", 'A', 'B'); % ==> a = "\0A\0B" or "\0B\0A" + a = pack (">h2", 'A', 'B'); % ==> a = "\0\xA\0\xB" + a = pack (" a = "\0B\0A" + a = pack ("s4", "AB", "CD"); % ==> a = "AB\0\0" + a = pack ("s4s2", "AB", "CD"); % ==> a = "AB\0\0CD" + a = pack ("S4", "AB", "CD"); % ==> a = "AB " + a = pack ("S4S2", "AB", "CD"); % ==> a = "AB CD" + + + + When unpacking, if the length specifier is greater than one, then an + array of that length will be returned. In addition, trailing + whitespace and null character are stripped when unpacking an object + given by the S specifier. Here are a few examples: + + + (x,y) = unpack ("cc", "AB"); % ==> x = 'A', y = 'B' + x = unpack ("c2", "AB"); % ==> x = ['A', 'B'] + x = unpack ("x x = 0xCDABuh + x = unpack ("xxs4", "a b c\0d e f"); % ==> x = "b c\0" + x = unpack ("xxS4", "a b c\0d e f"); % ==> x = "b c" + + + + 16.3.1. Example: Reading /var/log/wtmp + + + Consider the task of reading the Unix system file /var/log/utmp, which + contains login records about who logged onto the system. This file + format is documented in section 5 of the online Unix man pages, and + consists of a sequence of entries formatted according to the C + structure utmp defined in the utmp.h C header file. The actual + details of the structure may vary from one version of Unix to the + other. For the purposes of this example, consider its definition + under the Linux operating system running on an Intel processor: + + + struct utmp { + short ut_type; /* type of login */ + pid_t ut_pid; /* pid of process */ + char ut_line[12]; /* device name of tty - "/dev/" */ + char ut_id[2]; /* init id or abbrev. ttyname */ + time_t ut_time; /* login time */ + char ut_user[8]; /* user name */ + char ut_host[16]; /* host name for remote login */ + long ut_addr; /* IP addr of remote host */ + }; + + + + On this system, pid_t is defined to be an int and time_t is a long. + Hence, a format specifier for the pack and unpack functions is easily + constructed to be: + + + "h i S12 S2 l S8 S16 l" + + + + However, this particular definition is naive because it does not allow + for structure padding performed by the C compiler in order to align + the data types on suitable word boundaries. Fortunately, the intrin- + sic function pad_pack_format may be used to modify a format by adding + the correct amount of padding in the right places. In fact, + pad_pack_format applied to the above format on an Intel-based Linux + system produces the result: + + + "h x2 i S12 S2 x2 l S8 S16 l" + + + + Here we see that 4 bytes of padding were added. + + The other missing piece of information is the size of the structure. + This is useful because we would like to read in one structure at a + time using the fread function. Knowing the size of the various data + types makes this easy; however it is even easier to use the + sizeof_pack intrinsic function, which returns the size (in bytes) of + the structure described by the pack format. + + So, with all the pieces in place, it is rather straightforward to + write the code: + + + variable format, size, fp, buf; + + typedef struct + { + ut_type, ut_pid, ut_line, ut_id, + ut_time, ut_user, ut_host, ut_addr + } UTMP_Type; + + format = pad_pack_format ("h i S12 S2 l S8 S16 l"); + size = sizeof_pack (format); + + define print_utmp (u) + { + + () = fprintf (stdout, "%-16s %-12s %-16s %s\n", + u.ut_user, u.ut_line, u.ut_host, ctime (u.ut_time)); + } + + + fp = fopen ("/var/log/utmp", "rb"); + if (fp == NULL) + error ("Unable to open utmp file"); + + () = fprintf (stdout, "%-16s %-12s %-16s %s\n", + "USER", "TTY", "FROM", "LOGIN@"); + + variable U = @UTMP_Type; + + while (-1 != fread (&buf, Char_Type, size, fp)) + { + set_struct_fields (U, unpack (format, buf)); + print_utmp (U); + } + + () = fclose (fp); + + + + A few comments about this example are in order. First of all, note + that a new data type called UTMP_Type was created, although this was + not really necessary. We also opened the file in binary mode, but + this too is optional under a Unix system where there is no distinction + between binary and text modes. The print_utmp function does not print + all of the structure fields. Finally, last but not least, the return + values from fprintf and fclose were dealt with. + + + + 17. Debugging + + + + The current implementation provides no support for an interactive + debugger, although a future version will. Nevertheless, S-Lang has + several features that aid the programmer in tracking down problems, + including function call tracebacks and the tracing of function calls. + However, the biggest debugging aid stems from the fact that the + language is interpreted permitting one to easily add debugging + statements to the code. + + To enable debugging information, add the lines + + + _debug_info = 1; + _traceback = 1; + + + + to the top of the source file of the code containing the bug and the + reload the file. Setting the _debug_info variable to 1 causes line + number information to be compiled into the functions when the file is + loaded. The _traceback variable controls whether or not traceback + information should be generated. If it is set to 1, the values of + local variables will be dumped when the traceback is generated. Set- + ting this variable to -1 will cause only function names to be reported + in the traceback. + + Here is an example of a traceback report: + + + S-Lang Traceback: error + S-Lang Traceback: verror + S-Lang Traceback: (Error occurred on line 65) + S-Lang Traceback: search_generic_search + Local Variables: + $0: Type: String_Type, Value: "Search forward:" + $1: Type: Integer_Type, Value: 1 + $2: Type: Ref_Type, Value: _function_return_1 + $3: Type: String_Type, Value: "abcdefg" + $4: Type: Integer_Type, Value: 1 + S-Lang Traceback: (Error occurred on line 72) + S-Lang Traceback: search_forward + + + + There are several ways to read this report; perhaps the simplest is to + read it from the bottom. This report says that on line 72, the + search_forward function called the search_generic_search function. On + line 65 it called the verror function, which called error. The + search_generic_search function contains 5 local variables and are rep- + resented symbolically as $0 through $4. + + + + 18. Regular Expressions + + + The S-Lang library includes a regular expression (RE) package that may + be used by an application embedding the library. The RE syntax should + be familiar to anyone acquainted with regular expressions. In this + section the syntax of the S-Lang regular expressions is discussed. + + + 18.1. S-Lang RE Syntax + + + A regular expression specifies a pattern to be matched against a + string, and has the property that the contcatenation of two REs is + also a RE. + + The S-Lang library supports the following standard regular + expressions: + + + . match any character except newline + * matches zero or more occurences of previous RE + + matches one or more occurences of previous RE + ? matches zero or one occurence of previous RE + ^ matches beginning of a line + $ matches end of line + [ ... ] matches any single character between brackets. + For example, [-02468] matches `-' or any even digit. + and [-0-9a-z] matches `-' and any digit between 0 and 9 + as well as letters a through z. + \< Match the beginning of a word. + \> Match the end of a word. + \( ... \) + \1, \2, ..., \9 Matches the match specified by nth \( ... \) + expression. + + + + In addition the following extensions are also supported: + + + \c turn on case-sensitivity (default) + \C turn off case-sensitivity + \d match any digit + \e match ESC char + + + + Here are some simple examples: + + "^int " matches the "int " at the beginning of a line. + + "\" matches "money" but only if it appears as a separate word. + + "^$" matches an empty line. + + A more complex pattern is + + + "\(\<[a-zA-Z]+\>\)[ ]+\1\>" + + + + which matches any word repeated consecutively. Note how the grouping + operators \( and \) are used to define the text matched by the + enclosed regular expression, and then subsequently referred to \1. + + Finally, remember that when used in string literals either in the S- + Lang language or in the C language, care must be taken to "double-up" + the '\' character since both languages treat it as an escape + character. + + + 18.2. Differences between S-Lang and egrep REs + + + There are several differences between S-Lang regular expressions and, + e.g., egrep regular expressions. + + The most notable difference is that the S-Lang regular expressions do + not support the OR operator | in expressions. This means that "a|b" + or "a\|b" do not have the meaning that they have in regular expression + packages that support egrep-style expressions. + + The other main difference is that while S-Lang regular expressions + support the grouping operators \( and \), they are only used as a + means of specifying the text that is matched. That is, the expression + + + "@\([a-z]*\)@.*@\1@" + + + + matches "xxx@abc@silly@abc@yyy", where the pattern \1 matches the text + enclosed by the \( and \) expressions. However, in the current imple- + mentation, the grouping operators are not used to group regular + expressions to form a single regular expression. Thus expression such + as "\(hello\)*" is not a pattern to match zero or more occurances of + "hello" as it is in e.g., egrep. + + One question that comes up from time to time is why doesn't S-Lang + simply employ some posix-compatible regular expression library. The + simple answer is that, at the time of this writing, none exists that + is available across all the platforms that the S-Lang library supports + (Unix, VMS, OS/2, win32, win16, BEOS, MSDOS, and QNX) and can be + distributed under both the GNU and Artistic licenses. It is + particularly important that the library and the interpreter support a + common set of regular expressions in a platform independent manner. + + + + 19. Future Directions + + + + Several new features or enhancements to the S-Lang language are + planned for the next major release. In no particular order, these + include: + + o An interactive debugging facility. + + o Function qualifiers. These entities should already be familiar to + VMS users or to those who are familiar with the IDL language. + Basically, a qualifier is an optional argument that is passed to a + function, e.g., plot(X,Y,/logx). Here /logx is a qualifier that + specifies that the plot function should use a log scale for x. + + o File local variables and functions. A file local variable or + function is an object that is global to the file that defines it. + + o Multi-threading. Currently the language does not support multiple + threads. + + + + A. Copyright + + The S-Lang library is distributed under two copyrights: the GNU Genral + Public License, and the Artistic License. Any program that uses the + interpreter must adhere to rules of one of these licenses. + + + A.1. The GNU Public License + + + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + + + The licenses for most software are designed to take away your freedom + to share and change it. By contrast, the GNU General Public License + is intended to guarantee your freedom to share and change free soft- + ware--to make sure the software is free for all its users. This Gen- + eral Public License applies to most of the Free Software Foundation's + software and to any other program whose authors commit to using it. + (Some other Free Software Foundation software is covered by the GNU + Library General Public License instead.) You can apply it to your + programs, too. + + When we speak of free software, we are referring to freedom, not + price. Our General Public Licenses are designed to make sure that you + have the freedom to distribute copies of free software (and charge for + this service if you wish), that you receive source code or can get it + if you want it, that you can change the software or use pieces of it + in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid + anyone to deny you these rights or to ask you to surrender the rights. + These restrictions translate to certain responsibilities for you if + you distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether + gratis or for a fee, you must give the recipients all the rights that + you have. You must make sure that they, too, receive or can get the + source code. And you must show them these terms so they know their + rights. + + We protect your rights with two steps: (1) copyright the software, and + (2) offer you this license which gives you legal permission to copy, + distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain + that everyone understands that there is no warranty for this free + software. If the software is modified by someone else and passed on, + we want its recipients to know that what they have is not the + original, so that any problems introduced by others will not reflect + on the original authors' reputations. + + Finally, any free program is threatened constantly by software + patents. We wish to avoid the danger that redistributors of a free + program will individually obtain patent licenses, in effect making the + program proprietary. To prevent this, we have made it clear that any + patent must be licensed for everyone's free use or not licensed at + all. + + The precise terms and conditions for copying, distribution and + modification follow. + + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + + + 0. This License applies to any program or other work which contains a + notice placed by the copyright holder saying it may be distributed + under the terms of this General Public License. The "Program", below, + refers to any such program or work, and a "work based on the Program" + means either the Program or any derivative work under copyright law: + that is to say, a work containing the Program or a portion of it, + either verbatim or with modifications and/or translated into another + language. (Hereinafter, translation is included without limitation in + the term "modification".) Each licensee is addressed as "you". + + Activities other than copying, distribution and modification are not + covered by this License; they are outside its scope. The act of + running the Program is not restricted, and the output from the Program + is covered only if its contents constitute a work based on the Program + (independent of having been made by running the Program). Whether + that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's source + code as you receive it, in any medium, provided that you conspicuously + and appropriately publish on each copy an appropriate copyright notice + and disclaimer of warranty; keep intact all the notices that refer to + this License and to the absence of any warranty; and give any other + recipients of the Program a copy of this License along with the + Program. + + You may charge a fee for the physical act of transferring a copy, and + you may at your option offer warranty protection in exchange for a + fee. + + 2. You may modify your copy or copies of the Program or any portion of + it, thus forming a work based on the Program, and copy and distribute + such modifications or work under the terms of Section 1 above, + provided that you also meet all of these conditions: + + + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + + + + These requirements apply to the modified work as a whole. If identi- + fiable sections of that work are not derived from the Program, and can + be reasonably considered independent and separate works in themselves, + then this License, and its terms, do not apply to those sections when + you distribute them as separate works. But when you distribute the + same sections as part of a whole which is a work based on the Program, + the distribution of the whole must be on the terms of this License, + whose permissions for other licensees extend to the entire whole, and + thus to each and every part regardless of who wrote it. + + Thus, it is not the intent of this section to claim rights or contest + your rights to work written entirely by you; rather, the intent is to + exercise the right to control the distribution of derivative or + collective works based on the Program. + + In addition, mere aggregation of another work not based on the Program + with the Program (or with a work based on the Program) on a volume of + a storage or distribution medium does not bring the other work under + the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, + under Section 2) in object code or executable form under the terms of + Sections 1 and 2 above provided that you also do one of the following: + + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + + + + The source code for a work means the preferred form of the work for + making modifications to it. For an executable work, complete source + code means all the source code for all modules it contains, plus any + associated interface definition files, plus the scripts used to con- + trol compilation and installation of the executable. However, as a + special exception, the source code distributed need not include any- + thing that is normally distributed (in either source or binary form) + with the major components (compiler, kernel, and so on) of the operat- + ing system on which the executable runs, unless that component itself + accompanies the executable. + + If distribution of executable or object code is made by offering + access to copy from a designated place, then offering equivalent + access to copy the source code from the same place counts as + distribution of the source code, even though third parties are not + compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program + except as expressly provided under this License. Any attempt + otherwise to copy, modify, sublicense or distribute the Program is + void, and will automatically terminate your rights under this License. + However, parties who have received copies, or rights, from you under + this License will not have their licenses terminated so long as such + parties remain in full compliance. + + 5. You are not required to accept this License, since you have not + signed it. However, nothing else grants you permission to modify or + distribute the Program or its derivative works. These actions are + prohibited by law if you do not accept this License. Therefore, by + modifying or distributing the Program (or any work based on the + Program), you indicate your acceptance of this License to do so, and + all its terms and conditions for copying, distributing or modifying + the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the + Program), the recipient automatically receives a license from the + original licensor to copy, distribute or modify the Program subject to + these terms and conditions. You may not impose any further + restrictions on the recipients' exercise of the rights granted herein. + You are not responsible for enforcing compliance by third parties to + this License. + + 7. If, as a consequence of a court judgment or allegation of patent + infringement or for any other reason (not limited to patent issues), + conditions are imposed on you (whether by court order, agreement or + otherwise) that contradict the conditions of this License, they do not + excuse you from the conditions of this License. If you cannot + distribute so as to satisfy simultaneously your obligations under this + License and any other pertinent obligations, then as a consequence you + may not distribute the Program at all. For example, if a patent + license would not permit royalty-free redistribution of the Program by + all those who receive copies directly or indirectly through you, then + the only way you could satisfy both it and this License would be to + refrain entirely from distribution of the Program. + + If any portion of this section is held invalid or unenforceable under + any particular circumstance, the balance of the section is intended to + apply and the section as a whole is intended to apply in other + circumstances. + + It is not the purpose of this section to induce you to infringe any + patents or other property right claims or to contest validity of any + such claims; this section has the sole purpose of protecting the + integrity of the free software distribution system, which is + implemented by public license practices. Many people have made + generous contributions to the wide range of software distributed + through that system in reliance on consistent application of that + system; it is up to the author/donor to decide if he or she is willing + to distribute software through any other system and a licensee cannot + impose that choice. + + This section is intended to make thoroughly clear what is believed to + be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in + certain countries either by patents or by copyrighted interfaces, the + original copyright holder who places the Program under this License + may add an explicit geographical distribution limitation excluding + those countries, so that distribution is permitted only in or among + countries not thus excluded. In such case, this License incorporates + the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new + versions of the General Public License from time to time. Such new + versions will be similar in spirit to the present version, but may + differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the Program + specifies a version number of this License which applies to it and + "any later version", you have the option of following the terms and + conditions either of that version or of any later version published by + the Free Software Foundation. If the Program does not specify a + version number of this License, you may choose any version ever + published by the Free Software Foundation. + + 10. If you wish to incorporate parts of the Program into other free + programs whose distribution conditions are different, write to the + author to ask for permission. For software which is copyrighted by + the Free Software Foundation, write to the Free Software Foundation; + we sometimes make exceptions for this. Our decision will be guided by + the two goals of preserving the free status of all derivatives of our + free software and of promoting the sharing and reuse of software + generally. + + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY + FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN + OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES + PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED + OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS + TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE + PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, + REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING + WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR + REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, + INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING + OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED + TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY + YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER + PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE + POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest + possible use to the public, the best way to achieve this is to make it + free software which everyone can redistribute and change under these + terms. + + To do so, attach the following notices to the program. It is safest + to attach them to the start of each source file to most effectively + convey the exclusion of warranty; and each file should have at least + the "copyright" line and a pointer to where the full notice is found. + + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + + + Also add information on how to contact you by electronic and paper + mail. + + If the program is interactive, make it output a short notice like this + when it starts in an interactive mode: + + + Gnomovision version 69, Copyright (C) 19yy name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + + + + The hypothetical commands `show w' and `show c' should show the appro- + priate parts of the General Public License. Of course, the commands + you use may be called something other than `show w' and `show c'; they + could even be mouse-clicks or menu items--whatever suits your program. + + You should also get your employer (if you work as a programmer) or + your school, if any, to sign a "copyright disclaimer" for the program, + if necessary. Here is a sample; alter the names: + + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + + + + This General Public License does not permit incorporating your program + into proprietary programs. If your program is a subroutine library, + you may consider it more useful to permit linking proprietary applica- + tions with the library. If this is what you want to do, use the GNU + Library General Public License instead of this License. + + + A.2. The Artistic License + + + + The "Artistic License" + + Preamble + + + + The intent of this document is to state the conditions under which a + Package may be copied, such that the Copyright Holder maintains some + semblance of artistic control over the development of the package, + while giving the users of the package the right to use and distribute + the Package in a more-or-less customary fashion, plus the right to + make reasonable modifications. + + Definitions: + + + "Package" refers to the collection of files distributed by the + Copyright Holder, and derivatives of that collection of files + created through textual modification. + + "Standard Version" refers to such a Package if it has not been + modified, or has been modified in accordance with the wishes + of the Copyright Holder as specified below. + + "Copyright Holder" is whoever is named in the copyright or + copyrights for the package. + + "You" is you, if you're thinking about copying or distributing + this Package. + + "Reasonable copying fee" is whatever you can justify on the + basis of media cost, duplication charges, time of people involved, + and so on. (You will not be required to justify it to the + Copyright Holder, but only to the computing community at large + as a market that must bear the fee.) + + "Freely Available" means that no fee is charged for the item + itself, though there may be fees involved in handling the item. + It also means that recipients of the item may redistribute it + under the same conditions they received it. + + + + 1. You may make and give away verbatim copies of the source form of + the Standard Version of this Package without restriction, provided + that you duplicate all of the original copyright notices and associ- + ated disclaimers. + + 2. You may apply bug fixes, portability fixes and other modifications + derived from the Public Domain or from the Copyright Holder. A + Package modified in such a way shall still be considered the Standard + Version. + + 3. You may otherwise modify your copy of this Package in any way, + provided that you insert a prominent notice in each changed file + stating how and when you changed that file, and provided that you do + at least ONE of the following: + + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or + an equivalent medium, or placing the modifications on a major archive + site such as uunet.uu.net, or by allowing the Copyright Holder to include + your modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and provide + a separate manual page for each non-standard executable that clearly + documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + + + + 4. You may distribute the programs of this Package in object code or + executable form, provided that you do at least ONE of the following: + + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where + to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), together + with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + + + + 5. You may charge a reasonable copying fee for any distribution of + this Package. You may charge any fee you choose for support of this + Package. You may not charge a fee for this Package itself. However, + you may distribute this Package in aggregate with other (possibly com- + mercial) programs as part of a larger (possibly commercial) software + distribution provided that you do not advertise this Package as a + product of your own. You may embed this Package's interpreter within + an executable of yours (by linking); this shall be construed as a mere + form of aggregation, provided that the complete Standard Version of + the interpreter is so embedded. + + 6. The scripts and library files supplied as input to or produced as + output from the programs of this Package do not automatically fall + under the copyright of this Package, but belong to whomever generated + them, and may be sold commercially, and may be aggregated with this + Package. If such scripts or library files are aggregated with this + Package via the so-called "undump" or "unexec" methods of producing a + binary executable image, then distribution of such an image shall + neither be construed as a distribution of this Package nor shall it + fall under the restrictions of Paragraphs 3 and 4, provided that you + do not represent such an executable image as a Standard Version of + this Package. + 7. C subroutines (or comparably compiled subroutines in other + languages) supplied by you and linked into this Package in order to + emulate subroutines and variables of the language defined by this + Package shall not be considered part of this Package, but are the + equivalent of input as in Paragraph 6, provided these subroutines do + not change the language in any way that would cause it to fail the + regression tests for the language. + + 8. Aggregation of this Package with a commercial distribution is + always permitted provided that the use of this Package is embedded; + that is, when no overt attempt is made to make this Package's + interfaces visible to the end user of the commercial distribution. + Such use shall not be construed as a distribution of this Package. + + 9. The name of the Copyright Holder may not be used to endorse or + promote products derived from this software without specific prior + written permission. + + 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + + + + Table of Contents + + + 1. Preface . . . . . . . . . . . . . . . . . . . . . . . . . . . . 4 + 1.1. A Brief History of S-Lang . . . . . . . . . . . . . . . . . . 4 + 1.2. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . 4 + 2. Introduction . . . . . . . . . . . . . . . . . . . . . . . . . 6 + 2.1. Language Features . . . . . . . . . . . . . . . . . . . . . . 6 + 2.2. Data Types and Operators . . . . . . . . . . . . . . . . . . 6 + 2.3. Statements and Functions . . . . . . . . . . . . . . . . . . 6 + 2.4. Error Handling . . . . . . . . . . . . . . . . . . . . . . . 7 + 2.5. Run-Time Library . . . . . . . . . . . . . . . . . . . . . . 7 + 2.6. Input/Output . . . . . . . . . . . . . . . . . . . . . . . . 7 + 2.7. Obtaining S-Lang . . . . . . . . . . . . . . . . . . . . . . 8 + 3. Overview of the Language . . . . . . . . . . . . . . . . . . . 9 + 3.1. Variables and Functions . . . . . . . . . . . . . . . . . . . 9 + 3.2. Strings . . . . . . . . . . . . . . . . . . . . . . . . . . . 11 + 3.3. Referencing and Dereferencing . . . . . . . . . . . . . . . . 11 + 3.4. Arrays . . . . . . . . . . . . . . . . . . . . . . . . . . . 13 + 3.5. Structures and User-Defined Types . . . . . . . . . . . . . . 15 + 3.6. Namespaces . . . . . . . . . . . . . . . . . . . . . . . . . 16 + 4. Data Types and Literal Constants . . . . . . . . . . . . . . . 18 + 4.1. Predefined Data Types . . . . . . . . . . . . . . . . . . . . 18 + 4.1.1. Integers . . . . . . . . . . . . . . . . . . . . . . . . . 18 + 4.1.2. Floating Point Numbers . . . . . . . . . . . . . . . . . . 19 + 4.1.3. Complex Numbers . . . . . . . . . . . . . . . . . . . . . . 19 + 4.1.4. Strings . . . . . . . . . . . . . . . . . . . . . . . . . . 20 + 4.1.5. Null_Type . . . . . . . . . . . . . . . . . . . . . . . . . 21 + 4.1.6. Ref_Type . . . . . . . . . . . . . . . . . . . . . . . . . 21 + 4.1.7. Array_Type and Struct_Type . . . . . . . . . . . . . . . . 22 + 4.1.8. DataType_Type Type . . . . . . . . . . . . . . . . . . . . 22 + 4.2. Typecasting: Converting from one Type to Another . . . . . . 23 + 5. Identifiers . . . . . . . . . . . . . . . . . . . . . . . . . . 25 + 6. Variables . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 + 7. Operators . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 + 7.1. Unary Operators . . . . . . . . . . . . . . . . . . . . . . . 28 + 7.2. Binary Operators . . . . . . . . . . . . . . . . . . . . . . 28 + 7.2.1. Arithmetic Operators . . . . . . . . . . . . . . . . . . . 29 + 7.2.2. Relational Operators . . . . . . . . . . . . . . . . . . . 29 + 7.2.3. Boolean Operators . . . . . . . . . . . . . . . . . . . . . 29 + 7.2.4. Bitwise Operators . . . . . . . . . . . . . . . . . . . . . 30 + 7.2.5. Namespace operator . . . . . . . . . . . . . . . . . . . . 31 + 7.2.6. Operator Precedence . . . . . . . . . . . . . . . . . . . . 31 + 7.2.7. Binary Operators and Functions Returning Multiple Val- + ues . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 31 + 7.3. Mixing Integer and Floating Point Arithmetic . . . . . . . . 32 + 7.4. Short Circuit Boolean Evaluation . . . . . . . . . . . . . . 33 + 8. Statements . . . . . . . . . . . . . . . . . . . . . . . . . . 34 + 8.1. Variable Declaration Statements . . . . . . . . . . . . . . . 34 + 8.2. Assignment Statements . . . . . . . . . . . . . . . . . . . . 34 + 8.3. Conditional and Looping Statements . . . . . . . . . . . . . 36 + 8.3.1. Conditional Forms . . . . . . . . . . . . . . . . . . . . . 36 + 8.3.1.1. if . . . . . . . . . . . . . . . . . . . . . . . . . . . 36 + 8.3.1.2. if-else . . . . . . . . . . . . . . . . . . . . . . . . . 36 + 8.3.1.3. !if . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 + 8.3.1.4. orelse, andelse . . . . . . . . . . . . . . . . . . . . . 38 + 8.3.1.5. switch . . . . . . . . . . . . . . . . . . . . . . . . . 38 + 8.3.2. Looping Forms . . . . . . . . . . . . . . . . . . . . . . . 40 + 8.3.2.1. while . . . . . . . . . . . . . . . . . . . . . . . . . . 40 + 8.3.2.2. do...while . . . . . . . . . . . . . . . . . . . . . . . 41 + 8.3.2.3. for . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 + 8.3.2.4. loop . . . . . . . . . . . . . . . . . . . . . . . . . . 42 + 8.3.2.5. loop . . . . . . . . . . . . . . . . . . . . . . . . . . 42 + 8.3.2.6. forever . . . . . . . . . . . . . . . . . . . . . . . . . 42 + 8.3.2.7. foreach . . . . . . . . . . . . . . . . . . . . . . . . . 43 + 8.4. break, return, continue . . . . . . . . . . . . . . . . . . . 45 + 9. Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . 46 + 9.1. Declaring Functions . . . . . . . . . . . . . . . . . . . . . 46 + 9.2. Parameter Passing Mechanism . . . . . . . . . . . . . . . . . 46 + 9.3. Referencing Variables . . . . . . . . . . . . . . . . . . . . 48 + 9.4. Functions with a Variable Number of Arguments . . . . . . . . 49 + 9.5. Returning Values . . . . . . . . . . . . . . . . . . . . . . 51 + 9.6. Multiple Assignment Statement . . . . . . . . . . . . . . . . 52 + 9.7. Exit-Blocks . . . . . . . . . . . . . . . . . . . . . . . . . 54 + 10. Name Spaces . . . . . . . . . . . . . . . . . . . . . . . . . 56 + 11. Arrays . . . . . . . . . . . . . . . . . . . . . . . . . . . . 58 + 11.1. Creating Arrays . . . . . . . . . . . . . . . . . . . . . . 58 + 11.1.1. Range Arrays . . . . . . . . . . . . . . . . . . . . . . . 58 + 11.1.2. Creating arrays via the dereference operator . . . . . . . 59 + 11.2. Reshaping Arrays . . . . . . . . . . . . . . . . . . . . . . 60 + 11.3. Indexing Arrays . . . . . . . . . . . . . . . . . . . . . . 60 + 11.4. Arrays and Variables . . . . . . . . . . . . . . . . . . . . 64 + 11.5. Using Arrays in Computations . . . . . . . . . . . . . . . . 65 + 12. Associative Arrays . . . . . . . . . . . . . . . . . . . . . . 69 + 13. Structures and User-Defined Types . . . . . . . . . . . . . . 71 + 13.1. Defining a Structure . . . . . . . . . . . . . . . . . . . . 71 + 13.2. Accessing the Fields of a Structure . . . . . . . . . . . . 72 + 13.3. Linked Lists . . . . . . . . . . . . . . . . . . . . . . . . 72 + 13.4. Defining New Types . . . . . . . . . . . . . . . . . . . . . 75 + 14. Error Handling . . . . . . . . . . . . . . . . . . . . . . . . 77 + 14.1. Error-Blocks . . . . . . . . . . . . . . . . . . . . . . . . 77 + 14.2. Clearing Errors . . . . . . . . . . . . . . . . . . . . . . 78 + 15. Loading Files: evalfile and autoload . . . . . . . . . . . . . 80 + 16. File Input/Output . . . . . . . . . . . . . . . . . . . . . . 81 + 16.1. Input/Output via stdio . . . . . . . . . . . . . . . . . . . 81 + 16.1.1. Stdio Overview . . . . . . . . . . . . . . . . . . . . . . 81 + 16.1.2. Stdio Examples . . . . . . . . . . . . . . . . . . . . . . 82 + 16.2. POSIX I/O . . . . . . . . . . . . . . . . . . . . . . . . . 84 + 16.3. Advanced I/O techniques . . . . . . . . . . . . . . . . . . 84 + 16.3.1. Example: Reading /var/log/wtmp . . . . . . . . . . . . . . 86 + 17. Debugging . . . . . . . . . . . . . . . . . . . . . . . . . . 88 + 18. Regular Expressions . . . . . . . . . . . . . . . . . . . . . 89 + 18.1. S-Lang RE Syntax . . . . . . . . . . . . . . . . . . . . . 89 + 18.2. Differences between S-Lang and egrep REs . . . . . . . . . 90 + 19. Future Directions . . . . . . . . . . . . . . . . . . . . . . 91 + A. Copyright . . . . . . . . . . . . . . . . . . . . . . . . . . . 92 + A.1. The GNU Public License . . . . . . . . . . . . . . . . . . . 92 + A.2. The Artistic License . . . . . . . . . . . . . . . . . . . . 98 + + + diff --git a/libslang/doc/text/slangfun.txt b/libslang/doc/text/slangfun.txt new file mode 100644 index 0000000..3f35b89 --- /dev/null +++ b/libslang/doc/text/slangfun.txt @@ -0,0 +1,5943 @@ +_isnull + + SYNOPSIS + Check array for NULL elements + + USAGE + Char_Type[] = _isnull (a[]) + + DESCRIPTION + This function may be used to test for the presence of NULL elements + of an array. Specifically, it returns a `Char_Type' array of + with the same number of elements and dimensionality of the input + array. If an element of the input array is NULL, then the + corresponding element of the output array will be set to 1, + otherwise it will be set to 0. + + EXAMPLE + Set all NULL elements of a string array `A' to the empty + string `""': + + A[where(_isnull(A))] = ""; + + + NOTES + It is important to understand the difference between `A==NULL' + and `_isnull(A)'. The latter tests all elements of `A' + against NULL, whereas the former only tests `A' itself. + + SEE ALSO + where, array_map +-------------------------------------------------------------- + +_reshape + + SYNOPSIS + Copy an array to a new shape + + USAGE + Array_Type _reshape (Array_Type A, Array_Type I) + + DESCRIPTION + The `_reshape' function creates a copy of an array `A', + reshapes it to the form specified by `I' and returns the result. + The elements of `I' specify the new dimensions of the copy of + `A' and must be consistent with the number of elements `A'. + + EXAMPLE + If `A' is a `100' element 1-d array, a new array 2-d array of + size `20' by `5' may be created from the elements of `A' + by + + A = _reshape (A, [20, 5]); + + In this example, the original array was no longer needed. Hence, it + is preferable to make use of the `__tmp' operator to avoid the + creation of a new array, i.e., + + A = _reshape (__tmp(A), [20,5]); + + + NOTES + The `reshape' function performs a similar function to + `_reshape'. In fact, the `_reshape' function could have been + implemented via: + + define _reshape (a, i) + { + a = @a; % Make a new copy + reshape (a, i); + return a; + } + + + SEE ALSO + reshape, array_info +-------------------------------------------------------------- + +array_info + + SYNOPSIS + Returns information about an array + + USAGE + (Array_Type, Integer_Type, DataType_Type) array_info (Array_Type a) + + DESCRIPTION + The `array_info' function returns information about the array `a'. + It returns three values: an 1-d integer array specifying the + size of each dimension of `a', the number of dimensions of + `a', and the data type of `a'. + + EXAMPLE + The `array_info' function may be used to find the number of rows + of an array: + + define num_rows (a) + { + variable dims, num_dims, data_type; + + (dims, num_dims, data_type) = array_info (a); + return dims [0]; + } + + For 1-d arrays, this information is more easily obtained from the + `length' function. + + SEE ALSO + typeof, reshape, length, _reshape +-------------------------------------------------------------- + +array_map + + SYNOPSIS + Apply a function to each element of an array + + USAGE + Array_Type array_map (type, func, arg0, ...) + + DataType_Type type; + Ref_Type func; + + + DESCRIPTION + The `array_map' function may be used to apply a function to each + element of an array and returns the result as an array of a + specified type. The `type' parameter indicates what kind of + array should be returned and generally corresponds to the return + type of the function. The `arg0' parameter should be an array + and is used to determine the dimensions of the resulting array. If + any subsequent arguments correspond to an array of the same size, + then those array elements will be passed in parallel with the first + arrays arguments. + + EXAMPLE + The first example illustrates how to apply the `strlen' function + to an array of strings: + + S = ["", "Train", "Subway", "Car"]; + L = array_map (Integer_Type, &strlen, S); + + This is equivalent to: + + S = ["", "Train", "Subway", "Car"]; + L = Integer_Type [length (S)]; + for (i = 0; i < length (S); i++) L[i] = strlen (S[i]); + + + Now consider an example involving the `strcat' function: + + files = ["slang", "slstring", "slarray"]; + + exts = ".c"; + cfiles = array_map (String_Type, &strcat, files, exts); + % ==> cfiles = ["slang.c slstring.c slarray.c"]; + + exts = [".a",".b",".c"]; + xfiles = array_map (String_Type, &strcat, files, exts); + % ==> xfiles = ["slang.a", "slstring.b", "slarray.c"]; + + + NOTES + Many mathemetical functions already work transparantly on arrays. + For example, the following two statements produce identical results: + + B = sin (A); + B = array_map (Double_Type, &sin, A); + + + SEE ALSO + array_info, strlen, strcat, sin +-------------------------------------------------------------- + +array_sort + + SYNOPSIS + Sort an array + + USAGE + Array_Type array_sort (Array_Type a [, String_Type or Ref_Type f]) + + DESCRIPTION + `array_sort' sorts the array `a' into ascending order and + returns an integer array that represents the result of the sort. If + the optional second parameter `f' is present, the function + specified by `f' will be used to compare elements of `a'; + otherwise, a built-in sorting function will be used. + + If `f' is present, then it must be either a string representing + the name of the comparison function, or a reference to the function. + The sort function represented by `f' must be a S-Lang + user-defined function that takes two arguments. The function must + return an integer that is less than zero if the first parameter is + considered to be less than the second, zero if they are equal, and a + value greater than zero if the first is greater than the second. + + If the comparision function is not specified, then a built-in comparison + function appropriate for the data type will be used. For example, + if `a' is an array of character strings, then the sort will be + preformed using `strcmp'. + + The integer array returned by this function is simply an index that + indicates the order of the sorted array. The input array `a' is + not changed. + + EXAMPLE + An array of strings may be sorted using the `strcmp' function + since it fits the specification for the sorting function described + above: + + variable A = String_Type [3]; + A[0] = "gamma"; A[1] = "alpha"; A[2] = "beta"; + + variable I = array_sort (A, &strcmp); + + Alternatively, one may use + + variable I = array_sort (A); + + to use the built-in comparison function. + + After the `array_sort' has executed, the variable `I' will + have the values `[2, 0, 1]'. This array can be used to + re-shuffle the elements of `A' into the sorted order via the + array index expression `A = A[I]'. + + SEE ALSO + strcmp +-------------------------------------------------------------- + +cumsum + + SYNOPSIS + Compute the cumulative sum of an array + + USAGE + result = cumsum (Array_Type a [, Int_Type dim]) + + DESCRIPTION + The `cumsum' function performs a cumulative sum over the + elements of a numeric array and returns the resulting. If a second + argument is given, then it specifies the dimension of the array to + be summed over. For example, the cumulative sum of + `[1,2,3,4]', is the array `[1,1+2,1+2+3,1+2+3+4]', i.e., + `[1,3,6,10]'. + + SEE ALSO + sum +-------------------------------------------------------------- + +init_char_array + + SYNOPSIS + Initialize an array of characters + + USAGE + init_char_array (Array_Type a, String_Type s) + + DESCRIPTION + The `init_char_array' function may be used to initialize a + character array `a' by setting the elements of the array + `a' to the corresponding characters of the string `s'. + + EXAMPLE + The statements + + variable a = Char_Type [10]; + init_char_array (a, "HelloWorld"); + + creates an character array and initializes its elements to the + characters in the string `"HelloWorld"'. + + NOTES + The character array must be large enough to hold all the characters + of the initialization string. + + SEE ALSO + bstring_to_array, strlen, strcat +-------------------------------------------------------------- + +length + + SYNOPSIS + Get the length of an object + + USAGE + Integer_Type length (obj) + + DESCRIPTION + The `length' function may be used to get information about the + length of an object. For simple scalar data-types, it returns 1. + For arrays, it returns the total number of elements of the array. + + NOTES + If `obj' is a string, `length' returns 1 because a + `String_Type' object is considered to be a scalar. To get the + number of characters in a string, use the `strlen' function. + + SEE ALSO + array_info, typeof, strlen +-------------------------------------------------------------- + +max + + SYNOPSIS + Get the maximum value of an array + + USAGE + result = max (Array_Type a [,Int_Type dim]) + + DESCRIPTION + The `max' function examines the elements of a numeric array and + returns the value of the largest element. If a second argument is + given, then it specifies the dimension of the array to be searched. + In this case, an array of dimension one less than that of the input array + will be returned with the corresponding elements in the specified + dimension replaced by the minimum value in that dimension. + + EXAMPLE + Consider the 2-d array + + 1 2 3 4 5 + 6 7 8 9 10 + + generated by + + a = _reshape ([1:10], [2, 5]); + + Then `max(a)' will return `10', and `max(a,0)' will return + a 1-d array with elements + + 6 7 8 9 10 + + + SEE ALSO + max, sum, reshape +-------------------------------------------------------------- + +min + + SYNOPSIS + Get the minimum value of an array + + USAGE + result = min (Array_Type a [,Int_Type dim]) + + DESCRIPTION + The `min' function examines the elements of a numeric array and + returns the value of the smallest element. If a second argument is + given, then it specifies the dimension of the array to be searched. + In this case, an array of dimension one less than that of the input array + will be returned with the corresponding elements in the specified + dimension replaced by the minimum value in that dimension. + + EXAMPLE + Consider the 2-d array + + 1 2 3 4 5 + 6 7 8 9 10 + + generated by + + a = _reshape ([1:10], [2, 5]); + + Then `min(a)' will return `1', and `min(a,0)' will return + a 1-d array with elements + + 1 2 3 4 5 + + + SEE ALSO + max, sum, reshape +-------------------------------------------------------------- + +reshape + + SYNOPSIS + Reshape an array + + USAGE + reshape (Array_Type A, Array_Type I) + + DESCRIPTION + The `reshape' function changes the size of `A' to have the size + specified by the 1-d integer array `I'. The elements of `I' + specify the new dimensions of `A' and must be consistent with + the number of elements `A'. + + EXAMPLE + If `A' is a `100' element 1-d array, it can be changed to a + 2-d `20' by `5' array via + + reshape (A, [20, 5]); + + However, `reshape(A, [11,5])' will result in an error because + the `[11,5]' array specifies `55' elements. + + NOTES + Since `reshape' modifies the shape of an array, and arrays are + treated as references, then all references to the array will + reference the new shape. If this effect is unwanted, then use the + `_reshape' function instead. + + SEE ALSO + _reshape, array_info +-------------------------------------------------------------- + +sum + + SYNOPSIS + Sum over the elements of an array + + USAGE + result = sum (Array_Type a [, Int_Type dim]) + + DESCRIPTION + The `sum' function sums over the elements of a numeric array and + returns its result. If a second argument is given, then it + specifies the dimension of the array to be summed over. In this + case, an array of dimension one less than that of the input array + will be returned. + + If the input array is an integer type, then the resulting value will + be a `Double_Type'. If the input array is a `Float_Type', + then the result will be a `Float_Type'. + + EXAMPLE + The mean of an array `a' of numbers is + + sum(a)/length(a) + + + SEE ALSO + cumsum, transpose, reshape +-------------------------------------------------------------- + +transpose + + SYNOPSIS + Transpose an array + + USAGE + Array_Type transpose (Array_Type a) + + DESCRIPTION + The `transpose' function returns the transpose of a specified + array. By definition, the transpose of an array, say one with + elements `a[i,j,...k]' is an array whose elements are + `a[k,...,j,i]'. + + SEE ALSO + _reshape, reshape, sum, array_info +-------------------------------------------------------------- + +where + + SYNOPSIS + Get indices where an integer array is non-zero + + USAGE + Array_Type where (Array_Type a) + + DESCRIPTION + The `where' function examines an numeric array `a' and + returns an integer array giving the indices of `a' + where the corresponding element of `a' is non-zero. + + Although this function may appear to be simple or even trivial, it + is arguably one of the most important and powerful functions for + manipulating arrays. + + EXAMPLE + Consider the following: + + variable X = [0.0:10.0:0.01]; + variable A = sin (X); + variable I = where (A < 0.0); + A[I] = cos (X) [I]; + + Here the variable `X' has been assigned an array of doubles + whose elements range from `0.0' through `10.0' in + increments of `0.01'. The second statement assigns `A' to + an array whose elements are the `sin' of the elements of `X'. + The third statement uses the where function to get the indices of + the elements of `A' that are less than `0.0'. Finally, the + last statement substitutes into `A' the `cos' of the + elements of `X' at the positions of `A' where the + corresponding `sin' is less than `0'. The end result is + that the elements of `A' are a mixture of sines and cosines. + + SEE ALSO + array_info, sin, cos +-------------------------------------------------------------- + +assoc_delete_key + + SYNOPSIS + Delete a key from an Associative Array + + USAGE + assoc_delete_key (Assoc_Type a, String_Type k) + + DESCRIPTION + The `assoc_delete_key' function deletes a key given by `k' + from the associative array `a'. If the specified key does not + exist in `a', then this function has no effect. + + SEE ALSO + assoc_key_exists, assoc_get_keys +-------------------------------------------------------------- + +assoc_get_keys + + SYNOPSIS + Return all the key names of an Associative Array + + USAGE + String_Type[] assoc_get_keys (Assoc_Type a) + + DESCRIPTION + This function returns all the key names of an associative array + `a' as an ordinary one dimensional array of strings. If the + associative array contains no keys, an empty array will be returned. + + EXAMPLE + The following function computes the number of keys in an associative + array: + + define get_num_elements (a) + { + return length (assoc_get_keys (a)); + } + + + SEE ALSO + assoc_get_values, assoc_key_exists, assoc_delete_key, length +-------------------------------------------------------------- + +assoc_get_values + + SYNOPSIS + Return all the values of an Associative Array + + USAGE + Array_Type assoc_get_keys (Assoc_Type a) + + DESCRIPTION + This function returns all the values in the associative array + `a' as an array of proper type. If the associative array + contains no keys, an empty array will be returned. + + EXAMPLE + Suppose that `a' is an associative array of type + `Integer_Type', i.e., it was created via + + variable a = Assoc_Type[Integer_Type]; + + The the following may be used to print the values of the array in + ascending order: + + static define int_sort_fun (x, y) + { + return sign (x - y); + } + define sort_and_print_values (a) + { + variable i, v; + + v = assoc_get_values (a); + i = array_sort (v, &int_sort_fun); + v = v[i]; + foreach (v) + { + variable vi = (); + () = fprintf (stdout, "%d\n", vi); + } + } + + + SEE ALSO + assoc_get_values, assoc_key_exists, assoc_delete_key, array_sort +-------------------------------------------------------------- + +assoc_key_exists + + SYNOPSIS + Check to see whether a key exists in an Associative Array + + USAGE + Integer_Type assoc_key_exists (Assoc_Type a, String_Type k) + + DESCRIPTION + The `assoc_key_exists' function may be used to determine whether + or not a specified key `k' exists in an associative array `a'. + It returns 1 if the key exists, or 0 if it does not. + + SEE ALSO + assoc_get_keys, assoc_get_values, assoc_delete_key +-------------------------------------------------------------- + +array_to_bstring + + SYNOPSIS + Convert an array to a binary string + + USAGE + BString_Type array_to_bstring (Array_Type a) + + DESCRIPTION + The `array_to_bstring' function returns the elements of an + array `a' as a binary string. + + SEE ALSO + bstring_to_array, init_char_array +-------------------------------------------------------------- + +bstring_to_array + + SYNOPSIS + Convert a binary string to an array of characters + + USAGE + UChar_Type[] bstring_to_array (BString_Type b) + + DESCRIPTION + The `bstring_to_array' function returns an array of unsigned + characters whose elements correspond to the characters in the + binary string. + + SEE ALSO + array_to_bstring, init_char_array +-------------------------------------------------------------- + +bstrlen + + SYNOPSIS + Get the length of a binary string + + USAGE + UInt_Type bstrlen (BString_Type s) + + DESCRIPTION + The `bstrlen' function may be used to obtain the length of a + binary string. A binary string differs from an ordinary string (a C + string) in that a binary string may include null chracters. + + EXAMPLE + + variable s = "hello\0"; + len = bstrlen (s); % ==> len = 6 + len = strlen (s); % ==> len = 5 + + + SEE ALSO + strlen, length +-------------------------------------------------------------- + +pack + + SYNOPSIS + Pack objects into a binary string + + USAGE + BString_Type pack (String_Type fmt, ...) + + DESCRIPTION + The `pack' function combines zero or more the objects (represented + by the ellipses above) into a binary string acording to the format + string `fmt'. + + The format string consists of one or more data-type specification + characters, and each may be followed by an optional decimal length + specifier. Specifically, the data-types are specified according to + the following table: + + c char + C unsigned char + h short + H unsigned short + i int + I unsigned int + l long + L unsigned long + j 16 bit int + J 16 unsigned int + k 32 bit int + K 32 bit unsigned int + f float + d double + F 32 bit float + D 64 bit float + s character string, null padded + S character string, space padded + x a null pad character + + A decimal length specifier may follow the data-type specifier. With + the exception of the `s' and `S' specifiers, the length + specifier indicates how many objects of that data type are to be + packed or unpacked from the string. When used with the `s' or + `S' specifiers, it indicates the field width to be used. If the + length specifier is not present, the length defaults to one. + + With the exception of `c', `C', `s', `S', and + `x', each of these may be prefixed by a character that indicates + the byte-order of the object: + + > big-endian order (network order) + < little-endian order + = native byte-order + + The default is to use native byte order. + + When unpacking via the `unpack' function, if the length + specifier is greater than one, then an array of that length will be + returned. In addition, trailing whitespace and null character are + stripped when unpacking an object given by the `S' specifier. + + EXAMPLE + + a = pack ("cc", 'A', 'B'); % ==> a = "AB"; + a = pack ("c2", 'A', 'B'); % ==> a = "AB"; + a = pack ("xxcxxc", 'A', 'B'); % ==> a = "\0\0A\0\0B"; + a = pack ("h2", 'A', 'B'); % ==> a = "\0A\0B" or "\0B\0A" + a = pack (">h2", 'A', 'B'); % ==> a = "\0\xA\0\xB" + a = pack (" a = "\0B\0A" + a = pack ("s4", "AB", "CD"); % ==> a = "AB\0\0" + a = pack ("s4s2", "AB", "CD"); % ==> a = "AB\0\0CD" + a = pack ("S4", "AB", "CD"); % ==> a = "AB " + a = pack ("S4S2", "AB", "CD"); % ==> a = "AB CD" + + + SEE ALSO + unpack, sizeof_pack, pad_pack_format, sprintf +-------------------------------------------------------------- + +pad_pack_format + + SYNOPSIS + Add padding to a pack format + + USAGE + BString_Type pad_pack_format (String_Type fmt) + + DESCRIPTION + The `pad_pack_format' function may be used to add the + appropriate padding to the format `fmt' such that the data types + specified by the format will be properly aligned for the system. + This is especially important when reading or writing files that + assume the native alignment. + + See the S-Lang User's Guide for more information about the use of + this function. + + SEE ALSO + pack, unpack, sizeof_pack +-------------------------------------------------------------- + +sizeof_pack + + SYNOPSIS + Compute the size implied by a pack format string + + USAGE + UInt_Type sizeof_pack (String_Type fmt) + + DESCRIPTION + The `sizeof_pack' function returns the size of the binary string + represented by the format string `fmt'. This information may be + needed when reading a structure from a file. + + NOTES + + SEE ALSO + pack, unpack, pad_pack_format +-------------------------------------------------------------- + +unpack + + SYNOPSIS + Unpack Objects from a Binary String + + USAGE + (...) = unpack (String_Type fmt, BString_Type s) + + DESCRIPTION + The `unpack' function unpacks objects from a binary string + `s' according to the format `fmt' and returns the objects to + the stack in the order in which they were unpacked. See the + documentation of the `pack' function for details about the + format string. + + EXAMPLE + + (x,y) = unpack ("cc", "AB"); % ==> x = 'A', y = 'B' + x = unpack ("c2", "AB"); % ==> x = ['A', 'B'] + x = unpack ("x x = 0xCDABuh + x = unpack ("xxs4", "a b c\0d e f"); % ==> x = "b c\0" + x = unpack ("xxS4", "a b c\0d e f"); % ==> x = "b c" + + + SEE ALSO + pack, sizeof_pack, pad_pack_format +-------------------------------------------------------------- + +_clear_error + + SYNOPSIS + Clear an error condition + + USAGE + _clear_error () + + DESCRIPTION + This function may be used in error-blocks to clear the error that + triggered execution of the error block. Execution resumes following + the statement, in the scope of the error-block, that triggered the + error. + + EXAMPLE + Consider the following wrapper around the `putenv' function: + + define try_putenv (name, value) + { + variable status; + ERROR_BLOCK + { + _clear_error (); + status = -1; + } + status = 0; + putenv (sprintf ("%s=%s", name, value); + return status; + } + + If `putenv' fails, it generates an error condition, which the + `try_putenv' function catches and clears. Thus `try_putenv' + is a function that returns `-1' upon failure and `0' upon + success. + + SEE ALSO + _trace_function, _slangtrace, _traceback +-------------------------------------------------------------- + +_debug_info + + SYNOPSIS + Configure debugging information + + USAGE + Integer_Type _debug_info + + DESCRIPTION + The `_debug_info' variable controls whether or not extra code + should be generated for additional debugging and traceback + information. Currently, if `_debug_info' is zero, no extra code + will be generated; otherwise extra code will be inserted into the + compiled bytecode for additional debugging data. + + The value of this variable is local to each compilation unit and + setting its value in one unit has no effect upon its value in other + units. + + EXAMPLE + + _debug_info = 1; % Enable debugging information + + + NOTES + Setting this variable to a non-zero value may slow down the + interpreter somewhat. + + SEE ALSO + _traceback, _slangtrace +-------------------------------------------------------------- + +_slangtrace + + SYNOPSIS + Turn function tracing on or off. + + USAGE + Integer_Type _slangtrace + + DESCRIPTION + The `_slangtrace' variable is a debugging aid that when set to a + non-zero value enables tracing when function declared by + `_trace_function' is entered. If the value is greater than + zero, both intrinsic and user defined functions will get traced. + However, if set to a value less than zero, intrinsic functions will + not get traced. + + SEE ALSO + _trace_function, _traceback, _print_stack +-------------------------------------------------------------- + +_trace_function + + SYNOPSIS + Set the function to trace + + USAGE + _trace_function (String_Type f) + + DESCRIPTION + `_trace_function' declares that the S-Lang function with name + `f' is to be traced when it is called. Calling + `_trace_function' does not in itself turn tracing on. Tracing + is turned on only when the variable `_slangtrace' is non-zero. + + SEE ALSO + _slangtrace, _traceback +-------------------------------------------------------------- + +_traceback + + SYNOPSIS + Generate a traceback upon error + + USAGE + Integer_Type _traceback + + DESCRIPTION + `_traceback' is an intrinsic integer variable whose value + controls whether or not a traceback of the call stack is to be + generated upon error. If `_traceback' is greater than zero, a + full traceback will be generated, which includes the values of local + variables. If the value is less than zero, a traceback will be + generated without local variable information, and if + `_traceback' is zero the traceback will not be generated. + + Local variables are represented in the form `$n' where `n' is an + integer numbered from zero. More explicitly, `$0' represents the + first local variable, `$1' represents the second, and so on. + Please note that function parameters are local variables and that the + first parameter corresponds to `$0'. + + SEE ALSO + _slangtrace, error +-------------------------------------------------------------- + +chdir + + SYNOPSIS + Change the current working directory. + + USAGE + Integer_Type chdir (String_Type dir) + + DESCRIPTION + The `chdir' function may be used to changed the current working + directory to the directory specified by `dir'. Upon success it + returns zero; however, upon failure it returns `-1' and sets + `errno' accordingly. + + SEE ALSO + mkdir, stat_file +-------------------------------------------------------------- + +chmod + + SYNOPSIS + Change the mode of a file + + USAGE + Integer_Type chmod (String_Type file, Integer_Type mode) + + DESCRIPTION + The `chmod' function changes the permissions of `file' to those + specified by `mode'. It returns `0' upon success, or + `-1' upon failure setting `errno' accordingly. + + See the system specific documentation for the C library + function `chmod' for a discussion of the `mode' parameter. + + SEE ALSO + chown, stat_file +-------------------------------------------------------------- + +chown + + SYNOPSIS + Change the owner of a file + + USAGE + Integer_Type chown (String_Type file, Integer_Type uid, Integer_Type gid) + + DESCRIPTION + The `chown' function is used to change the user-id and group-id of + `file' to `uid' and `gid', respectively. It returns + `zero' upon success and `-1' upon failure, with `errno' + set accordingly. + + NOTES + On most systems, only the super user can change the ownership of a + file. + + Some systems do not support this function. + + SEE ALSO + chmod, stat_file +-------------------------------------------------------------- + +getcwd + + SYNOPSIS + Get the current working directory + + USAGE + String_Type getcwd () + + DESCRIPTION + The `getcwd' function returns the absolute pathname of the + current working directory. If an error occurs or it cannot + determine the working directory, it returns `NULL' and sets + `errno' accordingly. + + NOTES + Under Unix, OS/2, and MSDOS, the pathname returned by this function + includes the trailing slash character. Some versions also include + the drive specifier. + + SEE ALSO + mkdir, chdir, errno +-------------------------------------------------------------- + +listdir + + SYNOPSIS + Get a list of the files in a directory + + USAGE + String_Type[] listdir (String_Type dir) + + DESCRIPTION + The `listdir' function returns the directory listing of all the + files in the specified directory `dir' as an array of strings. + It does not return the special files `".."' and `"."' as + part of the list. + + SEE ALSO + stat_file, stat_is, length +-------------------------------------------------------------- + +lstat_file + + SYNOPSIS + Get information about a symbolic link + + USAGE + Struct_Type lstat_file (String_Type file) + + DESCRIPTION + The `lstat_file' function behaves identically to `stat_file' + but if `file' is a symbolic link, `lstat_file' returns + information about the link itself, and not the file that it + references. + + See the documentation for `stat_file' for more information. + + NOTES + On systems that do not support symbolic links, there is no + difference between this function and the `stat_file' function. + + SEE ALSO + stat_file, readlink +-------------------------------------------------------------- + +mkdir + + SYNOPSIS + Create a new directory + + USAGE + Integer_Type mkdir (String_Type dir, Integer_Type mode) + + DESCRIPTION + The `mkdir' function creates a directory whose name is specified + by the `dir' parameter with permissions specified by `mode'. + Upon success `mkdir' returns zero, or it returns `-1' and + sets `errno' accordingly. In particular, if the directory + already exists, the function will fail and set errno to + `EEXIST'. + + EXAMPLE + + define my_mkdir (dir) + { + if (0 == mkdir (dir, 0777)) return; + if (errno == EEXIST) return; + verror ("mkdir %s failed: %s", dir, errno_string (errno)); + } + + + NOTES + The `mode' parameter may not be meaningful on all systems. On + systems where it is meaningful, the actual permissions on the newly + created directory are modified by the process's umask. + + SEE ALSO + rmdir, getcwd, chdir, fopen, errno +-------------------------------------------------------------- + +readlink + + SYNOPSIS + String_Type readlink (String_Type path) + + USAGE + Get the value of a symbolic link + + DESCRIPTION + The `readlink' function returns the value of a symbolic link and + returns it as a string. Upon failure, NULL is returned and + `errno' set accordingly. + + NOTES + Not all systems support this function. + + SEE ALSO + lstat_file, stat_file, stat_is +-------------------------------------------------------------- + +remove + + SYNOPSIS + Delete a file + + USAGE + Integer_Type remove (String_Type file) + + DESCRIPTION + The `remove' function deletes a file. It returns 0 upon + success, or -1 upon error and sets `errno' accordingly. + + SEE ALSO + rename, rmdir +-------------------------------------------------------------- + +rename + + SYNOPSIS + Rename a file + + USAGE + Integer_Type rename (String_Type old, String_Type new) + + DESCRIPTION + The `rename' function renames a file from `old' to `new' + moving it between directories if necessary. This function may fail + if the directories do not refer to the same file system. It returns + 0 upon success, or -1 upon error and sets `errno' accordingly. + + SEE ALSO + remove, errno +-------------------------------------------------------------- + +rmdir + + SYNOPSIS + Remove a directory + + USAGE + Integer_Type rmdir (String_Type dir) + + DESCRIPTION + The `rmdir' function deletes a specified directory. It returns + 0 upon success or -1 upon error and sets `errno' accordingly. + + NOTES + The directory must be empty before it can be removed. + + SEE ALSO + rename, remove, mkdir +-------------------------------------------------------------- + +stat_file + + SYNOPSIS + Get information about a file + + USAGE + Struct_Type stat_file (String_Type file) + + DESCRIPTION + The `stat_file' function returns information about `file' + through the use of the system `stat' call. If the stat call + fails, the function returns `NULL' and sets errno accordingly. + If it is successful, it returns a stat structure with the following + integer fields: + + st_dev + st_ino + st_mode + st_nlink + st_uid + st_gid + st_rdev + st_size + st_atime + st_mtime + st_ctime + + See the man page for `stat' for a discussion of these fields. + + EXAMPLE + The following example shows how the `stat_file' function may be + used to get the size of a file: + + define file_size (file) + { + variable st; + st = stat_file(file); + if (st == NULL) verror ("Unable to stat %s", file); + return st.st_size; + } + + + SEE ALSO + lstat_file, stat_is +-------------------------------------------------------------- + +stat_is + + SYNOPSIS + Parse the var{st_mode + + USAGE + Char_Type stat_is (String_Type type, Integer_Type st_mode) + + DESCRIPTION + The `stat_is' function returns a signed character value about + the type of file specified by `st_mode'. Specifically, + `type' must be one of the strings: + + "sock" (socket) + "fifo" (fifo) + "blk" (block device) + "chr" (character device) + "reg" (regular file) + "lnk" (link) + "dir" (dir) + + It returns a non-zero value if `st_mode' corresponds to + `type'. + + EXAMPLE + The following example illustrates how to use the `stat_is' + function to determine whether or not a file is a directory: + + define is_directory (file) + { + variable st; + + st = stat_file (file); + if (st == NULL) return 0; + return stat_is ("dir", st.st_mode); + } + + + SEE ALSO + stat_file, lstat_file +-------------------------------------------------------------- + +autoload + + SYNOPSIS + Load a function from a file + + USAGE + autoload (String_Type funct, String_Type file) + + DESCRIPTION + The `autoload' function is used to declare `funct' to the + interpreter and indicate that it should be loaded from `file' when + it is actually used. + + EXAMPLE + Suppose `bessel_j0' is a function defined in the file + `bessel.sl'. Then the statement + + autoload ("bessel_j0", "bessel.sl"); + + will cause `bessel.sl' to be loaded prior to the execution of + `bessel_j0' + + SEE ALSO + evalfile +-------------------------------------------------------------- + +byte_compile_file + + SYNOPSIS + Compile a file to byte-code for faster loading. + + USAGE + byte_compile_file (String_Type file, Integer_Type method) + + DESCRIPTION + The `byte_compile_file' function byte-compiles `file' + producing a new file with the same name except a `'c'' is added + to the output file name. For example, `file' is + `"site.sl"', then the function produces a new file named + `site.slc'. + + NOTES + The `method' parameter is not used in the current + implementation. Its use is reserved for the future. For now, set + it to `0'. + + SEE ALSO + evalfile +-------------------------------------------------------------- + +eval + + SYNOPSIS + Interpret a string as slang code + + USAGE + eval (String_Type expression, [,String_Type namespace]) + + DESCRIPTION + The `eval' function parses a string as S-Lang code and executes the + result. If called with the optional namespace argument, then the + string will be evaluated in the specified namespace. + + This is a useful function in many contexts such as dynamically + generating function definitions where there is no way to generate + them otherwise. + + EXAMPLE + + if (0 == is_defined ("my_function")) + eval ("define my_function () { message (\"my_function\"); }"); + + + SEE ALSO + is_defined, autoload, evalfile +-------------------------------------------------------------- + +evalfile + + SYNOPSIS + Interpret a file containing slang code. + + USAGE + Integer_Type evalfile (String_Type file, [,String_Type namespace]) + + DESCRIPTION + The `evalfile' function loads `file' into the interpreter + and executes it. If called with the optional namespace argument, + the file will be loaded into the specified namespace, which will be + created if necessary. If no errors were encountered, `1' will + be returned; otherwise, a S-Lang error will be generated and the + function will return zero. + + EXAMPLE + + define load_file (file) + { + ERROR_BLOCK { _clear_error (); } + () = evalfile (file); + } + + + NOTES + For historical reasons, the return value of this function is not + really useful. + + The file is searched along an application-defined load-path. The + `get_slang_load_path' and `set_slang_load_path' functions + may be used to set and query the path. + + SEE ALSO + eval, autoload, set_slang_load_path, get_slang_load_path +-------------------------------------------------------------- + +get_slang_load_path + + SYNOPSIS + Get the value of the interpreter's load-path + + USAGE + String_Type get_slang_load_path () + + DESCRIPTION + This function retrieves the value of the delimiter-separated search + path used for loading files. + + NOTES + Some applications may not support the built-in load-path searching + facility provided by the underlying library. + + SEE ALSO + +-------------------------------------------------------------- + +set_slang_load_path + + SYNOPSIS + Set the value of the interpreter's load-path + + USAGE + set_slang_load_path (String_Type path) + + DESCRIPTION + This function may be used to set the value of the + delimiter-separated search path used by the `evalfile' and + `autoload' functions for locating files. + + EXAMPLE + + public define prepend_to_slang_load_path (p) + { + variable s = stat_file (p); + if (s == NULL) return; + if (0 == stat_is ("dir", s.st_mode)) + return; + + variable d = path_get_delimiter (); + set_slang_load_path (strcat (p, d, get_slang_load_path ())); + } + + + NOTES + Some applications may not support the built-in load-path searching + facility provided by the underlying library. + + SEE ALSO + get_slang_load_path, path_get_delimiter, evalfile, autoload +-------------------------------------------------------------- + +get_import_module_path + + SYNOPSIS + Get the search path for dynamically loadable objects + + USAGE + String_Type get_import_module_path () + + DESCRIPTION + The `get_import_module_path' may be used to get the search path + for dynamically shared objects. Such objects may be made accessable + to the application via the `import' function. + + SEE ALSO + import, set_import_module_path +-------------------------------------------------------------- + +import + + SYNOPSIS + Dynamically link to a specified module + + USAGE + import (String_Type module [, String_Type namespace]) + + DESCRIPTION + The `import' function causes the run-time linker to dynamically + link to the shared object specified by the `module' parameter. + It seaches for the shared object as follows: First a search is + performed along all module paths specified by the application. Then + a search is made along the paths defined via the + `set_import_module_path' function. If not found, a search is + performed along the paths given by the `SLANG_MODULE_PATH' + environment variable. Finally, a system dependent search is + performed (e.g., using the `LD_LIBRARY_PATH' environment + variable). + + The optional second parameter may be used to specify a namespace + for the intrinsic functions and variables of the module. If this + parameter is not present, the intrinsic objects will be placed into + the global namespace. + + This function signals an error if the specified module is not found. + + NOTES + The `import' function is not available on all systems. + + SEE ALSO + set_import_module_path, use_namespace, current_namespace, getenv, evalfile +-------------------------------------------------------------- + +set_import_module_path + + SYNOPSIS + Set the search path for dynamically loadable objects + + USAGE + set_import_module_path (String_Type path_list) + + DESCRIPTION + The `set_import_module_path' may be used to set the search path + for dynamically shared objects. Such objects may be made accessable + to the application via the `import' function. + + The actual syntax for the specification of the set of paths will + vary according to the operating system. Under Unix, a colon + character is used to separate paths in `path_list'. For win32 + systems a semi-colon is used. + + SEE ALSO + import, get_import_module_path +-------------------------------------------------------------- + +_NARGS + + SYNOPSIS + The number of parameters passed to a function + + USAGE + Integer_Type _NARGS + + EXAMPLE + This example uses the `_NARGS' variable to print the list of + values passed to the function: + + define print_values () + { + variable arg; + + if (_NARGS == 0) + { + message ("Nothing to print"); + return; + } + foreach (__pop_args (_NARGS)) + { + arg = (); + vmessage ("Argument value is: %S", arg.value); + } + } + + + SEE ALSO + __pop_args, __push_args, typeof +-------------------------------------------------------------- + +__get_defined_symbols + + SYNOPSIS + Get the symbols defined by the preprocessor + + USAGE + Integer_Type __get_defined_symbols () + + DESCRIPTION + The `__get_defined_symbols' functions is used to get the list of + all the symbols defined by the S-Lang preprocessor. It pushes each + of the symbols on the stack followed by the number of items pushed. + + SEE ALSO + is_defined, _apropos, _get_namespaces +-------------------------------------------------------------- + +__is_initialized + + SYNOPSIS + Determine whether or not a variable has a value + + USAGE + Integer_Type __is_initialized (Ref_Type r) + + DESCRIPTION + This function returns non-zero of the object referenced by `r' + is initialized, i.e., whether it has a value. It returns 0 if the + referenced object has not been initialized. + + EXAMPLE + For example, the function: + + define zero () + { + variable f; + return __is_initialized (&f); + } + + will always return zero, but + + define one () + { + variable f = 0; + return __is_initialized (&f); + } + + will return one. + + NOTES + It is easy to see why a reference to the variable must be passed to + `__is_initialized' and not the variable itself; otherwise, the + value of the variable would be passed and the variable may have no + value if it was not initialized. + + SEE ALSO + __get_reference, __uninitialize, is_defined, typeof, eval +-------------------------------------------------------------- + +_apropos + + SYNOPSIS + Generate a list of functions and variables + + USAGE + Array_Type _apropos (String_Type ns, String_Type s, Integer_Type flags) + + DESCRIPTION + The `_apropos' function may be used to get a list of all defined + objects in the namespace `ns' whose name matches the regular + expression `s' and whose type matches those specified by + `flags'. It returns an array of strings representing the + matches. + + The second parameter `flags' is a bit mapped value whose bits + are defined according to the following table + + 1 Intrinsic Function + 2 User-defined Function + 4 Intrinsic Variable + 8 User-defined Variable + + + EXAMPLE + + define apropos (s) + { + variable n, name, a; + a = _apropos ("Global", s, 0xF); + + vmessage ("Found %d matches:", length (a)); + foreach (a) + { + name = (); + message (name); + } + } + + prints a list of all matches. + + NOTES + If the namespace specifier `ns' is the empty string `""', + then the namespace will default to the static namespace of the + current compilation unit. + + SEE ALSO + is_defined, sprintf, _get_namespaces +-------------------------------------------------------------- + +_function_name + + SYNOPSIS + Returns the name of the currently executing function + + USAGE + String_Type _function_name () + + DESCRIPTION + This function returns the name of the currently executing function. + If called from top-level, it returns the empty string. + + SEE ALSO + _trace_function, is_defined +-------------------------------------------------------------- + +_get_namespaces + + SYNOPSIS + Returns a list of namespace names + + USAGE + String_Type[] _get_namespaces () + + DESCRIPTION + This function returns a string array containing the names of the + currently defined namespaces. + + SEE ALSO + _apropos, use_namespace, implements, __get_defined_symbols +-------------------------------------------------------------- + +_slang_doc_dir + + SYNOPSIS + Installed documentation directory + + USAGE + String_Type _slang_doc_dir; + + DESCRIPTION + The `_slang_doc_dir' variable is a read-only whose value + specifies the installation location of the S-Lang documentation. + + SEE ALSO + get_doc_string_from_file +-------------------------------------------------------------- + +_slang_version + + SYNOPSIS + The S-Lang library version number + + USAGE + Integer_Type _slang_version + + DESCRIPTION + The `_slang_version' variable is read-only and whose + value represents the number of the S-Lang library. + + SEE ALSO + _slang_version_string +-------------------------------------------------------------- + +_slang_version_string + + SYNOPSIS + The S-Lang library version number as a string + + USAGE + String_Type _slang_version_string + + DESCRIPTION + The `_slang_version_string' variable is read-only and whose + value represents the version number of the S-Lang library. + + SEE ALSO + _slang_version +-------------------------------------------------------------- + +get_doc_string_from_file + + SYNOPSIS + Read documentation from a file + + USAGE + String_Type get_doc_string_from_file (String_Type f, String_Type t) + + DESCRIPTION + `get_doc_string_from_file' opens the documentation file `f' + and searches it for topic `t'. It returns the documentation for + `t' upon success, otherwise it returns `NULL' upon error. + It will fail if `f' could not be opened or does not contain + documentation for the topic. + + SEE ALSO + stat_file + + SEE ALSO + _slang_doc_dir +-------------------------------------------------------------- + +is_defined + + SYNOPSIS + Indicate whether a variable or function defined. + + USAGE + Integer_Type is_defined (String_Type obj) + + DESCRIPTION + This function is used to determine whether or not a function or + variable whose name is `obj' has been defined. If `obj' is not + defined, the function returns 0. Otherwise, it returns a non-zero + value that defpends on the type of object `obj' represents. + Specifically, it returns one of the following values: + + +1 if an intrinsic function + +2 if user defined function + -1 if intrinsic variable + -2 if user defined variable + 0 if undefined + + + EXAMPLE + For example, consider the function: + + define runhooks (hook) + { + if (2 == is_defined(hook)) eval(hook); + } + + This function could be called from another S-Lang function to + allow customization of that function, e.g., if the function + represents a mode, the hook could be called to setup keybindings + for the mode. + + SEE ALSO + typeof, eval, autoload, __get_reference, __is_initialized +-------------------------------------------------------------- + +Conj + + SYNOPSIS + Compute the complex conjugate of a number + + USAGE + z1 = Conj (z) + + DESCRIPTION + The `Conj' function returns the complex conjugate of a number. + If its argument is an array, the `Conj' function will be applied to each + element and the result returned as an array. + + SEE ALSO + Real, Imag, abs +-------------------------------------------------------------- + +Imag + + SYNOPSIS + Compute the imaginary part of a number + + USAGE + i = Imag (z) + + DESCRIPTION + The `Imag' function returns the imaginary part of a number. + If its argument is an array, the `Imag' function will be applied to each + element and the result returned as an array. + + SEE ALSO + Real, Conj, abs +-------------------------------------------------------------- + +Real + + SYNOPSIS + Compute the real part of a number + + USAGE + r = Real (z) + + DESCRIPTION + The `Real' function returns the real part of a number. If its + argument is an array, the `Real' function will be applied to + each element and the result returned as an array. + + SEE ALSO + Imag, Conj, abs +-------------------------------------------------------------- + +abs + + SYNOPSIS + Compute the absolute value of a number + + USAGE + y = abs(x) + + DESCRIPTION + The `abs' function returns the absolute value of an arithmetic + type. If its argument is a complex number (`Complex_Type'), + then it returns the modulus. If the argument is an array, a new + array will be created whose elements are obtained from the original + array by using the `abs' function. + + SEE ALSO + sign, sqr +-------------------------------------------------------------- + +acos + + SYNOPSIS + Compute the arc-cosine of an number + + USAGE + y = acos (x) + + DESCRIPTION + The `acos' function computes the arc-cosine of a number and + returns the result as an array. If its argument is an array, the + `acos' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +acosh + + SYNOPSIS + Compute the inverse cosh of an number + + USAGE + y = acosh (x) + + DESCRIPTION + The `acosh' function computes the inverse cosh of a number and + returns the result as an array. If its argument is an array, the + `acosh' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +asin + + SYNOPSIS + Compute the arc-sine of an number + + USAGE + y = asin (x) + + DESCRIPTION + The `asin' function computes the arc-sine of a number and + returns the result as an array. If its argument is an array, the + `asin' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +asinh + + SYNOPSIS + Compute the inverse-sinh of an number + + USAGE + y = asinh (x) + + DESCRIPTION + The `asinh' function computes the inverse-sinh of a number and + returns the result as an array. If its argument is an array, the + `asinh' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +atan + + SYNOPSIS + Compute the arc-tangent of an number + + USAGE + y = atan (x) + + DESCRIPTION + The `atan' function computes the arc-tangent of a number and + returns the result as an array. If its argument is an array, the + `atan' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +atanh + + SYNOPSIS + Compute the inverse-tanh of an number + + USAGE + y = atanh (x) + + DESCRIPTION + The `atanh' function computes the inverse-tanh of a number and + returns the result as an array. If its argument is an array, the + `atanh' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +cos + + SYNOPSIS + Compute the cosine of an number + + USAGE + y = cos (x) + + DESCRIPTION + The `cos' function computes the cosine of a number and + returns the result as an array. If its argument is an array, the + `cos' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +cosh + + SYNOPSIS + Compute the hyperbolic cosine of an number + + USAGE + y = cosh (x) + + DESCRIPTION + The `cosh' function computes the hyperbolic cosine of a number and + returns the result as an array. If its argument is an array, the + `cosh' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +exp + + SYNOPSIS + Compute the exponential of an number + + USAGE + y = exp (x) + + DESCRIPTION + The `exp' function computes the exponential of a number and + returns the result as an array. If its argument is an array, the + `exp' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +log + + SYNOPSIS + Compute the logarithm of an number + + USAGE + y = log (x) + + DESCRIPTION + The `log' function computes the logarithm of a number and + returns the result as an array. If its argument is an array, the + `log' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +log10 + + SYNOPSIS + Compute the base-10 logarithm of an number + + USAGE + y = log10 (x) + + DESCRIPTION + The `log10' function computes the base-10 logarithm of a number and + returns the result as an array. If its argument is an array, the + `log10' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +mul2 + + SYNOPSIS + Multiply a number by 2 + + USAGE + y = mul2(x) + + DESCRIPTION + The `mul2' function multiplies an arithmetic type by two and + returns the result. If its argument is an array, a new array will + be created whose elements are obtained from the original array by + using the `mul2' function. + + SEE ALSO + sqr, abs +-------------------------------------------------------------- + +polynom + + SYNOPSIS + Evaluate a polynomial + + USAGE + Double_Type polynom(Double_Type a, b, ...c, Integer_Type n, Double_Type x) + + DESCRIPTION + The `polynom' function returns the value of the polynomial expression: + + ax^n + bx^(n - 1) + ... c + + + NOTES + The `polynom' function should be extended to work with complex + and array data types. The current implementation is limited to + `Double_Type' quantities. + + SEE ALSO + exp +-------------------------------------------------------------- + +set_float_format + + SYNOPSIS + Set the format for printing floating point values. + + USAGE + set_float_format (String_Type fmt) + + DESCRIPTION + The `set_float_format' function is used to set the floating + point format to be used when floating point numbers are printed. + The routines that use this are the traceback routines and the + `string' function. The default value is `"%f"' + + EXAMPLE + + s = string (PI); % --> s = "3.14159" + set_float_format ("%16.10f"); + s = string (PI); % --> s = "3.1415926536" + set_float_format ("%10.6e"); + s = string (PI); % --> s = "3.141593e+00" + + + SEE ALSO + string, sprintf, double +-------------------------------------------------------------- + +sign + + SYNOPSIS + Compute the sign of a number + + USAGE + y = sign(x) + + DESCRIPTION + The `sign' function returns the sign of an arithmetic type. If + its argument is a complex number (`Complex_Type'), it returns + the sign of the imaginary part of the number. If the argument is an + array, a new array will be created whose elements are obtained from + the original array by using the `sign' function. + + When applied to a real number or an integer, the `sign' function + returns -1, 0, or `+1' according to whether the number is + less than zero, equal to zero, or greater than zero, respectively. + + SEE ALSO + abs +-------------------------------------------------------------- + +sin + + SYNOPSIS + Compute the sine of an number + + USAGE + y = sin (x) + + DESCRIPTION + The `sin' function computes the sine of a number and + returns the result as an array. If its argument is an array, the + `sin' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +sinh + + SYNOPSIS + Compute the hyperbolic sine of an number + + USAGE + y = sinh (x) + + DESCRIPTION + The `sinh' function computes the hyperbolic sine of a number and + returns the result as an array. If its argument is an array, the + `sinh' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +sqr + + SYNOPSIS + Compute the square of a number + + USAGE + y = sqr(x) + + DESCRIPTION + The `sqr' function returns the square of an arithmetic type. If its + argument is a complex number (`Complex_Type'), then it returns + the square of the modulus. If the argument is an array, a new array + will be created whose elements are obtained from the original array + by using the `sqr' function. + + SEE ALSO + abs, mul2 +-------------------------------------------------------------- + +sqrt + + SYNOPSIS + Compute the square root of an number + + USAGE + y = sqrt (x) + + DESCRIPTION + The `sqrt' function computes the square root of a number and + returns the result as an array. If its argument is an array, the + `sqrt' function will be applied to each element and the result returned + as an array. + + SEE ALSO + sqr, cos, atan, acosh, cosh +-------------------------------------------------------------- + +tan + + SYNOPSIS + Compute the tangent of an number + + USAGE + y = tan (x) + + DESCRIPTION + The `tan' function computes the tangent of a number and + returns the result as an array. If its argument is an array, the + `tan' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +tanh + + SYNOPSIS + Compute the hyperbolic tangent of an number + + USAGE + y = tanh (x) + + DESCRIPTION + The `tanh' function computes the hyperbolic tangent of a number and + returns the result as an array. If its argument is an array, the + `tanh' function will be applied to each element and the result returned + as an array. + + SEE ALSO + cos, atan, acosh, cosh +-------------------------------------------------------------- + +error + + SYNOPSIS + Generate an error condition + + USAGE + error (String_Type msg + + DESCRIPTION + The `error' function generates a S-Lang error condition causing + the interpreter to start unwinding to top-level. It takes a single + string parameter which is displayed on the stderr output device. + The error condition may be cleared via an `ERROR_BLOCK' with the + `_clear_error' function. Consult \user-manual for more + information. + + EXAMPLE + + define add_txt_extension (file) + { + if (typeof (file) != String_Type) + error ("add_extension: parameter must be a string"); + file += ".txt"; + return file; + } + + + SEE ALSO + verror, _clear_error, message +-------------------------------------------------------------- + +message + + SYNOPSIS + Print a string onto the message device + + USAGE + message (String_Type s + + DESCRIPTION + The `message' function will print the string specified by + `s' onto the message device. + + EXAMPLE + + define print_current_time () + { + message (time ()); + } + + + NOTES + The message device will depend upon the application. For example, + the output message device for the `jed' editor correspond to the + line at the bottom of the display window. The default message + device is the standard output device. + + SEE ALSO + vmessage, sprintf, error +-------------------------------------------------------------- + +usage + + SYNOPSIS + Generate a usage error + + USAGE + usage (String_Type msg) + + DESCRIPTION + The `usage' function generates a usage exception and displays + `msg' to the message device. + + EXAMPLE + Suppose that some function `plot' plots an array of `x' and + `y' values. The such a function could be written to issue a + usage message if the wrong number of arguments were passed: + + define plot () + { + variable x, y; + + if (_NARGS != 2) + usage ("plot (x, y)"); + + (x, y) = (); + % Now do the hard part + . + . + } + + + SEE ALSO + error, message +-------------------------------------------------------------- + +verror + + SYNOPSIS + Generate an error condition + + USAGE + verror (String_Type fmt, ...) + + DESCRIPTION + The `verror' function performs the same role as the `error' + function. The only difference is that instead of a single string + argument, `verror' takes a sprintf style argument list. + + EXAMPLE + + define open_file (file) + { + variable fp; + + fp = fopen (file, "r"); + if (fp == NULL) verror ("Unable to open %s", file); + return fp; + } + + + NOTES + In the current implementation, strictly speaking, the `verror' + function is not an intrinsic function. Rather it is a predefined + S-Lang function using a combination of `Sprintf' and + `error'. + + SEE ALSO + error, Sprintf, vmessage +-------------------------------------------------------------- + +vmessage + + SYNOPSIS + Print a formatted string onto the message device + + USAGE + vmessage (String_Type fmt, ...) + + DESCRIPTION + The `vmessage' function formats a sprintf style argument list + and displays the resulting string onto the message device. + + NOTES + In the current implementation, strictly speaking, the `vmessage' + function is not an intrinsic function. Rather it is a predefined + S-Lang function using a combination of `Sprintf' and + `message'. + + SEE ALSO + message, Sprintf, verror +-------------------------------------------------------------- + +__class_id + + SYNOPSIS + Return the class-id of a specified type + + USAGE + Int_Type __class_id (DataType_Type type)) + + DESCRIPTION + This function returns the internal class-id of a specified data type. + + SEE ALSO + typeof, _typeof, __class_type +-------------------------------------------------------------- + +__class_type + + SYNOPSIS + Return the class-type of a specified type + + USAGE + Int_Type __class_type (DataType_Type type)) + + DESCRIPTION + Internally S-Lang objects are classified according to four types: + scalar, vector, pointer, and memory managed types. For example, an + integer is implemented as a scalar, a complex number as a vector, + and a string is represented as a pointer. The `__class_type' + function returns an integer representing the class-type associated + with the specified data type. Specifically, it returns: + + 0 memory-managed + 1 scalar + 2 vector + 3 pointer + + + SEE ALSO + typeof, _typeof, __class_id +-------------------------------------------------------------- + +__eqs + + SYNOPSIS + Test for equality between two objects + + USAGE + Int_Type __eqs (a, b) + + DESCRIPTION + This function tests its two arguments for equalit and returns 1 + if they are equal, and 0 otherwise. To be equal, the data type of + the arguments must match and the values of the objects must + reference the same underlying object. + + EXAMPLE + __eqs (1, 1) ===> 1 + __eqs (1, 1.0) ===> 0 + __eqs ("a", 1) ===> 0 + __eqs ([1,2], [1,2]) ===> 0 + + SEE ALSO + typeof, __get_reference + + NOTES + This function should be thought of as a test for "sameness". +-------------------------------------------------------------- + +__get_reference + + SYNOPSIS + Get a reference to a global object + + USAGE + Ref_Type __get_reference (String_Type nm) + + DESCRIPTION + This function returns a reference to a global variable or function + whose name is specified by `nm'. If no such object exists, it + returns `NULL', otherwise it returns a reference. + + EXAMPLE + For example, consider the function: + + define runhooks (hook) + { + variable f; + f = __get_reference (hook); + if (f != NULL) + @f (); + } + + This function could be called from another S-Lang function to + allow customization of that function, e.g., if the function + represents a mode, the hook could be called to setup keybindings + for the mode. + + SEE ALSO + is_defined, typeof, eval, autoload, __is_initialized, __uninitialize +-------------------------------------------------------------- + +__uninitialize + + SYNOPSIS + Uninitialize a variable + + USAGE + __uninitialize (Ref_Type x) + + DESCRIPTION + The `__uninitialize' function may be used to uninitialize the + variable referenced by the parameter `x'. + + EXAMPLE + The following two lines are equivalent: + + () = __tmp(z); + __uninitialize (&z); + + + SEE ALSO + __tmp, __is_initialized +-------------------------------------------------------------- + +_auto_declare + + SYNOPSIS + Set automatic variable declaration mode + + USAGE + Integer_Type _auto_declare + + DESCRIPTION + The `_auto_declare' may be used to have all undefined variables + implicitely declared as `static'. If set to zero, any variable + must be declared witha `variable' declaration before it can be + used. If set to one, then any undeclared variabled will be declared + as a `static' global variable. + + The `_auto_declare' variable is local to each compilation unit and + setting its value in one unit has no effect upon its value in other + units. The value of this variable has no effect upon the variables + in a function. + + EXAMPLE + The following code will not compile if `X' not been + declared: + + X = 1; + + However, + + _auto_declare = 1; % declare variables as static. + X = 1; + + is equivalent to + + static variable X = 1; + + + NOTES + This variable should be used sparingly and is intended primarily for + interactive applications where one types S-Lang commands at a prompt. +-------------------------------------------------------------- + +current_namespace + + SYNOPSIS + Get the name of the current namespace + + USAGE + String_Type current_namespace () + + DESCRIPTION + The `current_namespace' function returns the name of the + current namespace. If the current namespace is anonymous, that is, + has not been given a name via the `implements' function, the + empty string `""' will be returned. + + SEE ALSO + implements, use_namespace, import +-------------------------------------------------------------- + +getenv + + SYNOPSIS + Get the value of an environment variable + + USAGE + String_Type getenv(String_Type var) + + DESCRIPTION + The `getenv' function returns a string that represents the + value of an environment variable `var'. It will return + `NULL' if there is no environment variable whose name is given + by `var'. + + EXAMPLE + + if (NULL != getenv ("USE_COLOR")) + { + set_color ("normal", "white", "blue"); + set_color ("status", "black", "gray"); + USE_ANSI_COLORS = 1; + } + + + SEE ALSO + putenv, strlen, is_defined +-------------------------------------------------------------- + +implements + + SYNOPSIS + Name a private namespace + + USAGE + implements (String_Type name); + + DESCRIPTION + The `implements' function may be used to name the private + namespace associated with the current compilation unit. Doing so + will enable access to the members of the namespace from outside the + unit. The name of the global namespace is `Global'. + + EXAMPLE + Suppose that some file `t.sl' contains: + + implements ("Ts_Private"); + static define message (x) + { + Global->vmessage ("Ts_Private message: %s", x); + } + message ("hello"); + + will produce `"Ts_Private message: hello"'. This `message' + function may be accessed from outside via: + + Ts_Private->message ("hi"); + + + NOTES + Since `message' is an intrinsic function, it is global and may + not be redefined in the global namespace. + + SEE ALSO + use_namespace, current_namespace, import +-------------------------------------------------------------- + +putenv + + SYNOPSIS + Add or change an environment variable + + USAGE + putenv (String_Type s) + + DESCRIPTION + This functions adds string `s' to the environment. Typically, + `s' should of the form `"name=value"'. The function + signals a S-Lang error upon failure. + + NOTES + This function is not available on all systems. + + SEE ALSO + getenv, sprintf +-------------------------------------------------------------- + +use_namespace + + SYNOPSIS + Change to another namespace + + USAGE + use_namespace (String_Type name) + + DESCRIPTION + The `use_namespace' function changes the current namespace to + the one specified by the parameter. If the specified namespace + does not exist, an error will be generated. + + SEE ALSO + implements, current_namespace, import +-------------------------------------------------------------- + +path_basename + + SYNOPSIS + Get the basename part of a pathname + + USAGE + String_Type path_basename (String_Type path) + + DESCRIPTION + The `path_basename' function returns the basename associated + with the `path' parameter. The basename is the non-directory + part of the filename, e.g., on unix `c' is the basename of + `/a/b/c'. + + SEE ALSO + path_dirname, path_extname, path_concat, path_is_absolute +-------------------------------------------------------------- + +path_concat + + SYNOPSIS + Combine elements of a pathname + + USAGE + String_Type path_concat (String_Type dir, String_Type basename) + + DESCRIPTION + The `path_concat' function combines the arguments `dir' and + `basename' to produce a pathname. For example, on unix is + `dir' is `x/y' and `basename' is `z', then the + function will return `x/y/z'. + + SEE ALSO + path_dirname, path_basename, path_extname, path_is_absolute +-------------------------------------------------------------- + +path_dirname + + SYNOPSIS + Get the directory name part of a pathname + + USAGE + String_Type path_dirname (String_Type path) + + DESCRIPTION + The `path_dirname' function returns the directory name + associated with a specified pathname. + + NOTES + On systems that include a drive specifier as part of the pathname, + the value returned by this function will include the driver + specifier. + + SEE ALSO + path_basename, path_extname, path_concat, path_is_absolute +-------------------------------------------------------------- + +path_extname + + SYNOPSIS + Return the extension part of a pathname + + USAGE + String_Type path_extname (String_Type path) + + DESCRIPTION + The `path_extname' function returns the extension portion of a + specified pathname. If an extension is present, this function will + also include the dot as part of the extension, i.e., if `path' + is `file.c', then this function returns `".c"'. If no + extension is present, the function returns an empty string `""'. + + NOTES + Under VMS, the file version number is not returned as part of the + extension. + + SEE ALSO + path_sans_extname, path_dirname, path_basename, path_concat, path_is_absolute +-------------------------------------------------------------- + +path_get_delimiter + + SYNOPSIS + Get the value of a search-path delimiter + + USAGE + Char_Type path_get_delimiter () + + DESCRIPTION + This function returns the value of the character used to delimit + fields of a search-path. + + SEE ALSO + set_slang_load_path, get_slang_load_path +-------------------------------------------------------------- + +path_is_absolute + + SYNOPSIS + Determine whether or not a pathname is absolute + + USAGE + Int_Type path_is_absolute (String_Type path) + + DESCRIPTION + The `path_is_absolute' function will return non-zero is + `path' refers to an absolute pathname, otherwise it returns zero. + + SEE ALSO + path_dirname, path_basename, path_extname, path_concat +-------------------------------------------------------------- + +path_sans_extname + + SYNOPSIS + Strip the extension from a pathname + + USAGE + String_Type path_sans_extname (String_Type path) + + DESCRIPTION + The `path_sans_extname' function removes the file name extension + (including the dot) from the path and returns the result. + + SEE ALSO + path_extname, path_basename, path_dirname, path_concat +-------------------------------------------------------------- + +close + + SYNOPSIS + Close an open file descriptor + + USAGE + Int_Type close (FD_Type fd) + + DESCRIPTION + The `close' function is used to open file descriptor of type + `FD_Type'. Upon success 0 is returned, otherwise the function + returns -1 and sets `errno' accordingly. + + SEE ALSO + open, fclose, read, write +-------------------------------------------------------------- + +dup_fd + + SYNOPSIS + Duplicate a file descriptor + + USAGE + FD_Type dup_fd (FD_Type fd) + + DESCRIPTION + The `dup_fd' function duplicates and file descriptor and returns + its duplicate. If the function fails, NULL will be returned and + `errno' set accordingly. + + NOTES + This function is essentually a wrapper around the POSIX `dup' + function. + + SEE ALSO + open, close +-------------------------------------------------------------- + +fileno + + SYNOPSIS + Convert a stdio File_Type object to a FD_Type descriptor + + USAGE + FD_Type fileno (File_Type fp) + + DESCRIPTION + The `fileno' function returns the `FD_Type' descriptor + associated with the `File_Type' file pointer. Upon failure, + NULL is returned. + + SEE ALSO + fopen, open, fclose, close, dup_fd +-------------------------------------------------------------- + +isatty + + SYNOPSIS + Determine if an open file descriptor refers to a terminal + + USAGE + Int_Type isatty (FD_Type or File_Type fd) + + DESCRIPTION + This function returns 1 if the file descriptor `fd' refers to a + terminal; otherwise it returns 0. The object `fd' may either + be a `File_Type' stdio descriptor or an `FD_Type' object. + + SEE ALSO + fopen, fclose, fileno +-------------------------------------------------------------- + +lseek + + SYNOPSIS + Reposition a file descriptor's file pointer + + USAGE + Long_Type lseek (FD_Type fd, Long_Type ofs, int mode) + + SEEK_SET Set the offset to ofs + SEEK_CUR Add ofs to the current offset + SEEK_END Add ofs to the current file size + + + NOTES + Not all file descriptors are capable of supporting the seek + operation, e.g., a descriptor associated with a pipe. + + By using `SEEK_END' with a positive value of the `ofs' + parameter, it is possible to position the file pointer beyond the + current size of the file. + + SEE ALSO + fseek, ftell, open, close +-------------------------------------------------------------- + +open + + SYNOPSIS + Open a file + + USAGE + FD_Type open (String_Type filename, Int_Type flags [,Int_Type mode]) + + DESCRIPTION + The `open' function attempts to open a file specified by the + `filename' parameter according to the `flags' parameter, + which must be one of the following values: + + O_RDONLY (read-only) + O_WRONLY (write-only) + O_RDWR (read/write) + + In addition, `flags' may also be bitwise-or'd with any of the + following: + + O_BINARY (open the file in binary mode) + O_TEXT (open the file in text mode) + O_CREAT (create file if it does not exist) + O_EXCL (fail if the file already exists) + O_NOCTTY (do not make the device the controlling terminal) + O_TRUNC (truncate the file if it exists) + O_APPEND (open the file in append mode) + O_NONBLOCK (open the file in non-blocking mode) + + Some of these flags only make sense when combined with other flags. + For example, if O_EXCL is used, then O_CREAT must also be + specified, otherwise unpredictable behavior may result. + + If `O_CREAT' is used for the `flags' parameter then the + `mode' parameter must be present. `mode' specifies the + permissions to use if a new file is created. The actual file + permissions will be affected by the process's `umask' via + `mode&~umask'. The `mode' parameter's value is + constructed via bitwise-or of the following values: + + S_IRWXU (Owner has read/write/execute permission) + S_IRUSR (Owner has read permission) + S_IWUSR (Owner has write permission) + S_IXUSR (Owner has execute permission) + S_IRWXG (Group has read/write/execute permission) + S_IRGRP (Group has read permission) + S_IWGRP (Group has write permission) + S_IXGRP (Group has execute permission) + S_IRWXO (Others have read/write/execute permission) + S_IROTH (Others have read permission) + S_IWOTH (Others have write permission) + S_IXOTH (Others have execute permission) + + Upon success `open' returns a file descriptor object + (`FD_Type'), otherwise `NULL' is returned and `errno' + is set. + + NOTES + If you are not familiar with the `open' system call, then it + is recommended that you use `fopen' instead. + + SEE ALSO + fopen, close, read, write, stat_file +-------------------------------------------------------------- + +read + + SYNOPSIS + Read from an open file descriptor + + USAGE + UInt_Type read (FD_Type fd, Ref_Type buf, UInt_Type num) + + DESCRIPTION + The `read' function attempts to read at most `num' bytes + into the variable indicated by `buf' from the open file + descriptor `fd'. It returns the number of bytes read, or -1 + and sets `errno' upon failure. The number of bytes read may be + less than `num', and will be zero if an attempt is made to read + past the end of the file. + + NOTES + `read' is a low-level function and may return -1 for a variety + of reasons. For example, if non-blocking I/O has been specified for + the open file descriptor and no data is available for reading then + the function will return -1 and set `errno' to `EAGAIN'. + + SEE ALSO + fread, open, close, write +-------------------------------------------------------------- + +write + + SYNOPSIS + Write to an open file descriptor + + USAGE + UInt_Type write (FD_Type fd, BString_Type buf) + + DESCRIPTION + The `write' function attempts to write the bytes specified by + the `buf' parameter to the open file descriptor `fd'. It + returns the number of bytes successfully written, or -1 and sets + `errno' upon failure. The number of bytes written may be less + than `length(buf)'. + + SEE ALSO + read, fwrite, open, close +-------------------------------------------------------------- + +errno + + SYNOPSIS + Error code set by system functions. + + USAGE + Integer_Type errno + + DESCRIPTION + A system function can fail for a variety of reasons. For example, a + file operation may fail because lack of disk space, or the process + does not have permission to perform the operation. Such functions + will return `-1' and set the variable `errno' to an error + code describing the reason for failure. + + Particular values of `errno' may be specified by the following + symbolic constants (read-only variables) and the corresponding + `errno_string' value: + + EPERM "Not owner" + ENOENT "No such file or directory" + ESRCH "No such process" + ENXIO "No such device or address" + ENOEXEC "Exec format error" + EBADF "Bad file number" + ECHILD "No children" + ENOMEM "Not enough core" + EACCES "Permission denied" + EFAULT "Bad address" + ENOTBLK "Block device required" + EBUSY "Mount device busy" + EEXIST "File exists" + EXDEV "Cross-device link" + ENODEV "No such device" + ENOTDIR "Not a directory" + EISDIR "Is a directory" + EINVAL "Invalid argument" + ENFILE "File table overflow" + EMFILE "Too many open files" + ENOTTY "Not a typewriter" + ETXTBSY "Text file busy" + EFBIG "File too large" + ENOSPC "No space left on device" + ESPIPE "Illegal seek" + EROFS "Read-only file system" + EMLINK "Too many links" + EPIPE "Broken pipe" + ELOOP "Too many levels of symbolic links" + ENAMETOOLONG "File name too long" + + + EXAMPLE + The `mkdir' function will attempt to create a directory. If + that directory already exists, the function will fail and set + `errno' to `EEXIST'. + + define create_dir (dir) + { + if (0 == mkdir (dir)) return; + if (errno != EEXIST) + error ("mkdir %s failied: %s", dir, errno_string); + } + + + SEE ALSO + errno_string, error, mkdir +-------------------------------------------------------------- + +errno_string + + SYNOPSIS + Return a string describing an errno. + + USAGE + String_Type errno_string (Integer_Type err) + + DESCRIPTION + The `errno_string' function returns a string describing the + integer error code `err'. The variable `err' usually + corresponds to the `errno' intrinsic function. See the + description for `errno' for more information. + + EXAMPLE + The `errno_string' function may be used as follows: + + define sizeof_file (file) + { + variable st = stat (file); + if (st == NULL) + verror ("%s: %s", file, errno_string (errno); + return st.st_size; + } + + + SEE ALSO + errno, stat, verror +-------------------------------------------------------------- + +getegid + + SYNOPSIS + Get the effective group id + + USAGE + Int_Type getegid () + + DESCRIPTION + The `getegid' function returns the effective group ID of the + current process. + + NOTES + This function is not supported by all systems. + + SEE ALSO + getgid, geteuid, setgid +-------------------------------------------------------------- + +geteuid + + SYNOPSIS + Get the effective user-id of the current process + + USAGE + Int_Type geteuid () + + DESCRIPTION + The `geteuid' function returns the effective user-id of the + current process. + + NOTES + This function is not supported by all systems. + + SEE ALSO + getuid, setuid, setgid +-------------------------------------------------------------- + +getgid + + SYNOPSIS + Get the group id + + USAGE + Integer_Type getgid () + + DESCRIPTION + The `getgid' function returns the real group id of the current + process. + + NOTES + This function is not supported by all systems. + + SEE ALSO + getpid, getppid +-------------------------------------------------------------- + +getpid + + SYNOPSIS + Get the current process id + + USAGE + Integer_Type getpid () + + DESCRIPTION + The `getpid' function returns the current process identification + number. + + SEE ALSO + getppid, getgid +-------------------------------------------------------------- + +getppid + + SYNOPSIS + Get the parent process id + + USAGE + Integer_Type getppid () + + DESCRIPTION + The `getpid' function returns the process identification + number of the parent process. + + NOTES + This function is not supported by all systems. + + SEE ALSO + getpid, getgid +-------------------------------------------------------------- + +getuid + + SYNOPSIS + Get the user-id of the current process + + USAGE + Int_Type getuid () + + DESCRIPTION + The `getuid' function returns the user-id of the current + process. + + NOTES + This function is not supported by all systems. + + SEE ALSO + getuid, getegid +-------------------------------------------------------------- + +kill + + SYNOPSIS + Send a signal to a process + + USAGE + Integer_Type kill (Integer_Type pid, Integer_Type sig) + + DESCRIPTION + This function may be used to send a signal given by the integer `sig' + to the process specified by `pid'. The function returns zero upon + success and `-1' upon failure setting errno accordingly. + + EXAMPLE + The `kill' function may be used to determine whether or not + a specific process exists: + + define process_exists (pid) + { + if (-1 == kill (pid, 0)) + return 0; % Process does not exist + return 1; + } + + + NOTES + This function is not supported by all systems. + + SEE ALSO + getpid +-------------------------------------------------------------- + +mkfifo + + SYNOPSIS + Create a named pipe + + USAGE + Int_Type mkfifo (String_Type name, Int_Type mode) + + DESCRIPTION + The `mkfifo' attempts to create a named pipe with the specified + name and mode (modified by the process's umask). The function + returns 0 upon success, or -1 and sets `errno' upon failure. + + NOTES + Not all systems support the `mkfifo' function and even on + systems that do implement the `mkfifo' system call, the + underlying file system may not support the concept of a named pipe, + e.g, an NFS filesystem. + + SEE ALSO + stat_file +-------------------------------------------------------------- + +setgid + + SYNOPSIS + Set the group-id of the current process + + USAGE + Int_Type setgid (Int_Type gid) + + DESCRIPTION + The `setgid' function sets the effective group-id of the current + process. It returns zero upon success, or -1 upon error and sets + `errno' appropriately. + + NOTES + This function is not supported by all systems. + + SEE ALSO + getgid, setuid +-------------------------------------------------------------- + +setpgid + + SYNOPSIS + Set the process group-id + + USAGE + Int_Type setpgid (Int_Type pid, Int_Type gid) + + DESCRIPTION + The `setpgid' function sets the group-id `gid' of the + process whose process-id is `pid'. If `pid' is 0, then the + current process-id will be used. If `pgid' is 0, then the pid + of the affected process will be used. + + If successful zero will be returned, otherwise the function will + return -1 and set `errno' accordingly. + + NOTES + This function is not supported by all systems. + + SEE ALSO + setgid, setuid +-------------------------------------------------------------- + +setuid + + SYNOPSIS + Set the user-id of the current process + + USAGE + Int_Type setuid (Int_Type id) + + DESCRIPTION + The `setuid' function sets the effective user-id of the current + process. It returns zero upon success, or -1 upon error and sets + `errno' appropriately. + + NOTES + This function is not supported by all systems. + + SEE ALSO + setgid, setpgid, getuid, geteuid +-------------------------------------------------------------- + +sleep + + SYNOPSIS + Pause for a specified number of seconds + + USAGE + sleep (Double_Type n) + + DESCRIPTION + The `sleep' function delays the current process for the + specified number of seconds. If it is interrupted by a signal, it + will return prematurely. + + NOTES + Not all system support sleeping for a fractional part of a second. +-------------------------------------------------------------- + +system + + SYNOPSIS + Execute a shell command + + USAGE + Integer_Type system (String_Type cmd) + + DESCRIPTION + The `system' function may be used to execute the string + expression `cmd' in an inferior shell. This function is an + interface to the C `system' function which returns an + implementation-defined result. On Linux, it returns 127 if the + inferior shell could not be invoked, -1 if there was some other + error, otherwise it returns the return code for `cmd'. + + EXAMPLE + + define dir () + { + () = system ("DIR"); + } + + displays a directory listing of the current directory under MSDOS or + VMS. + + SEE ALSO + popen, listdir +-------------------------------------------------------------- + +umask + + SYNOPSIS + Set the file creation mask + + USAGE + Int_Type umask (Int_Type m) + + DESCRIPTION + The `umask' function sets the file creation mask to `m' and + returns the previous mask. + + SEE ALSO + stat_file +-------------------------------------------------------------- + +uname + + SYNOPSIS + Get the system name + + USAGE + Struct_Tye uname () + + DESCRIPTION + The `uname' function returns a structure containing information + about the operating system. The structure contains the following + fields: + + sysname (Name of the operating system) + nodename (Name of the node within the network) + release (Release level of the OS) + version (Current version of the release) + machine (Name of the hardware) + + + NOTES + Not all systems support this function. + + SEE ALSO + getenv, pack, unpack +-------------------------------------------------------------- + +__pop_args + + SYNOPSIS + Remove n function arguments from the stack + + USAGE + variable args = __pop_args(Integer_Type n); + + DESCRIPTION + This function together with the companion function `__push_args' + is useful for passing the arguments of a function to another function. + `__pop_args' returns an array of `n' structures with a + single structure field called `value', which represents the value + of the argument. + + EXAMPLE + Consider the following `print' function. It prints all its + arguments to `stdout' separated by spaces: + + define print () + { + variable i; + variable args = __pop_args (_NARGS); + + for (i = 0; i < _NARGS; i++) + { + () = fputs (string (args[i].value), stdout); + () = fputs (" ", stdout); + } + () = fputs ("\n", stdout); + () = fflush (stdout); + } + + Now consider the problem of defining a function called `ones' + that returns a multi-dimensional array with all the elements set to + 1. For example, `ones(10)' should return a 1-d array of ones, + whereas `ones(10,20)' should return a 10x20 array. + + define ones () + { + !if (_NARGS) return 1; + variable a; + + a = __pop_args (_NARGS); + return @Array_Type (Integer_Type, [__push_args (a)]) + 1; + } + + Here, `__push_args' was used to push on the arguments passed to + the `ones' function onto the stack to be used when dereferencing + `Array_Type'. + + SEE ALSO + __push_args, typeof, _pop_n +-------------------------------------------------------------- + +__push_args + + SYNOPSIS + Remove n function arguments onto the stack + + USAGE + __push_args (Struct_Type args); + + DESCRIPTION + This function together with the companion function `__pop_args' + is useful for passing the arguments of one function to another. + See the desription of `__pop_args' for more information. + + SEE ALSO + __pop_args, typeof, _pop_n +-------------------------------------------------------------- + +_pop_n + + SYNOPSIS + Remove objects from the stack + + USAGE + _pop_n (Integer_Type n); + + DESCRIPTION + The `_pop_n' function pops `n' objects from the top of the + stack. + + EXAMPLE + + define add3 () + { + variable x, y, z; + if (_NARGS != 3) + { + _pop_n (_NARGS); + error ("add3: Expecting 3 arguments"); + } + (x, y, z) = (); + return x + y + z; + } + + + SEE ALSO + _stkdepth, pop +-------------------------------------------------------------- + +_print_stack + + SYNOPSIS + print the values on the stack. + + USAGE + _print_stack () + + DESCRIPTION + This function dumps out what is currently on the S-Lang. It does not + alter the stack and it is usually used for debugging purposes. + + SEE ALSO + _stkdepth, string +-------------------------------------------------------------- + +_stk_reverse + + SYNOPSIS + Reverse the order of the objects on the stack. + + USAGE + _stk_reverse (Integer_Type n) + + DESCRIPTION + The `_stk_reverse' function reverses the order of the top + `n' items on the stack. + + SEE ALSO + _stkdepth, _stk_roll +-------------------------------------------------------------- + +_stk_roll + + SYNOPSIS + Roll items on the stack + + USAGE + _stk_roll (Integer_Type n); + + DESCRIPTION + This function may be used to alter the arrangement of objects on the + stack. Specifically, if the integer `n' is positive, the top + `n' items on the stack are rotated up. If + `n' is negative, the top `abs(n)' items on the stack are + rotated down. + + EXAMPLE + If the stack looks like: + + item-0 + item-1 + item-2 + item-3 + + where `item-0' is at the top of the stack, then + `_stk_roll(-3)' will change the stack to: + + item-2 + item-0 + item-1 + item-3 + + + NOTES + This function only has an effect for `abs(n) > 1'. + + SEE ALSO + _stkdepth, _stk_reverse, _pop_n, _print_stack +-------------------------------------------------------------- + +_stkdepth + + USAGE + Get the number of objects currently on the stack. + + SYNOPSIS + Integer_Type _stkdepth () + + DESCRIPTION + The `_stkdepth' function returns number of items on stack prior + to the call of `_stkdepth'. + + SEE ALSO + _print_stack, _stk_reverse, _stk_roll +-------------------------------------------------------------- + +dup + + SYNOPSIS + Duplicate the value at the top of the stack + + USAGE + dup () + + DESCRIPTION + This function returns an exact duplicate of the object on top of the + stack. For some objects such as arrays or structures, it creates a + new reference to the array. However, for simple scalar S-Lang types such + as strings, integers, and doubles, it creates a new copy of the + object. + + SEE ALSO + pop, typeof +-------------------------------------------------------------- + +exch + + SYNOPSIS + Exchange two items on the stack + + USAGE + exch () + + DESCRIPTION + The `exch' swaps the two top items on the stack. + + SEE ALSO + pop, _stk_reverse, _stk_roll +-------------------------------------------------------------- + +pop + + SYNOPSIS + Discard an item from the stack + + USAGE + pop () + + DESCRIPTION + The `pop' function removes the top item from the stack. + + SEE ALSO + _pop_n +-------------------------------------------------------------- + +clearerr + + SYNOPSIS + Clear the error of a file stream + + USAGE + clearerr (File_Type fp + + DESCRIPTION + The `clearerr' function clears the error and end-of-file flags + associated with the open file stream `fp'. + + SEE ALSO + ferror, feof, fopen +-------------------------------------------------------------- + +fclose + + SYNOPSIS + Close a file + + USAGE + Integer_Type fclose (File_Type fp) + + DESCRIPTION + The `fclose' function may be used to close an open file pointer + `fp'. Upon success it returns zero, and upon failure it sets + `errno' and returns `-1'. Failure usually indicates a that + the file system is full or that `fp' does not refer to an open file. + + NOTES + Many C programmers call `fclose' without checking the return + value. The S-Lang language requires the programmer to explicitly + handle any value returned by a S-Lang function. The simplest way to + handle the return value from `fclose' is to use it as: + + () = fclose (fp); + + + SEE ALSO + fopen, fgets, fflush, pclose, errno +-------------------------------------------------------------- + +fdopen + + SYNOPSIS + Convert a FD_Type file descriptor to a stdio File_Type object + + USAGE + File_Type fdopen (FD_Type, String_Type mode) + + DESCRIPTION + The `fdopen' function creates and returns a stdio + `File_Type' object from the open `FD_Type' + descriptor `fd'. The `mode' parameter corresponds to the + `mode' parameter of the `fopen' function and must be + consistent with the mode of the descriptor `fd'. The function + returns NULL upon failure and sets `errno'. + + NOTES + The `fclose' function does not close the `File_Type' object + returned from this function. The underlying file object must be + closed by the `close' function. + + SEE ALSO + fileno, fopen, open, close, fclose +-------------------------------------------------------------- + +feof + + SYNOPSIS + Get the end-of-file status + + USAGE + Integer_Type feof (File_Type fp) + + DESCRIPTION + This function may be used to determine the state of the end-of-file + indicator of the open file descriptor `fp'. It returns `0' + if the indicator is not set, or non-zero if it is. The end-of-file + indicator may be cleared by the `clearerr' function. + + SEE ALSO + ferror, clearerr, fopen +-------------------------------------------------------------- + +ferror + + SYNOPSIS + Determine the error status of an open file descriptor + + USAGE + Integer_Type ferror (File_Type fp) + + DESCRIPTION + This function may be used to determine the state of the error + indicator of the open file descriptor `fp'. It returns `0' + if the indicator is not set, or non-zero if it is. The error + indicator may be cleared by the `clearerr' function. + + SEE ALSO + feof, clearerr, fopen +-------------------------------------------------------------- + +fflush + + SYNOPSIS + Flush an output stream + + USAGE + Integer_Type fflush (File_Type fp) + + DESCRIPTION + The `fflush' function may be used to update the _output_ + stream specified by `fp'. It returns `0' upon success, or + `-1' upon failure and sets `errno' accordingly. In + particular, this function will fail if `fp' does not represent + an output stream, or if `fp' is associated with a disk file and + there is insufficient disk space. + + EXAMPLE + This example illustrates how to use the `fflush' function + without regard to the return value: + + () = fputs ("Enter value> ", stdout); + () = fflush (stdout); + + + NOTES + Many C programmers disregard the return value from the `fflush' + function. The above example illustrates how to properly do this in + the S-Lang langauge. + + SEE ALSO + fopen, fclose +-------------------------------------------------------------- + +fgets + + SYNOPSIS + Read a line from a file. + + USAGE + Integer_Type fgets (SLang_Ref_Type ref, File_Type fp) + + DESCRIPTION + `fgets' reads a line from the open file specified by `fp' + and places the characters in the variable whose reference is + specified by `ref'. + It returns `-1' if `fp' is not associated with an open file + or an attempt was made to read at the end the file; otherwise, it + returns the number of characters read. + + EXAMPLE + The following example returns the lines of a file via a linked list: + + define read_file (file) + { + variable buf, fp, root, tail; + variable list_type = struct { text, next }; + + root = NULL; + + fp = fopen(file, "r"); + if (fp == NULL) + error("fopen %s failed." file); + while (-1 != fgets (&buf, fp)) + { + if (root == NULL) + { + root = @list_type; + tail = root; + } + else + { + tail.next = @list_type; + tail = tail.next; + } + tail.text = buf; + tail.next = NULL; + } + () = fclose (fp); + return root; + } + + + SEE ALSO + fopen, fclose, fputs, fread, error +-------------------------------------------------------------- + +fgetslines + + SYNOPSIS + Read all the lines from an open file + + USAGE + String_Type[] fgetslines (File_Type fp) + + DESCRIPTION + The `fgetslines' function returns all the remaining lines as an + array of strings in the file specified by the open file pointer + `fp'. If the file is empty, an empty string array will be + returned. The function returns `NULL' upon error. + + EXAMPLE + The following function returns the number of lines in a file: + + define count_lines_in_file (file) + { + variable fp, lines; + + fp = fopen (file, "r"); + if (fp == NULL) + return -1; + + lines = fgetslines (fp); + if (lines == NULL) + return -1; + + return length (lines); + } + + Note that the file was implicitly closed by the function. + + NOTES + This function should not be used if the file contains many lines + since that would require that all the lines be read into memory. + + SEE ALSO + fgets, fread, fopen +-------------------------------------------------------------- + +fopen + + SYNOPSIS + Open a file + + USAGE + File_Type fopen (String_Type f, String_Type m) + + DESCRIPTION + The `fopen' function opens a file `f' according to the mode + string `m'. Allowed values for `m' are: + + "r" Read only + "w" Write only + "a" Append + "r+" Reading and writing at the beginning of the file. + "w+" Reading and writing. The file is created if it does not + exist; otherwise, it is truncated. + "a+" Reading and writing at the end of the file. The file is created + if it does not already exist. + + In addition, the mode string can also include the letter `'b'' + as the last character to indicate that the file is to be opened in + binary mode. + + Upon success, `fopen' a `File_Type' object which is meant to + be used in other operations that require an open file. Upon + failure, the function returns `NULL'. + + EXAMPLE + The following function opens a file in append mode and writes a + string to it: + + define append_string_to_file (file, str) + { + variable fp = fopen (file, "a"); + if (fp == NULL) verror ("%s could not be opened", file); + () = fputs (string, fp); + () = fclose (fp); + } + + Note that the return values from `fputs' and `fclose' are + ignored. + + NOTES + There is no need to explicitly close a file opened with `fopen'. + If the returned `File_Type' object goes out of scope, S-Lang + will automatically close the file. However, explicitly closing a + file after use is recommended. + + SEE ALSO + fclose, fgets, fputs, popen +-------------------------------------------------------------- + +fprintf + + SYNOPSIS + Create and write a formatted string to a file + + USAGE + Int_Type fprintf (File_Type fp, String_Type fmt, ...) + + DESCRIPTION + `fprintf' formats the objects specified by the variable argument + list according to the format `fmt' and write the result to the + open file pointer `fp'. + + The format string obeys the same syntax and semantics as the + `sprintf' format string. See the description of the + `sprintf' function for more information. + + `fprintf' returns the number of characters written to the file, + or -1 upon error. + + SEE ALSO + fputs, printf, fwrite, message +-------------------------------------------------------------- + +fputs + + SYNOPSIS + Write a string to an open stream + + USAGE + Integer_Type fputs (String_Type s, File_Type fp); + + DESCRIPTION + The `fputs' function writes the string `s' to the open file + pointer `fp'. It returns -1 upon failure and sets `errno', + otherwise it returns the length of the string. + + EXAMPLE + The following function opens a file in append mode and uses the + `fputs' function to write to it. + + define append_string_to_file (str, file) + { + variable fp; + fp = fopen (file, "a"); + if (fp == NULL) verror ("Unable to open %s", file); + if ((-1 == fputs (s, fp)) + or (-1 == fclose (fp))) + verror ("Error writing to %s", file); + } + + + NOTES + One must not disregard the return value from the `fputs' + function, as many C programmers do. Doing so may lead to a stack + overflow error. + + To write an object that contains embedded null characters, use the + `fwrite' function. + + SEE ALSO + fclose, fopen, fgets, fwrite +-------------------------------------------------------------- + +fread + + SYNOPSIS + Read binary data from a file + + USAGE + UInt_Type fread (Ref_Type b, DataType_Type t, UInt_Type n, File_Type fp) + + DESCRIPTION + The `fread' function may be used to read `n' objects of type + `t' from an open file pointer `fp'. Upon success, it + returns the number of objects read from the file and places the + objects in the variable specified by `b'. Upon error or end of + file, it returns `-1'. If more than one object is read from the + file, those objects will be placed in an array of the appropriate + size. The exception to this is when reading `Char_Type' or + `UChar_Type' objects from a file, in which case the data will be + returned as an `n' character BString_Type binary string, but + only if `n'>1. + + EXAMPLE + The following example illustrates how to read 50 bytes from a file: + + define read_50_bytes_from_file (file) + { + variable fp, n, buf; + + fp = fopen (file, "rb"); + if (fp == NULL) error ("Open failed"); + n = fread (&buf, Char_Type, 50, fp); + if (n == -1) + error ("fread failed"); + () = fclose (fp); + return buf; + } + + + NOTES + Use the `pack' and `unpack' functions to read data with a + specific byte-ordering. + + SEE ALSO + fwrite, fgets, fopen, pack, unpack +-------------------------------------------------------------- + +fseek + + SYNOPSIS + Reposition a stream + + USAGE + Integer_Type fseek (File_Type fp, Integer_Type ofs, Integer_Type whence + + DESCRIPTION + The `fseek' function may be used to reposition the file position + pointer associated with the open file stream `fp'. Specifically, + it moves the pointer `ofs' bytes relative to the position + indicated by `whence'. If whence is set to one of the symbolic + constants `SEEK_SET', `SEEK_CUR', or `SEEK_END', the + offset is relative to the start of the file, the current position + indicator, or end-of-file, respectively. + + The function return zero upon success, or -1 upon failure and sets + `errno' accordingly. + + EXAMPLE + define rewind (fp) + { + if (0 == fseek (fp, 0, SEEK_SET)) return; + vmessage ("rewind failed, reason: %s", errno_string (errno)); + } + + NOTES + The current implementation uses an integer to specify the offset. + One some systems, a long integer may be required making this + function fail for very large files, i.e., files that are longer than + the maximum value of an integer. + + SEE ALSO + ftell, fopen +-------------------------------------------------------------- + +ftell + + SYNOPSIS + Obtain the current position in an open stream + + USAGE + Integer_Type ftell (File_Type fp) + + DESCRIPTION + The ftell function may be used to obtain the current position in the + stream associated with the open file pointer `fp'. It returns + the position of the pointer measured in bytes from the beginning of + the file. Upon error, it returns `-1' and sets `errno'. + + SEE ALSO + fseek, fopen +-------------------------------------------------------------- + +fwrite + + SYNOPSIS + Write binary data to a file + + USAGE + UInt_Type fwrite (b, File_Type fp) + + DESCRIPTION + The `fwrite' may be used to write the object represented by + `b' to an open file. If `b' is a string or an array, the + function will attempt to write all elements of the object to the + file. It returns the number of objects successfully written, + otherwise it returns -1 upon error and sets `errno' + accordingly. + + EXAMPLE + The following example illustrates how to write an integer array to a + file. In this example, `fp' is an open file descriptor: + + variable a = [1:50]; % 50 element integer array + if (50 != fwrite (a, fp)) + error ("fwrite failed"); + + Here is how to write the array one element at a time: + + variable a = [1:50]; + foreach (a) + { + variable ai = (); + if (1 != fwrite(ai, fp)) + error ("fwrite failed"); + } + + + NOTES + Not all data types may support the `fwrite' operation. However, + it is supported by all vector, scalar, and string objects. + + SEE ALSO + fread, fputs, fopen, pack, unpack +-------------------------------------------------------------- + +pclose + + SYNOPSIS + Close an object opened with popen + + USAGE + Integer_Type pclose (File_Type fp) + + DESCRIPTION + The `pclose' function waits for the process associated with + `fp' to exit and the returns the exit status of the command. + + SEE ALSO + pclose, fclose +-------------------------------------------------------------- + +popen + + SYNOPSIS + Open a process + + USAGE + File_Type popen (String_Type cmd, String_Type mode) + + DESCRIPTION + The `popen' function executes a process specified by `cmd' + and opens a unidirectional pipe to the newly created process. The + `mode' indicates whether or not the pipe is open for reading + or writing. Specifically, if `mode' is `"r"', then the + pipe is opened for reading, or if `mode' is `"w"', then the + pipe will be open for writing. + + Upon success, a `File_Type' pointer will be returned, otherwise + the function failed and `NULL' will be returned. + + NOTES + This function is not available on all systems. + + SEE ALSO + pclose, fopen +-------------------------------------------------------------- + +printf + + SYNOPSIS + Create and write a formatted string to stdout + + USAGE + Int_Type printf (String_Type fmt, ...) + + DESCRIPTION + `fprintf' formats the objects specified by the variable argument + list according to the format `fmt' and write the result to + `stdout'. This function is equivalent to `fprintf' used + with the `stdout' file pointer. See `fprintf' for more + information. + + `printf' returns the number of characters written to the file, + or -1 upon error. + + NOTES + Many C programmers do not check the return status of the + `printf' C library function. Make sure that if you do not care + about whether or not the function succeeds, then code it as in the + following example: + + () = printf ("%s laid %d eggs\n", chicken_name, num_egg); + + + SEE ALSO + fputs, printf, fwrite, message +-------------------------------------------------------------- + +Sprintf + + SYNOPSIS + Format objects into a string + + USAGE + String_Type Sprintf (String_Type format, ..., Integer_Type n) + + DESCRIPTION + `Sprintf' formats a string from `n' objects according to + `format'. Unlike `sprintf', the `Sprintf' function + requires the number of items to format. + + The format string is a C library `sprintf' style format + descriptor. Briefly, the format string may consist of ordinary + characters (not including the `%' character), which are copied + into the output string as-is, and a conversion specification + introduced by the `%' character. The `%' character must be + followed by at least one other character to specify the conversion: + + s value is a string + f value is a floating point number + e print float in exponential form, e.g., 2.345e08 + g print float as e or g, depending upon its value + c value is an ascii character + % print the percent character + d print a signed decimal integer + u print an unsigned decimal integer + o print an integer as octal + X print an integer as hexadecimal + S convert value to a string and format as string + + Note that `%S' is a S-Lang extension which will cause the value + to be formatted as string. In fact, `sprintf("%S",x)' is + equivalent to `sprintf("%s",string(x))'. + + s = Sprintf("%f is greater than %f but %s is better than %s\n", + PI, E, "Cake" "Pie", 4); + + The final argument to `Sprintf' is the number of items to format; in + this case, there are 4 items. + + SEE ALSO + sprintf, string, sscanf +-------------------------------------------------------------- + +create_delimited_string + + SYNOPSIS + Concatenate strings using a delimiter + + USAGE + String_Type create_delimited_string (delim, s_1, s_2, ..., s_n, n) + + String_Type delim, s_1, ..., s_n + Integer_Type n + + + DESCRIPTION + `create_delimited_string' performs a concatenation operation on + the `n' strings `s_1', ...,`s_n', using the string + `delim' as a delimiter. The resulting string is equivalent to + one obtained via + + s_1 + delim + s_2 + delim + ... + s_n + + + EXAMPLE + One use for this function is to construct path names, e.g., + + create_delimited_string ("/", "user", "local", "bin", 3); + + will produce `"usr/local/bin"'. + + NOTES + The expression `strcat(a,b)' is equivalent to + `create_delimited_string("", a, b, 2)'. + + SEE ALSO + strjoin, is_list_element, extract_element, strchop, strcat +-------------------------------------------------------------- + +extract_element + + SYNOPSIS + Extract the nth element of a string with delimiters + + USAGE + String_Type extract_element (String_Type list, Integer_Type nth, Integer_Type delim); + + DESCRIPTION + The `extract_element' function may be used to extract the + `nth' element of the `delim' delimited list of strings + `list'. The function will return the `nth' element of the + list, unless `nth' specifies more elements than the list + contains, in which case `NULL' will be returned. + Elements in the list are numbered from `0'. + + EXAMPLE + The expression + + extract_element ("element 0, element 1, element 2", 1, ',') + + returns the string `" element 1"', whereas + + extract_element ("element 0, element 1, element 2", 1, ' ') + + returns `"0,"'. + + The following function may be used to compute the number of elements + in the list: + + define num_elements (list, delim) + { + variable nth = 0; + while (NULL != extract_element (list, nth, delim)) + nth++; + return nth; + } + + + Alternatively, the `strchop' function may be more useful. In + fact, `extract_element' may be expressed in terms of the + function `strchop' as + + define extract_element (list, nth, delim) + { + list = strchop(list, delim, 0); + if (nth >= length (list)) + return NULL; + else + return list[nth]; + } + + and the `num_elements' function used above may be recoded more + simply as: + + define num_elements (list, delim) + { + return length (strchop (length, delim, 0)); + } + + + SEE ALSO + is_list_element, is_substr, strtok, strchop, create_delimited_string +-------------------------------------------------------------- + +is_list_element + + SYNOPSIS + Test whether a delimited string contains a specific element + + USAGE + Integer_Type is_list_element (String_Type list, String_Type elem, Integer_Type delim) + + DESCRIPTION + The `is_list_element' function may be used to determine whether + or not a delimited list of strings, `list', contains the element + `elem'. If `elem' is not an element of `list', the function + will return zero, otherwise, it returns 1 plus the matching element + number. + + EXAMPLE + The expression + + is_list_element ("element 0, element 1, element 2", "0,", ' '); + + returns `2' since `"0,"' is element number one of the list + (numbered from zero). + + SEE ALSO + extract_element, is_substr, create_delimited_string +-------------------------------------------------------------- + +is_substr + + SYNOPSIS + Test for a specified substring within a string. + + USAGE + Integer_Type is_substr (String_Type a, String_Type b) + + DESCRIPTION + This function may be used to determine if `a' contains the + string `b'. If it does not, the function returns 0; otherwise it + returns the position of the first occurance of `b' in `a'. + + NOTES + It is important to remember that the first character of a string + corresponds to a position value of `1'. + + SEE ALSO + substr, string_match, strreplace +-------------------------------------------------------------- + +make_printable_string + + SYNOPSIS + Format a string suitable for parsing + + USAGE + String_Type make_printable_string(String_Type str) + + DESCRIPTION + This function formats a string in such a way that it may be used as + an argument to the `eval' function. The resulting string is + identical to `str' except that it is enclosed in double quotes and the + backslash, newline, and double quote characters are expanded. + + SEE ALSO + eval, str_quote_string +-------------------------------------------------------------- + +sprintf + + SYNOPSIS + Format objects into a string + + USAGE + String sprintf (String format, ...); + + DESCRIPTION + This function performs a similar task as the C function with the same + name. It differs from the S-Lang function `Sprintf' in that it + does not require the number of items to format. + See the documentation for `Sprintf' for more information. + + SEE ALSO + Sprintf, string, sscanf, vmessage +-------------------------------------------------------------- + +sscanf + + SYNOPSIS + Parse a formatted string + + USAGE + Int_Type sscanf (s, fmt, r1, ... rN) + + String_Type s, fmt; + Ref_Type r1, ..., rN + + + DESCRIPTION + The `sscanf' function parses the string `s' according to the + format `fmt' and sets the variables whose references are given by + `r1', ..., `rN'. The function returns the number of + references assigned, or `-1' upon error. + + The format string `fmt' consists of ordinary characters and + conversion specifiers. A conversion specifier begins with the + special character `%' and is described more fully below. A white + space character in the format string matches any amount of whitespace + in the input string. Parsing of the format string stops whenever a + match fails. + + The `%' is used to denote a conversion specifier whose general + form is given by `%[*][width][type]format' where the brackets + indicate optional items. If `*' is present, then the conversion + will be performed by no assignment to a reference will be made. The + `width' specifier specifies the maximum field width to use for + the conversion. The `type' modifier is used to indicate size of + the object, e.g., a short integer, as follows. + + If _type_ is given as the character `h', then if the format + conversion is for an integer (`dioux'), the object assigned will + be a short integer. If _type_ is `l', then the conversion + will be to a long integer for integer conversions, or to a double + precession floating point number for floating point conversions. + + The format specifier is a character that specifies the conversion: + + % Matches a literal percent character. No assigment is + performed. + d Matches a signed decimal integer. + D Matches a long decimal integer (equiv to `ld') + u Matches an unsigned decimal integer + U Matches an unsigned long decimal integer (equiv to `lu') + i Matches either a hexidecimal integer, decimal integer, or + octal integer. + I Equivalent to `li'. + x Matches a hexidecimal integer. + X Matches a long hexidecimal integer (same as `lx'). + e,f,g Matches a decimal floating point number (Float_Type). + E,F,G Matches a double precision floating point number, same as `lf'. + s Matches a string of non-whitespace characters (String_Type). + c Matches one character. If width is given, width + characters are matched. + n Assigns the number of characters scanned so far. + [...] Matches zero or more characters from the set of characters + enclosed by the square brackets. If '^' is given as the + first character, then the complement set is matched. + + + EXAMPLE + Suppose that `s' is `"Coffee: (3,4,12.4)"'. Then + + n = sscanf (s, "%[a-zA-Z]: (%d,%d,%lf)", &item, &x, &y, &z); + + will set `n' to 4, `item' to `"Coffee"', `x' to 3, + `y' to 4, and `z' to the double precision number + `12.4'. However, + + n = sscanf (s, "%s: (%d,%d,%lf)", &item, &x, &y, &z); + + will set `n' to 1, `item' to `"Coffee:"' and the + remaining variables will not be assigned. + + SEE ALSO + sprintf, unpack, string, atof, int, integer, string_match +-------------------------------------------------------------- + +str_delete_chars + + SYNOPSIS + Delete characters from a string + + USAGE + String_Type str_delete_chars (String_Type str, String_Type del_set + + DESCRIPTION + This function may be used to delete the set of characters specified + by `del_set' from the string `str'. The result is returned. + + EXAMPLE + + str = str_delete_chars (str, "^A-Za-z"); + + will remove all characters except `A-Z' and `a-z' from + `str'. +-------------------------------------------------------------- + +str_quote_string + + SYNOPSIS + Escape characters in a string. + + USAGE + String_Type str_quote_string(String_Type str, String_Type qlis, Integer_Type quote) + + DESCRIPTION + The `str_quote_string' returns a string identical to `str' + except that all characters in the set specified by the string + `qlis' are escaped with the `quote' character, including the + quote character itself. This function is useful for making a + string that can be used in a regular expression. + + EXAMPLE + Execution of the statements + + node = "Is it [the coat] really worth $100?"; + tag = str_quote_string (node, "\\^$[]*.+?", '\\'); + + will result in `tag' having the value: + + Is it \[the coat\] really worth \$100\? + + + SEE ALSO + str_uncomment_string, make_printable_string +-------------------------------------------------------------- + +str_replace + + SYNOPSIS + Replace a substring of a string + + USAGE + Integer_Type str_replace (String_Type a, String_Type b, String_Type c) + + DESCRIPTION + The `str_replace' function replaces the first occurance of `b' in + `a' with `c' and returns an integer that indicates whether a + replacement was made or not. If `b' does not occur in `a', zero is + returned. However, if `b' occurs in `a', a non-zero integer is + returned as well as the new string resulting from the replacement. + + NOTES + This function has been superceded by `strreplace'. + + SEE ALSO + strreplace +-------------------------------------------------------------- + +str_uncomment_string + + SYNOPSIS + Remove comments from a string + + USAGE + String_Type str_uncomment_string(String_Type s, String_Type beg, String_Type end) + + DESCRIPTION + This function may be used to remove comments from a string `s'. + The parameters, `beg' and `end', are strings of equal length + whose corresponding characters specify the begin and end comment + characters, respectively. It returns the uncommented string. + + EXAMPLE + The expression + + str_uncomment_string ("Hello (testing) 'example' World", "'(", "')") + + returns the string `"Hello World"'. + + NOTES + This routine does not handle multicharacter comment delimiters and it + assumes that comments are not nested. + + SEE ALSO + str_quote_string +-------------------------------------------------------------- + +strcat + + SYNOPSIS + Concatenate strings + + USAGE + String_Type strcat (String_Type a_1, ..., String_Type a_N) + + DESCRIPTION + The `strcat' function concatenates its N `String_Type' + arguments `a_1', ... `a_N' together and returns the result. + + EXAMPLE + + strcat ("Hello", " ", "World"); + + produces the string `"Hello World"'. + + NOTES + This function is equivalent to the binary operation `a_1+...+a_N'. + However, `strcat' is much faster making it the preferred method + to concatenate string. + + SEE ALSO + sprintf, create_delimited_string +-------------------------------------------------------------- + +strchop + + SYNOPSIS + Chop or split a string into substrings. + + USAGE + String_Type[] strchop (String_Type str, Integer_Type delim, Integer_Type quote) + + DESCRIPTION + The `strchop' function may be used to split-up a string + `str' that consists of substrings delimited by the character + specified by `delim'. If the integer `quote' is non-zero, + it will be taken as a quote character for the delimiter. The + function returns the substrings as an array. + + EXAMPLE + The following function illustrates how to sort a comma separated + list of strings: + + define sort_string_list (a) + { + variable i, b, c; + b = strchop (a, ',', 0); + + i = array_sort (b, &strcmp); + b = b[i]; % rearrange + + % Convert array back into comma separated form + return strjoin (b, ","); + } + + + NOTES + The semantics of this `strchop' and `strchopr' have been + changed since version 1.2.x of the interpreter. Old versions of + these functions returned the values on the stack, which meant that + one could not chop up arbitrarily long strings that consist of + many substrings. + + The function `strchopr' should be used if it is desired to have + the string chopped-up in the reverse order. + + SEE ALSO + strchopr, extract_element, strjoin, strtok +-------------------------------------------------------------- + +strchopr + + SYNOPSIS + Chop or split a string into substrings. + + USAGE + String_Type[] strchopr (String_Type str, String_Type delim, String_Type quote) + + DESCRIPTION + This routine performs exactly the same function as `strchop' except + that it returns the substrings in the reverse order. See the + documentation for `strchop' for more information. + + SEE ALSO + strchop, extract_element, strtok, strjoin +-------------------------------------------------------------- + +strcmp + + SYNOPSIS + Compare two strings + + USAGE + Interpret strcmp (String_Type a, String_Type b) + + DESCRIPTION + The `strcmp' function may be used to perform a case-sensitive + string comparison, in the lexicongraphic sense, on strings `a' and + `b'. It returns 0 if the strings are identical, a negative integer + if `a' is less than `b', or a positive integer if `a' is greater + than `b'. + + EXAMPLE + The `strup' function may be used to perform a case-insensitive + string comparison: + + define case_insensitive_strcmp (a, b) + { + return strcmp (strup(a), strup(b)); + } + + + NOTES + One may also use one of the binary comparison operators, e.g., + `a > b'. + + SEE ALSO + strup, strncmp +-------------------------------------------------------------- + +strcompress + + SYNOPSIS + Remove excess whitespace characters from a string + + USAGE + String_Type strcompress (String_Type s, String_Type white) + + DESCRIPTION + The `strcompress' function compresses the string `s' by + replacing a sequence of one or more characters from the set + `white' by the first character of `white'. In addition, it + also removes all leading and trailing characters from `s' that + are part of `white'. + + EXAMPLE + The expression + + strcompress (",;apple,,cherry;,banana", ",;"); + + returns the string `"apple,cherry,banana"'. + + SEE ALSO + strtrim, strtrans +-------------------------------------------------------------- + +string_match + + SYNOPSIS + Match a string against a regular expression + + USAGE + Integer_Type string_match(String_Type str, String_Type pat, Integer_Type pos) + + DESCRIPTION + The `string_match' function returns zero if `str' does not + match regular expression specified by `pat'. This function + performs the match starting at position `pos' (numbered from 1) in + `str'. This function returns the position of the start of the + match. To find the exact substring actually matched, use + `string_match_nth'. + + SEE ALSO + string_match_nth, strcmp, strncmp +-------------------------------------------------------------- + +string_match_nth + + SYNOPSIS + Get the result of the last call to string_match + + USAGE + (Integer_Type, Integer_Type) = string_match_nth(Integer_Type nth) + + DESCRIPTION + The `string_match_nth' function returns two integers describing + the result of the last call to `string_match'. It returns both + the offset into the string and the length of characters matches by + the `nth' submatch. + + By convention, `nth' equal to zero means the entire match. + Otherwise, `nth' must be an integer with a value 1 through 9, + and refers to the set of characters matched by the `nth' regular + expression enclosed by the pairs `\(, \)'. + + EXAMPLE + Consider: + + variable matched, pos, len; + matched = string_match("hello world", "\\([a-z]+\\) \\([a-z]+\\)", 1); + if (matched) (pos, len) = string_match_nth(2); + + This will set `matched' to 1 since a match will be found at the + first position, `pos' to 6 since `w' is offset 6 characters + from the beginning of the string, and `len' to 5 since + `"world"' is 5 characters long. + + NOTES + The position offset is _not_ affected by the value of the offset + parameter to the `string_match' function. For example, if the + value of the last parameter to the `string_match' function had + been 3, `pos' would still have been set to 6. + + Note also that `string_match_nth' returns the _offset_ from + the beginning of the string and not the position of the match. + + SEE ALSO + string_match +-------------------------------------------------------------- + +strjoin + + SYNOPSIS + Concatenate elements of a string array + + USAGE + String_Type strjoin (Array_Type a, String_Type delim) + + DESCRIPTION + The `strjoin' function operates on an array of strings by joining + successive elements together separated with a delimiter `delim'. + If `delim' is the empty string `""', then the result will + simply be the concatenation of the elements. + + EXAMPLE + Suppose that + + days = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat","Sun"]; + + Then `strjoin (days,"+")' will produce + `"Sun+Mon+Tue+Wed+Thu+Fri+Sat+Sun"'. Similarly, + `strjoin (["","",""], "X")' will produce `"XX"'. + + SEE ALSO + create_delimited_string, strchop, strcat +-------------------------------------------------------------- + +strlen + + SYNOPSIS + Compute the length of a string + + USAGE + Integer_Type strlen (String_Type a) + + DESCRIPTION + The `strlen' function may be used to compute the length of a string. + + EXAMPLE + After execution of + + variable len = strlen ("hello"); + + `len' will have a value of `5'. + + SEE ALSO + bstrlen, length, substr +-------------------------------------------------------------- + +strlow + + SYNOPSIS + Convert a string to lowercase + + USAGE + String_Type strlow (String_Type s) + + DESCRIPTION + The `strlow' function takes a string `s' and returns another + string identical to `s' except that all upper case characters + that comprise `s' will be converted to lower case. + + EXAMPLE + The function + + define Strcmp (a, b) + { + return strcmp (strlow (a), strlow (b)); + } + + performs a case-insensitive comparison operation of two strings by + converting them to lower case first. + + SEE ALSO + strup, tolower, strcmp, strtrim, define_case +-------------------------------------------------------------- + +strncmp + + SYNOPSIS + Compare the first few characters of two strings + + USAGE + Integer_Type strncmp (String_Type a, String_Type b, Integer_Type n) + + DESCRIPTION + This function behaves like `strcmp' except that it compares only the + first `n' characters in the strings `a' and `b'. See + the documentation for `strcmp' for information about the return + value. + + EXAMPLE + The expression + + strcmp ("apple", "appliance", 3); + + will return zero since the first three characters match. + + SEE ALSO + strcmp, strlen +-------------------------------------------------------------- + +strreplace + + SYNOPSIS + Replace one or more substrings + + USAGE + (new, n) = strreplace (a, b, c, max_n) + + String_Type a, b, c, rep; + Int_Type n, max_n; + + + DESCRIPTION + The `strreplace' function may be used to replace one or more + occurances of `b' in `a' with `c'. If the integer + `max_n' is positive, then the first `max_n' occurances of + `b' in `a' will be replaced. Otherwise, if `max_n' is + negative, then the last `abs(max_n)' occurances will be replaced. + + The function returns the resulting string and an integer indicating + how many replacements were made. + + EXAMPLE + The following function illustrates how `strreplace' may be used + to remove all occurances of a specified substring + + define delete_substrings (a, b) + { + (a, ) = strreplace (a, b, "", strlen (a)); + return a; + } + + + SEE ALSO + is_substr, strsub, strtrim, strtrans, str_delete_chars +-------------------------------------------------------------- + +strsub + + SYNOPSIS + Replace a character with another in a string. + + USAGE + String_Type strsub (String_Type s, Integer_Type pos, Integer_Type ch) + + DESCRIPTION + The `strsub' character may be used to substitute the character + `ch' for the character at position `pos' of the string + `s'. The resulting string is returned. + + EXAMPLE + + define replace_spaces_with_comma (s) + { + variable n; + while (n = is_substr (s, " "), n) s = strsub (s, n, ','); + return s; + } + + For uses such as this, the `strtrans' function is a better choice. + + NOTES + The first character in the string `s' is specified by `pos' + equal to 1. + + SEE ALSO + is_substr, strreplace, strlen +-------------------------------------------------------------- + +strtok + + SYNOPSIS + Extract tokens from a string + + USAGE + String_Type[] strtok (String_Type str [,String_Type white]) + + DESCRIPTION + `strtok' breaks the string `str' into a series of tokens and + returns them as an array of strings. If the second parameter + `white' is present, then it specifies the set of characters that + are to be regarded as whitespace when extracting the tokens, and may + consist of the whitespace characters or a range of such characters. + If the first character of `white' is `'^'', then the + whitespace characters consist of all characters except those in + `white'. For example, if `white' is `" \t\n,;."', + then those characters specifiy the whitespace characters. However, + if `white' is given by `"^a-zA-Z0-9_"', then any character + is a whitespace character except those in the ranges `a-z', + `A-Z', `0-9', and the underscore character. + + If the second parameter is not present, then it defaults to + `" \t\r\n\f"'. + + EXAMPLE + The following example may be used to count the words in a text file: + + define count_words (file) + { + variable fp, line, count; + + fp = fopen (file, "r"); + if (fp == NULL) return -1; + + count = 0; + while (-1 != fgets (&line, fp)) + { + line = strtok (line, "^a-zA-Z"); + count += length (line); + } + () = fclose (fp); + return count; + } + + + SEE ALSO + strchop, strcompress, extract_element, strjoin +-------------------------------------------------------------- + +strtrans + + SYNOPSIS + Replace characters in a string + + USAGE + String_Type strtrans (str, old_set, new_set) + + String_Type str, old_set, new_set; + + + DESCRIPTION + The `strtrans' function may be used to replace all the characters + from the set `old_set' with the corresponding characters from + `new_set' in the string `str'. If `new_set' is empty, + then the characters in `old_set' will be removed from `str'. + This function returns the result. + + EXAMPLE + + str = strtrans (str, "A-Z", "a-z"); % lower-case str + str = strtrans (str, "^0-9", " "); % Replace anything but 0-9 by space + + + SEE ALSO + strreplace, strtrim, strup, strlow +-------------------------------------------------------------- + +strtrim + + SYNOPSIS + Remove whitespace from the ends of a string + + USAGE + String_Type strtrim (String_Type s [,String_Type w]) + + DESCRIPTION + The `strtrim' function removes all leading and trailing whitespace + characters from the string `s' and returns the result. The + optional second parameter specifies the set of whitespace + characters. If the argument is not present, then the set defaults + to `" \t\r\n"'. + + SEE ALSO + strtrim_beg, strtrim_end, strcompress +-------------------------------------------------------------- + +strtrim_beg + + SYNOPSIS + Remove leading whitespace from a string + + USAGE + String_Type strtrim_beg (String_Type s [,String_Type w]) + + DESCRIPTION + The `strtrim_beg' function removes all leading whitespace + characters from the string `s' and returns the result. The + optional second parameter specifies the set of whitespace + characters. If the argument is not present, then the set defaults + to `" \t\r\n"'. + + SEE ALSO + strtrim, strtrim_end, strcompress +-------------------------------------------------------------- + +strtrim_end + + SYNOPSIS + Remove trailing whitespace from a string + + USAGE + String_Type strtrim_end (String_Type s [,String_Type w]) + + DESCRIPTION + The `strtrim_end' function removes all trailing whitespace + characters from the string `s' and returns the result. The + optional second parameter specifies the set of whitespace + characters. If the argument is not present, then the set defaults + to `" \t\r\n"'. + + SEE ALSO + strtrim, strtrim_beg, strcompress +-------------------------------------------------------------- + +strup + + SYNOPSIS + Convert a string to uppercase + + USAGE + String_Type strup (String_Type s) + + DESCRIPTION + The `strup' function takes a string `s' and returns another + string identical to `s' except that all lower case characters + that comprise `s' will be converted to upper case. + + EXAMPLE + The function + + define Strcmp (a, b) + { + return strcmp (strup (a), strup (b)); + } + + performs a case-insensitive comparison operation of two strings by + converting them to upper case first. + + SEE ALSO + strlow, toupper, strcmp, strtrim, define_case, strtrans +-------------------------------------------------------------- + +substr + + SYNOPSIS + Extract a substring from a string + + USAGE + String_Type substr (String_Type s, Integer_Type n, Integer_Type len) + + DESCRIPTION + The `substr' function returns a substring with length `len' + of the string `s' beginning at position `n'. If `len' is + `-1', the entire length of the string `s' will be used for + `len'. The first character of `s' is given by `n' equal + to 1. + + EXAMPLE + + substr ("To be or not to be", 7, 5); + + returns `"or no"' + + NOTES + In many cases it is more convenient to use array indexing rather + than the `substr' function. In fact, `substr(s,i+1,strlen(s))' is + equivalent to `s[[i:]]'. + + SEE ALSO + is_substr, strlen +-------------------------------------------------------------- + +_push_struct_field_values + + SYNOPSIS + Push the values of a structure's fields onto the stack + + USAGE + Integer_Type num = _push_struct_field_values (Struct_Type s) + + DESCRIPTION + The `_push_struct_field_values' function pushes the values of + all the fields of a structure onto the stack, returning the + number of items pushed. The fields are pushed such that the last + field of the structure is pushed first. + + SEE ALSO + get_struct_field_names, get_struct_field +-------------------------------------------------------------- + +get_struct_field + + SYNOPSIS + Get the value associated with a structure field + + USAGE + x = get_struct_field (Struct_Type s, String field_name) + + DESCRIPTION + The `get_struct_field' function gets the value of the field + whose name is specified by `field_name' of the structure `s'. + + EXAMPLE + The following example illustrates how this function may be used to + to print the value of a structure. + + define print_struct (s) + { + variable name; + + foreach (get_struct_field_names (s)) + { + name = (); + value = get_struct_field (s, name); + vmessage ("s.%s = %s\n", name, string(value)); + } + } + + + SEE ALSO + set_struct_field, get_struct_field_names, array_info +-------------------------------------------------------------- + +get_struct_field_names + + SYNOPSIS + Retrieve the field names associated with a structure + + USAGE + String_Type[] = get_struct_field_names (Struct_Type s) + + DESCRIPTION + The `get_struct_field_names' function returns an array of + strings whose elements specify the names of the fields of the + struct `s'. + + EXAMPLE + The following example illustrates how the + `get_struct_field_names' function may be used to print the + value of a structure. + + define print_struct (s) + { + variable name, value; + + foreach (get_struct_field_names (s)) + { + name = (); + value = get_struct_field (s, name); + vmessage ("s.%s = %s\n", name, string (value)); + } + } + + + SEE ALSO + _push_struct_field_values, get_struct_field +-------------------------------------------------------------- + +is_struct_type + + SYNOPSIS + Determine whether or not an object is a structure + + USAGE + Integer_Type is_struct_type (X) + + DESCRIPTION + The `is_struct_type' function returns 1 if the parameter + refers to a structure or a user-defined type. If the object is + neither, 0 will be returned. + + SEE ALSO + typeof, _typeof +-------------------------------------------------------------- + +set_struct_field + + SYNOPSIS + Set the value associated with a structure field + + USAGE + set_struct_field (s, field_name, field_value) + + Struct_Type s; + String_Type field_name; + Generic_Type field_value; + + + DESCRIPTION + The `set_struct_field' function sets the value of the field + whose name is specified by `field_name' of the structure + `s' to `field_value'. + + SEE ALSO + get_struct_field, get_struct_field_names, set_struct_fields, array_info +-------------------------------------------------------------- + +set_struct_fields + + SYNOPSIS + Set the fields of a structure + + USAGE + set_struct_fields (Struct_Type s, ...) + + DESCRIPTION + The `set_struct_fields' function may be used to set zero or more + fields of a structure. The fields are set in the order in which + they were created when the structure was defined. + + EXAMPLE + + variable s = struct { name, age, height }; + set_struct_fields (s, "Bill", 13, 64); + + + SEE ALSO + set_struct_field, get_struct_field_names +-------------------------------------------------------------- + +_time + + SYNOPSIS + Get the current time in seconds + + USAGE + ULong_Type _time () + + DESCRIPTION + The `_time' function returns the number of elapsed seconds since + 00:00:00 GMT, January 1, 1970. The `ctime' function may be used + to convert this into a string representation. + + SEE ALSO + ctime, time, localtime, gmtime +-------------------------------------------------------------- + +ctime + + SYNOPSIS + Convert a calendar time to a string + + USAGE + String_Type ctime(ULong_Type secs) + + DESCRIPTION + This function returns a string representation of the time as given + by `secs' seconds since 1970. + + SEE ALSO + time, _time, localtime, gmtime +-------------------------------------------------------------- + +gmtime + + SYNOPSIS + Break down a time in seconds to GMT timezone + + USAGE + Struct_Type gmtime (Long_Type secs) + + DESCRIPTION + The `gmtime' function is exactly like `localtime' except + that the values in the structure it returns are with respect to GMT + instead of the local timezone. See the documentation for + `localtime' for more information. + + NOTES + On systems that do not support the `gmtime' C library function, + this function is the same as `localtime'. + + SEE ALSO + localtime, _time +-------------------------------------------------------------- + +localtime + + SYNOPSIS + Break down a time in seconds to local timezone + + USAGE + Struct_Type localtime (Long_Type secs) + + DESCRIPTION + The `localtime' function takes a parameter `secs' + representing the number of seconds since 00:00:00, January 1 1970 + UTC and returns a structure containing information about `secs' + in the local timezone. The structure contains the following + `Int_Type' fields: + + `tm_sec' The number of seconds after the minute, normally + in the range 0 to 59, but can be up to 61 to allow for + leap seconds. + + `tm_min' The number of minutes after the hour, in the + range 0 to 59. + + `tm_hour' The number of hours past midnight, in the range + 0 to 23. + + `tm_mday' The day of the month, in the range 1 to 31. + + `tm_mon' The number of months since January, in the range + 0 to 11. + + `tm_year' The number of years since 1900. + + `tm_wday' The number of days since Sunday, in the range 0 + to 6. + + `tm_yday' The number of days since January 1, in the + range 0 to 365. + + `tm_isdst' A flag that indicates whether daylight saving + time is in effect at the time described. The value is + positive if daylight saving time is in effect, zero if it + is not, and negative if the information is not available. + + SEE ALSO + gmtime, _time, ctime +-------------------------------------------------------------- + +tic + + SYNOPSIS + Start timing + + USAGE + void tic () + + DESCRIPTION + The `tic' function restarts the internal clock used for timing + the execution of commands. To get the elapsed time of the clock, + use the `toc' function. + + SEE ALSO + toc, times +-------------------------------------------------------------- + +time + + SYNOPSIS + Return the current data and time as a string + + USAGE + String_Type time () + + DESCRIPTION + This function returns the current time as a string of the form: + + Sun Apr 21 13:34:17 1996 + + + SEE ALSO + ctime, message, substr +-------------------------------------------------------------- + +times + + SYNOPSIS + Get process times + + USAGE + Struct_Type times () + + DESCRIPTION + The `times' function returns a structure containing the + following fields: + + tms_utime (user time) + tms_stime (system time) + tms_cutime (user time of child processes) + tms_cstime (system time of child processes) + + + NOTES + Not all systems support this function. + + SEE ALSO + tic, toc, _times +-------------------------------------------------------------- + +toc + + SYNOPSIS + Get elapsed CPU time + + USAGE + Double_Type toc () + + DESCRIPTION + The `toc' function returns the elapsed CPU time in seconds since + the last call to `tic'. The CPU time is the amount of time the + CPU spent running the code of the current process. + + EXAMPLE + The `tic' and `toc' functions are ideal for timing the + execution of the interpreter: + + variable a = "hello", b = "world", c, n = 100000, t; + + tic (); loop (n) c = a + b; t = toc (); + vmessage ("a+b took %f seconds\n", t); + tic (); loop (n) c = strcat(a,b); t = toc (); + vmessage ("strcat took %f seconds\n", t); + + + NOTES + This function may not be available on all systems. + + The implementation of this function is based upon the `times' + system call. The precision of the clock is system dependent. + + SEE ALSO + tic, times, _time +-------------------------------------------------------------- + +_slang_guess_type + + SYNOPSIS + Guess the data type that a string represents. + + USAGE + DataType_Type _slang_guess_type (String_Type s) + + DESCRIPTION + This function tries to determine whether its argument `s' + represents an integer (short, int, long), floating point (float, + double), or a complex number. If it appears to be none of these, + then a string is assumed. It returns one of the following values + depending on the format of the string `s': + + Short_Type : short integer (e.g., "2h") + UShort_Type : unsigned short integer (e.g., "2hu") + Integer_Type : integer (e.g., "2") + UInteger_Type : unsigned integer (e.g., "2") + Long_Type : long integer (e.g., "2l") + ULong_Type : unsigned long integer (e.g., "2l") + Float_Type : float (e.g., "2.0f") + Double_Type : double (e.g., "2.0") + Complex_Type : imaginary (e.g., "2i") + String_Type : Anything else. (e.g., "2foo") + + For example, `_slang_guess_type("1e2")' returns + `Double_Type' but `_slang_guess_type("e12")' returns + `String_Type'. + + SEE ALSO + integer, string, double, atof +-------------------------------------------------------------- + +_typeof + + SYNOPSIS + Get the data type of an object + + USAGE + DataType_Type _typeof (x) + + DESCRIPTION + This function is similar to the `typeof' function except in the + case of arrays. If the object `x' is an array, then the data + type of the array will be returned. otherwise `_typeof' returns + the data type of `x'. + + EXAMPLE + + if (Integer_Type == _typeof (x)) + message ("x is an integer or an integer array"); + + + SEE ALSO + typeof, array_info, _slang_guess_type, typecast +-------------------------------------------------------------- + +atof + + SYNOPSIS + Convert a string to a double precision number + + USAGE + Double_Type atof (String_Type s) + + DESCRIPTION + This function converts a string `s' to a double precision value + and returns the result. It performs no error checking on the format + of the string. The function `_slang_guess_type' may be used to + check the syntax of the string. + + EXAMPLE + + define error_checked_atof (s) + { + switch (_slang_guess_type (s)) + { + case Double_Type: + return atof (s); + } + { + case Integer_Type: + return double (integer (s)); + } + + verror ("%s is not a double", s); + } + + + SEE ALSO + typecast, double, _slang_guess_type +-------------------------------------------------------------- + +char + + SYNOPSIS + Convert an ascii value into a string + + USAGE + String_Type char (Integer_Type c) + + DESCRIPTION + The `char' function converts an integer ascii value `c' to a string + of unit length such that the first character of the string is `c'. + For example, `char('a')' returns the string `"a"'. + + SEE ALSO + integer, string, typedef +-------------------------------------------------------------- + +define_case + + SYNOPSIS + Define upper-lower case conversion. + + USAGE + define_case (Integer_Type ch_up, Integer_Type ch_low); + + DESCRIPTION + This function defines an upper and lowercase relationship between two + characters specified by the arguments. This relationship is used by + routines which perform uppercase and lowercase conversions. + The first integer `ch_up' is the ascii value of the uppercase character + and the second parameter `ch_low' is the ascii value of its + lowercase counterpart. + + SEE ALSO + strlow, strup +-------------------------------------------------------------- + +double + + SYNOPSIS + Convert an object to double precision + + USAGE + result = double (x) + + DESCRIPTION + The `double' function typecasts an object `x' to double + precision. For example, if `x' is an array of integers, an + array of double types will be returned. If an object cannot be + converted to `Double_Type', a type-mismatch error will result. + + NOTES + The `double' function is equivalent to the typecast operation + + typecast (x, Double_Type) + + To convert a string to a double precision number, use the `atof' + function. + + SEE ALSO + typecast, atof, int +-------------------------------------------------------------- + +int + + SYNOPSIS + Typecast an object to an integer + + USAGE + int (s) + + DESCRIPTION + This function performs a typecast of `s' from its data type to + an object of `Integer_Type'. If `s' is a string, it returns + returns the ascii value of the first character of the string + `s'. If `s' is `Double_Type', `int' truncates the + number to an integer and returns it. + + EXAMPLE + `int' can be used to convert single character strings to + integers. As an example, the intrinsic function `isdigit' may + be defined as + + define isdigit (s) + { + if ((int (s) >= '0') and (int (s) <= '9')) return 1; + return 0; + } + + + NOTES + This function is equalent to `typecast (s, Integer_Type)'; + + SEE ALSO + typecast, double, integer, char, isdigit +-------------------------------------------------------------- + +integer + + SYNOPSIS + Convert a string to an integer + + USAGE + Integer_Type integer (String_Type s) + + DESCRIPTION + The `integer' function converts a string representation of an + integer back to an integer. If the string does not form a valid + integer, a type-mismatch error will be generated. + + EXAMPLE + `integer ("1234")' returns the integer value `1234'. + + NOTES + This function operates only on strings and is not the same as the + more general `typecast' operator. + + SEE ALSO + typecast, _slang_guess_type, string, sprintf, char +-------------------------------------------------------------- + +isdigit + + SYNOPSIS + Tests for a decimal digit character + + USAGE + Integer_Type isdigit (String_Type s) + + DESCRIPTION + This function returns a non-zero value if the first character in the + string `s' is a digit; otherwise, it returns zero. + + EXAMPLE + A simple, user defined implementation of `isdigit' is + + define isdigit (s) + { + return ((s[0] <= '9') and (s[0] >= '0')); + } + + However, the intrinsic function `isdigit' executes many times faster + than the equivalent representation defined above. + + NOTES + Unlike the C function with the same name, the S-Lang function takes + a string argument. + + SEE ALSO + int, integer +-------------------------------------------------------------- + +string + + SYNOPSIS + Convert an object to a string representation. + + USAGE + Integer_Type string (obj) + + DESCRIPTION + The `string' function may be used to convert an object + `obj' of any type to a string representation. + For example, `string(12.34)' returns `"12.34"'. + + EXAMPLE + + define print_anything (anything) + { + message (string (anything)); + } + + + NOTES + This function is _not_ the same as typecasting to a `String_Type' + using the `typecast' function. + + SEE ALSO + typecast, sprintf, integer, char +-------------------------------------------------------------- + +tolower + + SYNOPSIS + Convert a character to lowercase. + + USAGE + Integer_Type lower (Integer_Type ch) + + DESCRIPTION + This function takes an integer `ch' and returns its lowercase + equivalent. + + SEE ALSO + toupper, strup, strlow, int, char, define_case +-------------------------------------------------------------- + +toupper + + SYNOPSIS + Convert a character to uppercase. + + USAGE + Integer_Type toupper (Integer_Type ch) + + DESCRIPTION + This function takes an integer `ch' and returns its uppercase + equivalent. + + SEE ALSO + tolower, strup, strlow, int, char, define_case +-------------------------------------------------------------- + +typecast + + SYNOPSIS + Convert an object from one data type to another. + + USAGE + typecast (x, new_type) + + DESCRIPTION + The `typecast' function performs a generic typecast operation on + `x' to convert it to `new_type'. If `x' represents an + array, the function will attempt to convert all elements of `x' + to `new_type'. Not all objects can be converted and a + type-mismatch error will result upon failure. + + EXAMPLE + + define to_complex (x) + { + return typecast (x, Complex_Type); + } + + defines a function that converts its argument, `x' to a complex + number. + + SEE ALSO + int, double, typeof +-------------------------------------------------------------- + +typeof + + SYNOPSIS + Get the data type of an object. + + USAGE + DataType_Type typeof (x) + + DESCRIPTION + This function returns the data type of `x'. + + EXAMPLE + + if (Integer_Type == typeof (x)) message ("x is an integer"); + + + SEE ALSO + _typeof, is_struct_type, array_info, _slang_guess_type, typecast +-------------------------------------------------------------- + diff --git a/libslang/doc/tm/Makefile b/libslang/doc/tm/Makefile new file mode 100644 index 0000000..e4d1a27 --- /dev/null +++ b/libslang/doc/tm/Makefile @@ -0,0 +1,100 @@ +# -*- sh -*- +# +# To create the SGML files, you will need to install the tm-utils +# package. See http://www.jedsoft.org/ for more information. +# +TM2SGML = /aluche/d1/web/tm-dist/bin/tmexpand +MACRODIR = /aluche/d1/web/tm-dist/macros + +TXT_FILES = slang.txt cslang.txt cref.txt slangfun.txt +SGML_FILES = slang.sgml cslang.sgml cref.sgml slangfun.sgml +HTML_FILES = slang.html cslang.html cref.html slangfun.html +TEX_FILES = slang.tex cslang.tex #cref.tex slangfun.tex +PS_FILES = slang.ps cslang.ps #cref.ps slangfun.ps +PDF_FILES = slang.pdf cslang.pdf + +SGML2LATEX = sgml2latex -p letter -o tex +SGML2HTML = sgml2html +SGML2TXT = sgml2txt -f +TM2TXT = tools/$(ARCH)objs/tm2txt --quiet +LATEX = latex +PDFLATEX = pdflatex + +TEXTDIR = ../text +PSDIR = ../ps +HTMLDIR = ../html +SGMLDIR = ../sgml + +SUBDIRS = $(TEXTDIR) $(HTMLDIR) $(PSDIR) $(SGMLDIR) +SRCDIR = `pwd` + +all: $(SGML_FILES) $(HTML_FILES) $(TEX_FILES) $(TXT_FILES) +text-files: $(TXT_FILES) +#----- SGML Files ----------------------------------------------------------- +cslang.sgml : cslang.tm preface.tm copyright.tm + $(TM2SGML) -I$(MACRODIR) cslang.tm cslang.sgml +slang.sgml : slang.tm preface.tm copyright.tm + $(TM2SGML) -I$(MACRODIR) slang.tm slang.sgml +cref.sgml : cref.tm + $(TM2SGML) -I$(MACRODIR) cref.tm cref.sgml +slangfun.sgml : slangfun.tm + $(TM2SGML) -I$(MACRODIR) slangfun.tm slangfun.sgml +#----- HTML Files ----------------------------------------------------------- +cslang.html : cslang.sgml + $(SGML2HTML) cslang.sgml +slang.html : slang.sgml + $(SGML2HTML) slang.sgml +cref.html : cref.sgml + $(SGML2HTML) cref.sgml +slangfun.html : slangfun.sgml + $(SGML2HTML) slangfun.sgml +#----- TeX Files ------------------------------------------------------------ +slang.tex : slang.sgml + $(SGML2LATEX) slang.sgml + jed -script ./fixtex.sl slang.tex +cslang.tex : cslang.sgml + $(SGML2LATEX) cslang.sgml + jed -script ./fixtex.sl cslang.tex +#----- PDF Files ----------------------------------------------------------- +cslang.pdf : cslang.tex + $(PDFLATEX) cslang.tex + $(PDFLATEX) cslang.tex +slang.pdf : slang.tex + $(PDFLATEX) slang.tex + $(PDFLATEX) slang.tex +#----- PS Files ----------------------------------------------------------- +cslang.ps : cslang.tex + $(LATEX) cslang.tex + $(LATEX) cslang.tex + dvips -o cslang.ps cslang.dvi +slang.ps : slang.tex + $(LATEX) slang.tex + $(LATEX) slang.tex + dvips -o slang.ps slang.dvi +#----- Text Files ----------------------------------------------------------- +cslang.txt: cslang.sgml + $(SGML2TXT) cslang.sgml +slang.txt: slang.sgml + $(SGML2TXT) slang.sgml +# +slangfun.txt : slangfun.tm $(TM2TXT) + cat rtl/*.tm | $(TM2TXT) > slangfun.txt +cref.txt : cref.tm $(TM2TXT) + $(TM2TXT) < cref.tm > cref.txt +$(TM2TXT) : tools/tm2txt.c + cd tools; make SRCDIR=$(SRCDIR) +#---------------------------------------------------------------------------- +clean: + -rm -f *~ *.dvi *.log *.aux *.toc rtl/*.BAK rtl/*~ *.tmp +distclean: clean + -rm -f *.html *.ps $(TXT_FILES) $(TEX_FILES) $(SGML_FILES) $(PDF_FILES) + cd tools; make clean +install-txt-files: $(TXT_FILES) + -mv $(TXT_FILES) ../text + +install: all $(PS_FILES) + -mkdir $(SUBDIRS) + -mv $(TXT_FILES) ../text + -mv *.html ../html + -mv $(PS_FILES) ../ps + -mv $(SGML_FILES) ../sgml diff --git a/libslang/doc/tm/copyright.tm b/libslang/doc/tm/copyright.tm new file mode 100644 index 0000000..f82a631 --- /dev/null +++ b/libslang/doc/tm/copyright.tm @@ -0,0 +1,476 @@ +\chapter{Copyright} + The \slang library is distributed under two copyrights: the GNU + Genral Public License, and the Artistic License. Any program + that uses the interpreter must adhere to rules of one of these + licenses. + +\sect{The GNU Public License} +#v+ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble +#v- + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. +#v+ + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION +#v- + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: +#v+ + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) +#v- +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: +#v+ + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) +#v- +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. +#v+ + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS +#v- + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. +#v+ + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +#v- +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: +#v+ + Gnomovision version 69, Copyright (C) 19yy name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. +#v- +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: +#v+ + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice +#v- +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. + +\sect{The Artistic License} +#v+ + The "Artistic License" + + Preamble +#v- +The intent of this document is to state the conditions under which a +Package may be copied, such that the Copyright Holder maintains some +semblance of artistic control over the development of the package, +while giving the users of the package the right to use and distribute +the Package in a more-or-less customary fashion, plus the right to make +reasonable modifications. + +Definitions: +#v+ + "Package" refers to the collection of files distributed by the + Copyright Holder, and derivatives of that collection of files + created through textual modification. + + "Standard Version" refers to such a Package if it has not been + modified, or has been modified in accordance with the wishes + of the Copyright Holder as specified below. + + "Copyright Holder" is whoever is named in the copyright or + copyrights for the package. + + "You" is you, if you're thinking about copying or distributing + this Package. + + "Reasonable copying fee" is whatever you can justify on the + basis of media cost, duplication charges, time of people involved, + and so on. (You will not be required to justify it to the + Copyright Holder, but only to the computing community at large + as a market that must bear the fee.) + + "Freely Available" means that no fee is charged for the item + itself, though there may be fees involved in handling the item. + It also means that recipients of the item may redistribute it + under the same conditions they received it. +#v- +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications +derived from the Public Domain or from the Copyright Holder. A Package +modified in such a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided +that you insert a prominent notice in each changed file stating how and +when you changed that file, and provided that you do at least ONE of the +following: +#v+ + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or + an equivalent medium, or placing the modifications on a major archive + site such as uunet.uu.net, or by allowing the Copyright Holder to include + your modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and provide + a separate manual page for each non-standard executable that clearly + documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. +#v- +4. You may distribute the programs of this Package in object code or +executable form, provided that you do at least ONE of the following: +#v+ + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where + to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), together + with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. +#v- +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this +Package. You may not charge a fee for this Package itself. However, +you may distribute this Package in aggregate with other (possibly +commercial) programs as part of a larger (possibly commercial) software +distribution provided that you do not advertise this Package as a +product of your own. You may embed this Package's interpreter within +an executable of yours (by linking); this shall be construed as a mere +form of aggregation, provided that the complete Standard Version of the +interpreter is so embedded. + +6. The scripts and library files supplied as input to or produced as +output from the programs of this Package do not automatically fall +under the copyright of this Package, but belong to whomever generated +them, and may be sold commercially, and may be aggregated with this +Package. If such scripts or library files are aggregated with this +Package via the so-called "undump" or "unexec" methods of producing a +binary executable image, then distribution of such an image shall +neither be construed as a distribution of this Package nor shall it +fall under the restrictions of Paragraphs 3 and 4, provided that you do +not represent such an executable image as a Standard Version of this +Package. + +7. C subroutines (or comparably compiled subroutines in other +languages) supplied by you and linked into this Package in order to +emulate subroutines and variables of the language defined by this +Package shall not be considered part of this Package, but are the +equivalent of input as in Paragraph 6, provided these subroutines do +not change the language in any way that would cause it to fail the +regression tests for the language. + +8. Aggregation of this Package with a commercial distribution is always +permitted provided that the use of this Package is embedded; that is, +when no overt attempt is made to make this Package's interfaces visible +to the end user of the commercial distribution. Such use shall not be +construed as a distribution of this Package. + +9. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + diff --git a/libslang/doc/tm/cref.tm b/libslang/doc/tm/cref.tm new file mode 100644 index 0000000..527c145 --- /dev/null +++ b/libslang/doc/tm/cref.tm @@ -0,0 +1,3430 @@ +#i linuxdoc.tm + +#d slang \bf{S-lang} +#d jed \bf{jed} +#d slang-c-programmers-guide \em{S-Lang Library C Programmer's Guide} +#d kw#1 \tt{$1} +#d exmp#1 \tt{$1} +#d var#1 \tt{$1} +#d ldots ... +#d chapter#1 $1

+#d preface +#d tag#1 $1 + +#d function#1 \sect{$1\label{$1}} +#d variable#1 \sect{$1\label{$1}} +#cd function#1

$1\label{$1}

+#d synopsis#1 Synopsis $1 +#d keywords#1 Keywords $1 +#d usage#1 Usage $1 +#d description Description +#d example Example +#d notes Notes +#d seealso#1 See Also $1 +#d documentstyle article +#d r#1 \ref{$1}{$1} +#d done

+#d 0 \exmp{0} +#d -1 \exmp{-1} +#d 1 \exmp{1} + +\linuxdoc +\begin{\documentstyle} + +\title {The \slang C Library Reference} +\author John E. Davis, \tt{davis@space.mit.edu} +\date \__today__ + +\toc + + +\function{SLsmg_fill_region} +\synopsis{Fill a rectangular region with a character} +\usage{void SLsmg_fill_region (r, c, nr, nc, ch)} +#v+ + int r + int c + unsigned int nr + unsigned int nc + unsigned char ch +#v- +\description + The \var{SLsmg_fill_region} function may be used to a + rectangular region with the character \var{ch} in the current color. + The rectangle's upper left corner is at row \var{r} and column + \var{c}, and spans \var{nr} rows and \var{nc} columns. The position + of the virtual cursor will be left at (\var{r}, \var{c}). +\seealso{SLsmg_write_char, SLsmg_set_color} +\done + + + +\function{SLsmg_set_char_set} +\synopsis{Turn on or off line drawing characters} +\usage{void SLsmg_set_char_set (int a);} +\description + \var{SLsmg_set_char_set} may be used to select or deselect the line drawing + character set as the current character set. If \var{a} is non-zero, + the line drawing character set will be selected. Otherwise, the + standard character set will be selected. +\notes + There is no guarantee that this function will actually enable the + use of line drawing characters. All it does is cause subsequent + characters to be rendered using the terminal's alternate character + set. Such character sets usually contain line drawing characters. +\seealso{SLsmg_write_char, SLtt_get_terminfo} +\done + + +\variable{int SLsmg_Scroll_Hash_Border;} +\synopsis{Set the size of the border for the scroll hash} +\usage{int SLsmg_Scroll_Hash_Border = 0;} +\description + This variable may be used to ignore the characters that occur at the + beginning and the end of a row when performing the hash calculation + to determine whether or not a line has scrolled. The default value + is zero which means that all the characters on a line will be used. +\seealso{SLsmg_refresh} +\done + + +\function{SLsmg_suspend_smg} +\synopsis{Suspend screen management} +\usage{int SLsmg_suspend_smg (void)} +\description + \var{SLsmg_suspend_smg} can be used to suspend the state of the + screen management facility during suspension of the program. Use of + this function will reset the display back to its default state. The + funtion \var{SLsmg_resume_smg} should be called after suspension. + + It returns zero upon success, or \-1 upon error. + + This function is similar to \var{SLsmg_reset_smg} except that the + state of the display prior to calling \var{SLsmg_suspend_smg} is saved. +\seealso{SLsmg_resume_smg, SLsmg_reset_smg} +\done + + +\function{SLsmg_resume_smg} +\synopsis{Resume screen management} +\usage{int SLsmg_resume_smg (void)} +\description + \var{SLsmg_resume_smg} should be called after + \var{SLsmg_suspend_smg} to redraw the display exactly like it was + before \var{SLsmg_suspend_smg} was called. It returns zero upon + success, or \-1 upon error. +\seealso{SLsmg_suspend_smg} +\done + + +\function{SLsmg_erase_eol} +\synopsis{Erase to the end of the row} +\usage{void SLsmg_erase_eol (void);} +\description + \var{SLsmg_erase_eol} erases all characters from the current + position to the end of the line. The newly created space is given + the color of the current color. This function has no effect on the + position of the virtual cursor. +\seealso{SLsmg_gotorc, SLsmg_erase_eos, SLsmg_fill_region} +\done + + +\function{SLsmg_gotorc} +\synopsis{Move the virtual cursor} +\usage{void SLsmg_gotorc (int r, int c)} +\description + The \var{SLsmg_gotorc} function moves the virtual cursor to the row + \var{r} and column \var{c}. The first row and first column is + specified by \exmp{r = 0} and \exmp{c = 0}. +\seealso{SLsmg_refresh} +\done + + +\function{SLsmg_erase_eos} +\synopsis{Erase to the end of the screen} +\usage{void SLsmg_erase_eos (void);} +\description + The \var{SLsmg_erase_eos} is like \var{SLsmg_erase_eol} except that + it erases all text from the current position to the end of the + display. The current color will be used to set the background of + the erased area. +\seealso{SLsmg_erase_eol} +\done + + +\function{SLsmg_reverse_video} +\synopsis{Set the current color to 1} +\usage{void SLsmg_reverse_video (void);} +\description + This function is nothing more than \exmp{SLsmg_set_color(1)}. +\seealso{SLsmg_set_color} +\done + + +\function{SLsmg_set_color (int)} +\synopsis{Set the current color} +\usage{void SLsmg_set_color (int c);} +\description + \var{SLsmg_set_color} is used to set the current color. The + parameter \var{c} is really a color object descriptor. Actual + foreground and background colors as well as other visual attributes + may be associated with a color descriptor via the + \var{SLtt_set_color} function. +\example + This example defines color \exmp{7} to be green foreground on black + background and then displays some text in this color: +#v+ + SLtt_set_color (7, NULL, "green", "black"); + SLsmg_set_color (7); + SLsmg_write_string ("Hello"); + SLsmg_refresh (); +#v- +\notes + It is important to understand that the screen managment routines + know nothing about the actual colors associated with a color + descriptor. Only the descriptor itself is used by the \var{SLsmg} + routines. The lower level \var{SLtt} interface converts the color + descriptors to actual colors. Thus +#v+ + SLtt_set_color (7, NULL, "green", "black"); + SLsmg_set_color (7); + SLsmg_write_string ("Hello"); + SLtt_set_color (7, NULL, "red", "blue"); + SLsmg_write_string ("World"); + SLsmg_refresh (); +#v- + will result in \exmp{"hello"} displayed in red on blue and \em{not} + green on black. +\seealso{SLtt_set_color, SLtt_set_color_object} +\done + + +\function{SLsmg_normal_video} +\synopsis{Set the current color to 0} +\usage{void SLsmg_normal_video (void);} +\description + \var{SLsmg_normal_video} sets the current color descriptor to \var{0}. +\seealso{SLsmg_set_color} +\done + + +\function{SLsmg_printf} +\synopsis{Format a string on the virtual display} +\usage{void SLsmg_printf (char *fmt, ...)} +\description + \var{SLsmg_printf} format a \var{printf} style variable argument + list and writes it on the virtual display. The virtual cursor will + be moved to the end of the string. +\seealso{SLsmg_write_string, SLsmg_vprintf} +\done + + +\function{SLsmg_vprintf} +\synopsis{Format a string on the virtual display} +\usage{void SLsmg_vprintf (char *fmt, va_list ap)} +\description + \var{SLsmg_vprintf} formats a string in the manner of \em{vprintf} + and writes the result to the display. The virtual cursor is + advanced to the end of the string. +\seealso{SLsmg_write_string, SLsmg_printf} +\done + + +\function{SLsmg_write_string} +\synopsis{Write a character string on the display } +\usage{void SLsmg_write_string (char *s)} +\description + The function \var{SLsmg_write_string} displays the string \var{s} on + the virtual display at the current position and moves the position + to the end of the string. +\seealso{SLsmg_printf, SLsmg_write_nstring} +\done + + +\function{SLsmg_write_nstring} +\synopsis{Write the first n characters of a string on the display} +\usage{void SLsmg_write_nstring (char *s, unsigned int n);} +\description + \var{SLsmg_write_nstring} writes the first \var{n} characters of + \var{s} to this virtual display. If the length of the string + \var{s} is less than \var{n}, the spaces will used until + \var{n} characters have been written. \var{s} can be \var{NULL}, in + which case \var{n} spaces will be written. +\seealso{SLsmg_write_string, SLsmg_write_nchars} +\done + + +\function{SLsmg_write_char} +\synopsis{Write a character to the virtual display} +\usage{void SLsmg_write_char (char ch);} +\description + \var{SLsmg_write_char} writes the character \var{ch} to the virtual + display. +\seealso{SLsmg_write_nchars, SLsmg_write_string} +\done + + +\function{SLsmg_write_nchars} +\synopsis{Write n characters to the virtual display} +\usage{void SLsmg_write_nchars (char *s, unsigned int n);} +\description + \var{SLsmg_write_nchars} writes at most \var{n} characters from the + string \var{s} to the display. If the length of \var{s} is less + than \var{n}, the whole length of the string will get written. + + This function differs from \var{SLsmg_write_nstring} in that + \var{SLsmg_write_nstring} will pad the string to write exactly + \var{n} characters. \var{SLsmg_write_nchars} does not perform any + padding. +\seealso{SLsmg_write_nchars, SLsmg_write_nstring} +\done + + +\function{SLsmg_write_wrapped_string} +\synopsis{Write a string to the display with wrapping} +\usage{void SLsmg_write_wrapped_string (s, r, c, nr, nc, fill)} +#v+ + char *s + int r, c + unsigned int nr, nc + int fill +#v- +\description + \var{SLsmg_write_wrapped_string} writes the string \var{s} to the + virtual display. The string will be confined to the rectangular + region whose upper right corner is at row \var{r} and column \var{c}, + and consists of \var{nr} rows and \var{nc} columns. The string will + be wrapped at the boundaries of the box. If \var{fill} is non-zero, + the last line to which characters have been written will get padded + with spaces. +\notes + This function does not wrap on word boundaries. However, it will + wrap when a newline charater is encountered. +\seealso{SLsmg_write_string} +\done + + +\function{SLsmg_cls} +\synopsis{Clear the virtual display} +\usage{void SLsmg_cls (void)} +\description + \var{SLsmg_cls} erases the virtual display using the current color. + This will cause the physical display to get cleared the next time + \var{SLsmg_refresh} is called. +\notes + This function is not the same as +#v+ + SLsmg_gotorc (0,0); SLsmg_erase_eos (); +#v- + since these statements do not guarantee that the physical screen + will get cleared. +\seealso{SLsmg_refresh, SLsmg_erase_eos} +\done + + +\function{SLsmg_refresh} +\synopsis{Update physical screen} +\usage{void SLsmg_refresh (void)} +\description + The \var{SLsmg_refresh} function updates the physical display to + look like the virtual display. +\seealso{SLsmg_suspend_smg, SLsmg_init_smg, SLsmg_reset_smg} +\done + + +\function{SLsmg_touch_lines} +\synopsis{Mark lines on the virtual display for redisplay} +\usage{void SLsmg_touch_lines (int r, unsigned int nr)} +\description + \var{SLsmg_touch_lines} marks the \var{nr} lines on the virtual + display starting at row \var{r} for redisplay upon the next call to + \var{SLsmg_refresh}. +\notes + This function should rarely be called, if ever. If you find that + you need to call this function, then your application should be + modified to properly use the \var{SLsmg} screen management routines. + This function is provided only for curses compatibility. +\seealso{SLsmg_refresh} +\done + +\function{SLsmg_init_smg} +\synopsis{Initialize the \var{SLsmg} routines} +\usage{int SLsmg_init_smg (void)} +\description + The \var{SLsmg_init_smg} function initializes the \var{SLsmg} screen + management routines. Specifically, this function allocates space + for the virtual display and calls \var{SLtt_init_video} to put the + terminal's physical display in the proper state. It is up to the + caller to make sure that the \var{SLtt} routines are initialized via + \var{SLtt_get_terminfo} before calling \var{SLsmg_init_smg}. + + This function should also be called any time the size of the + physical display has changed so that it can reallocate a new virtual + display to match the physical display. + + It returns zero upon success, or \-1 upon failure. +\seealso{SLsmg_reset_smg} +\done + + +\function{SLsmg_reset_smg} +\synopsis{Reset the \var{SLsmg} routines} +\usage{int SLsmg_reset_smg (void);} +\description + \var{SLsmg_reset_smg} resets the \var{SLsmg} screen management + routines by freeing all memory allocated while it was active. It + also calls \var{SLtt_reset_video} to put the terminal's display in + it default state. +\seealso{SLsmg_init_smg} +\done + + +\function{SLsmg_char_at} +\synopsis{Get the character at the current position on the virtual display} +\usage{unsigned short SLsmg_char_at(void)} +\description + The \var{SLsmg_char_at} function returns the character and its color + at the current position on the virtual display. +\seealso{SLsmg_read_raw, SLsmg_write_char} +\done + + +\function{SLsmg_set_screen_start} +\synopsis{Set the origin of the virtual display} +\usage{void SLsmg_set_screen_start (int *r, int *c)} +\description + \var{SLsmg_set_screen_start} sets the origin of the virtual display + to the row \var{*r} and the column \var{*c}. If either \var{r} or \var{c} + is \var{NULL}, then the corresponding value will be set to \var{0}. + Otherwise, the location specified by the pointers will be updated to + reflect the old origin. + + See \tt{slang/demo/pager.c} for how this function may be used to + scroll horizontally. +\seealso{SLsmg_init_smg} +\done + + +\function{SLsmg_draw_hline} +\synopsis{Draw a horizontal line} +\usage{void SLsmg_draw_hline (unsigned int len)} +\description + The \var{SLsmg_draw_hline} function draws a horizontal line of + length \var{len} on the virtual display. The position of the + virtual cursor is left at the end of the line. +\seealso{SLsmg_draw_vline} +\done + + +\function{SLsmg_draw_vline} +\synopsis{Draw a vertical line} +\usage{void SLsmg_draw_vline (unsigned int len);} +\description + The \var{SLsmg_draw_vline} function draws a vertical line of + length \var{len} on the virtual display. The position of the + virtual cursor is left at the end of the line. +\seealso{??} +\done + + +\function{SLsmg_draw_object} +\synopsis{Draw an object from the alternate character set} +\usage{void SLsmg_draw_object (int r, int c, unsigned char obj)} +\description + The \var{SLsmg_draw_object} function may be used to place the object + specified by \var{obj} at row \var{r} and column \var{c}. The + object is really a character from the alternate character set and + may be specified using one of the following constants: +#v+ + SLSMG_HLINE_CHAR Horizontal line + SLSMG_VLINE_CHAR Vertical line + SLSMG_ULCORN_CHAR Upper left corner + SLSMG_URCORN_CHAR Upper right corner + SLSMG_LLCORN_CHAR Lower left corner + SLSMG_LRCORN_CHAR Lower right corner + SLSMG_CKBRD_CHAR Checkboard character + SLSMG_RTEE_CHAR Right Tee + SLSMG_LTEE_CHAR Left Tee + SLSMG_UTEE_CHAR Up Tee + SLSMG_DTEE_CHAR Down Tee + SLSMG_PLUS_CHAR Plus or Cross character +#v- +\seealso{SLsmg_draw_vline, SLsmg_draw_hline, SLsmg_draw_box} +\done + + +\function{SLsmg_draw_box} +\synopsis{Draw a box on the virtual display} +\usage{void SLsmg_draw_box (int r, int c, unsigned int dr, unsigned int dc)} +\description + \var{SLsmg_draw_box} uses the \var{SLsmg_draw_hline} and + \var{SLsmg_draw_vline} functions to draw a rectangular box on the + virtual display. The box's upper left corner is placed at row + \var{r} and column \var{c}. The width and length of the box is + specified by \var{dc} and \var{dr}, respectively. +\seealso{SLsmg_draw_vline, SLsmg_draw_hline, SLsmg_draw_object} +\done + +\function{SLsmg_set_color_in_region} +\synopsis{Change the color of a specifed region} +\usage{void SLsmg_set_color_in_region (color, r, c, dr, dc)} +#v+ + int color; + int r, c; + unsigned int dr, dc; +#v- +\description + \var{SLsmg_set_color_in_region} may be used to change the color of a + rectangular region whose upper left corner is given by + (\var{r},\var{c}), and whose width and height is given by \var{dc} + and \var{dr}, respectively. The color of the region is given by the + \var{color} parameter. +\seealso{SLsmg_draw_box, SLsmg_set_color} +\done + + +\function{SLsmg_get_column} +\synopsis{Get the column of the virtual cursor} +\usage{int SLsmg_get_column(void);} +\description + The \var{SLsmg_get_column} function returns the current column of + the virtual cursor on the virtual display. +\seealso{SLsmg_get_row, SLsmg_gotorc} +\done + + +\function{SLsmg_get_row} +\synopsis{Get the row of the virtual cursor} +\usage{int SLsmg_get_row(void);} +\description + The \var{SLsmg_get_row} function returns the current row of the + virtual cursor on the virtual display. +\seealso{SLsmg_get_column, SLsmg_gotorc} +\done + + +\function{SLsmg_forward} +\synopsis{Move the virtual cursor forward n columns} +\usage{void SLsmg_forward (int n);} +\description + The \var{SLsmg_forward} function moves the virtual cursor forward + \var{n} columns. +\seealso{SLsmg_gotorc} +\done + + +\function{SLsmg_write_color_chars} +\synopsis{Write characters with color descriptors to virtual display} +\usage{void SLsmg_write_color_chars (unsigned short *s, unsigned int len)} +\description + The \var{SLsmg_write_color_chars} function may be used to write + \var{len} characters, each with a different color descriptor to the + virtual display. Each character and its associated color are + encoded as an \exmp{unsigned short} such that the lower eight bits + form the character and the next eight bits form the color. +\seealso{SLsmg_char_at, SLsmg_write_raw} +\done + + +\function{SLsmg_read_raw} +\synopsis{Read characters from the virtual display} +\usage{unsigned int SLsmg_read_raw (unsigned short *buf, unsigned int len)} +\description + \var{SLsmg_read_raw} attempts to read \var{len} characters from the + current position on the virtual display into the buffer specified by + \var{buf}. It returns the number of characters actually read. This + number will be less than \var{len} if an attempt is made to read + past the right margin of the display. +\notes + The purpose of the pair of functions, \var{SLsmg_read_raw} and + \var{SLsmg_write_raw}, is to permit one to copy the contents of one + region of the virtual display to another region. +\seealso{SLsmg_char_at, SLsmg_write_raw} +\done + + +\function{SLsmg_write_raw} +\synopsis{Write characters directly to the virtual display} +\usage{unsigned int SLsmg_write_raw (unsigned short *buf, unsigned int len)} +\description + The \var{SLsmg_write_raw} function attempts to write \var{len} + characters specified by \var{buf} to the display at the current + position. It returns the number of characters successfully written, + which will be less than \var{len} if an attempt is made to write + past the right margin. +\notes + The purpose of the pair of functions, \var{SLsmg_read_raw} and + \var{SLsmg_write_raw}, is to permit one to copy the contents of one + region of the virtual display to another region. +\seealso{SLsmg_read_raw} +\done + + +\function{SLallocate_load_type} +\synopsis{Allocate a SLang_Load_Type object} +\usage{SLang_Load_Type *SLallocate_load_type (char *name)} +\description + The \var{SLallocate_load_type} function allocates and initializes + space for a \var{SLang_Load_Type} object and returns it. Upon + failure, the function returns \var{NULL}. The parameter \var{name} + must uniquely identify the object. For example, if the object + represents a file, then \var{name} could be the absolute path name + of the file. +\seealso{SLdeallocate_load_type, SLang_load_object} +\done + +\function{SLdeallocate_load_type} +\synopsis{Free a SLang_Load_Type object} +\usage{void SLdeallocate_load_type (SLang_Load_Type *slt)} +\description + This function frees the memory associated with a + \var{SLang_Load_Type} object that was acquired from a call to the + \var{SLallocate_load_type} function. +\seealso{SLallocate_load_type, SLang_load_object} +\done + + +\function{SLang_load_object} +\synopsis{Load an object into the interpreter} +\usage{int SLang_load_object (SLang_Load_Type *obj)} +\description + The function \var{SLang_load_object} is a generic function that may + be used to loaded an object of type \var{SLang_Load_Type} into the + interpreter. For example, the functions \var{SLang_load_file} and + \var{SLang_load_string} are wrappers around this function to load a + file and a string, respectively. +\seealso{SLang_load_file, SLang_load_string, SLallocate_load_type} +\done + + +\function{SLclass_allocate_class} +\synopsis{Allocate a class for a new data type} +\usage{SLang_Class_Type *SLclass_allocate_class (char *name)} +\description + The purpose of this function is to allocate and initialize space + that defines a new data type or class called \var{name}. If + successful, a pointer to the class is returned, or upon failure the + function returns \var{NULL}. + + This function does not automatically create the new data type. + Callback functions must first be associated with the data type via + functions such as \var{SLclass_set_push_function}, and the data + type must be registered with the interpreter via + \var{SLclass_register_class}. See the \slang library programmer's + guide for more information. +\seealso{SLclass_register_class, SLclass_set_push_function} +\done + + +\function{SLclass_register_class} +\synopsis{Register a new data type with the interpreter} +\usage{int SLclass_register_class (cl, type, sizeof_type, class_type)} +#v+ + SLang_Class_Type *cl + unsigned char type + unsigned int sizeof_type + unsigned char class_type +#v- +\description + The \var{SLclass_register_class} function is used to register a new + class or data type with the interpreter. If successful, the + function returns \exmp{0}, or upon failure, it returns \var{-1}. + + The first parameter, \var{cl}, must have been previously obtained + via the \var{SLclass_allocate_class} function. + + The second parameter, \var{type} specifies the data type of the new + class. It must be an unsigned character with value greater that + \exmp{127}. The values in the range \exmp{0-127} are reserved for + internal use by the library. + + The size that the data type represents in bytes is specified by the + third parameter, \var{sizeof_type}. This value should not be + confused with the sizeof the structure that represents the data + type, unless the data type is of class \var{SLANG_CLASS_TYPE_VECTOR} + or \var{SLANG_CLASS_TYPE_SCALAR}. For pointer objects, the value + of this parameter is just \var{sizeof(void *)}. + + The final parameter specifies the class type of the data type. It must + be one of the values: +#v+ + SLANG_CLASS_TYPE_SCALAR + SLANG_CLASS_TYPE_VECTOR + SLANG_CLASS_TYPE_PTR + SLANG_CLASS_TYPE_MMT +#v- + The \var{SLANG_CLASS_TYPE_SCALAR} indicates that the new data type + is a scalar. Examples of scalars in \var{SLANG_INT_TYPE} and + \var{SLANG_DOUBLE_TYPE}. + + Setting \var{class_type} to SLANG_CLASS_TYPE_VECTOR implies that the + new data type is a vector, or a 1-d array of scalar types. An + example of a data type of this class is the + \var{SLANG_COMPLEX_TYPE}, which represents complex numbers. + + \var{SLANG_CLASS_TYPE_PTR} specifies the data type is of a pointer + type. Examples of data types of this class include + \var{SLANG_STRING_TYPE} and \var{SLANG_ARRAY_TYPE}. Such types must + provide for their own memory management. + + Data types of class \var{SLANG_CLASS_TYPE_MMT} are pointer types + except that the memory management, i.e., creation and destruction of + the type, is handled by the interpreter. Such a type is called a + \em{memory managed type}. An example of this data type is the + \var{SLANG_FILEPTR_TYPE}. +\notes + See the \slang-c-programmers-guide for more information. +\seealso{SLclass_allocate_class} +\done + + +\function{SLclass_set_string_function} +\synopsis{Set a data type's string representation callback} +\usage{int SLclass_set_string_function (cl, sfun)} +#v+ + SLang_Class_Type *cl + char *(*sfun) (unsigned char, VOID_STAR); +#v- +\description + The \var{SLclass_set_string_function} routine is used to define a + callback function, \var{sfun}, that will be used when a string + representation of an object of the data type represented by \var{cl} + is needed. \var{cl} must have already been obtained via a call to + \var{SLclass_allocate_class}. When called, \var{sfun} will be + passed two arguments: a unsigned char which represents the data + type, and the address of the object for which a string represetation + is required. The callback function must return a \em{malloced} + string. + + Upon success, \var{SLclass_set_string_function} returns zero, or + upon error it returns \-1. +\example + A callback function that handles both \var{SLANG_STRING_TYPE} and + \var{SLANG_INT_TYPE} variables looks like: +#v+ + char *string_and_int_callback (unsigned char type, VOID_STAR addr) + { + char buf[64]; + + switch (type) + { + case SLANG_STRING_TYPE: + return SLmake_string (*(char **)addr); + + case SLANG_INTEGER_TYPE: + sprintf (buf, "%d", *(int *)addr); + return SLmake_string (buf); + } + return NULL; + } +#v- +\notes + The default string callback simply returns the name of the data type. +\seealso{SLclass_allocate_class, SLclass_register_class} +\done + + +\function{SLclass_set_destroy_function} +\synopsis{Set the destroy method callback for a data type} +\usage{int SLclass_set_destroy_function (cl, destroy_fun)} +#v+ + SLang_Class_Type *cl + void (*destroy_fun) (unsigned char, VOID_STAR); +#v- +\description + \var{SLclass_set_destroy_function} is used to set the destroy + callback for a data type. The data type's class \var{cl} must have + been previously obtained via a call to \var{SLclass_allocate_class}. + When called, \var{destroy_fun} will be passed two arguments: a + unsigned char which represents the data type, and the address of the + object to be destroyed. + + \var{SLclass_set_destroy_function} returns zero upon success, and + \-1 upon failure. +\example + The destroy method for \var{SLANG_STRING_TYPE} looks like: +#v+ + static void string_destroy (unsigned char type, VOID_STAR ptr) + { + char *s = *(char **) ptr; + if (s != NULL) SLang_free_slstring (*(char **) s); + } +#v- +\notes + Data types of class SLANG_CLASS_TYPE_SCALAR do not require a destroy + callback. However, other classes do. +\seealso{SLclass_allocate_class, SLclass_register_class} +\done + + +\function{SLclass_set_push_function} +\synopsis{Set the push callback for a new data type} +\usage{int SLclass_set_push_function (cl, push_fun)} +#v+ + SLang_Class_Type *cl + int (*push_fun) (unsigned char, VOID_STAR); +#v- +\description + \var{SLclass_set_push_function} is used to set the push callback + for a new data type specified by \var{cl}, which must have been + previously obtained via \var{SLclass_allocate_class}. + + The parameter \var{push_fun} is a pointer to the push callback. It + is required to take two arguments: an unsigned character + representing the data type, and the address of the object to be + pushed. It must return zero upon success, or \-1 upon failure. + + \var{SLclass_set_push_function} returns zero upon success, or \-1 + upon failure. +\example + The push callback for \var{SLANG_COMPLEX_TYPE} looks like: +#v+ + static int complex_push (unsigned char type, VOID_STAR ptr) + { + double *z = *(double **) ptr; + return SLang_push_complex (z[0], z[1]); + } +#v- +\seealso{SLclass_allocate_class, SLclass_register_class} +\done + + +\function{SLclass_set_pop_function} +\synopsis{Set the pop callback for a new data type} +\usage{int SLclass_set_pop_function (cl, pop_fun)} +#v+ + SLang_Class_Type *cl + int (*pop_fun) (unsigned char, VOID_STAR); +#v- +\description + \var{SLclass_set_pop_function} is used to set the callback for + popping an object from the stack for a new data type specified by + \var{cl}, which must have been previously obtained via + \var{SLclass_allocate_class}. + + The parameter \var{pop_fun} is a pointer to the pop callback + function, which is required to take two arguments: an unsigned + character representing the data type, and the address of the object + to be popped. It must return zero upon success, or \-1 upon + failure. + + \var{SLclass_set_pop_function} returns zero upon success, or \-1 + upon failure. +\example + The pop callback for \var{SLANG_COMPLEX_TYPE} looks like: +#v+ + static int complex_push (unsigned char type, VOID_STAR ptr) + { + double *z = *(double **) ptr; + return SLang_pop_complex (&z[0], &z[1]); + } +#v- +\seealso{SLclass_allocate_class, SLclass_register_class} +\done + + +\function{SLclass_get_datatype_name} +\synopsis{Get the name of a data type} +\usage{char *SLclass_get_datatype_name (unsigned char type)} +\description + The \var{SLclass_get_datatype_name} function returns the name of the + data type specified by \var{type}. For example, if \var{type} is + \var{SLANG_INT_TYPE}, the string \exmp{"Integer_Type"} will be + returned. + + This function returns a pointer that should not be modified or freed. +\seealso{SLclass_allocate_class, SLclass_register_class} +\done + +\function{SLang_free_mmt} +\synopsis{Free a memory managed type} +\usage{void SLang_free_mmt (SLang_MMT_Type *mmt)} +\description + The \var{SLang_MMT_Type} function is used to free a memory managed + data type. +\seealso{SLang_object_from_mmt, SLang_create_mmt} +\done + + +\function{SLang_object_from_mmt} +\synopsis{Get a pointer to the value of a memory managed type} +\usage{VOID_STAR SLang_object_from_mmt (SLang_MMT_Type *mmt)} +\description + The \var{SLang_object_from_mmt} function returns a pointer to the + actual object whose memory is being managed by the interpreter. +\seealso{SLang_free_mmt, SLang_create_mmt} +\done + + +\function{SLang_create_mmt} +\synopsis{Create a memory managed data type} +\usage{SLang_MMT_Type *SLang_create_mmt (unsigned char t, VOID_STAR ptr)} +\description + The \var{SLang_create_mmt} function returns a pointer to a new + memory managed object. This object contains information necessary + to manage the memory associated with the pointer \var{ptr} which + represents the application defined data type of type \var{t}. +\seealso{SLang_object_from_mmt, SLang_push_mmt, SLang_free_mmt} +\done + + +\function{SLang_push_mmt} +\synopsis{Push a memory managed type} +\usage{int SLang_push_mmt (SLang_MMT_Type *mmt)} +\description + This function is used to push a memory managed type onto the + interpreter stack. It returns zero upon success, or \exmp{-1} upon + failure. +\seealso{SLang_create_mmt, SLang_pop_mmt} +\done + + +\function{SLang_pop_mmt} +\synopsis{Pop a memory managed data type} +\usage{SLang_MMT_Type *SLang_pop_mmt (unsigned char t)} +\description + The \var{SLang_pop_mmt} function may be used to pop a memory managed + type of type \var{t} from the stack. It returns a pointer to the + memory managed object upon success, or \var{NULL} upon failure. The + function \var{SLang_object_from_mmt} should be used to access the + actual pointer to the data type. +\seealso{SLang_object_from_mmt, SLang_push_mmt} +\done + + +\function{SLang_inc_mmt} +\synopsis{Increment a memory managed type reference count} +\usage{void SLang_inc_mmt (SLang_MMT_Type *mmt);} +\description + The \var{SLang_inc_mmt} function may be used to increment the + reference count associated with the memory managed data type given + by \var{mmt}. +\seealso{SLang_free_mmt, SLang_create_mmt, SLang_pop_mmt, SLang_pop_mmt} +\done + + +\function{SLang_vmessage} +\synopsis{Display a message to the message device} +\usage{void SLang_vmessage (char *fmt, ...)} +\description + This function prints a \var{printf} style formatted variable + argument list to the message device. The default message device is + \var{stdout}. +\seealso{SLang_verror} +\done + + +\function{SLang_exit_error} +\synopsis{Exit the program and display an error message} +\usage{void SLang_exit_error (char *fmt, ...)} +\description + The \var{SLang_exit_error} function terminates the program and + displays an error message using a \var{printf} type variable + argument list. The default behavior to this function is to write + the message to \var{stderr} and exit with the \var{exit} system + call. + + If the function pointer \var{SLang_Exit_Error_Hook} is + non-NULL, the function to which it points will be called. This + permits an application to perform whatever cleanup is necessary. + This hook has the prototype: +#v+ + void (*SLang_Exit_Error_Hook)(char *, va_list); +#v- +\seealso{SLang_verror, exit} +\done + + +\function{SLang_init_slang} +\synopsis{Initialize the interpreter} +\usage{int SLang_init_slang (void)} +\description + The \var{SLang_init_slang} function must be called by all + applications that use the \slang interpreter. It initializes the + interpreter, defines the built-in data types, and adds a set of core + intrinsic functions. + + The function returns \var{0} upon success, or \var{-1} upon failure. +\seealso{SLang_init_slfile, SLang_init_slmath, SLang_init_slunix} +\done + +\function{SLang_init_slfile} +\synopsis{Initialize the interpreter file I/O intrinsics} +\usage{int SLang_init_slfile (void)} +\description + This function initializes the interpreters file I/O intrinsic + functions. This function adds intrinsic functions such as + \var{fopen}, \var{fclose}, and \var{fputs} to the interpreter. + It returns \exmp{0} if successful, or \exmp{-1} upon error. +\notes + Before this function can be called, it is first necessary to call + \var{SLang_init_slang}. It also adds + the preprocessor symbol \var{__SLFILE__} to the interpreter. +\seealso{SLang_init_slang, SLang_init_slunix, SLang_init_slmath} +\done + + +\function{SLang_init_slmath} +\synopsis{Initialize the interpreter math intrinsics} +\usage{int SLang_init_slmath (void)} +\description + The \var{SLang_init_slmath} function initializes the interpreter's + mathematical intrinsic functions and makes them available to the + language. The intrinsic functions include \var{sin}, \var{cos}, + \var{tan}, etc... It returns \exmp{0} if successful, or \exmp{-1} + upon failure. +\notes + This function must be called after \var{SLang_init_slang}. It adds + the preprocessor symbol \var{__SLMATH__} to the interpreter. +\seealso{SLang_init_slang, SLang_init_slfile, SLang_init_slunix} +\done + + +\function{SLang_init_slunix} +\synopsis{Make available some unix system calls to the interpreter} +\usage{int SLang_init_slunix (void)} +\description + The \var{SLang_init_slunix} function initializes the interpreter's + unix system call intrinsic functions and makes them available to the + language. Examples of functions made available by + \var{SLang_init_slunix} include \var{chmod}, \var{chown}, and + \var{stat_file}. It returns \exmp{0} if successful, or \exmp{-1} + upon failure. +\notes + This function must be called after \var{SLang_init_slang}. It adds + the preprocessor symbol \var{__SLUNIX__} to the interpreter. +\seealso{SLang_init_slang, SLang_init_slfile, SLang_init_slmath} +\done + + +\function{SLadd_intrin_fun_table} +\synopsis{Add a table of intrinsic functions to the interpreter} +\usage{int SLadd_intrin_fun_table(SLang_Intrin_Fun_Type *tbl, char *pp_name);} +\description + The \var{SLadd_intrin_fun_table} function adds an array, or table, of + \var{SLang_Intrin_Fun_Type} objects to the interpreter. The first + parameter, \var{tbl} specifies the table to be added. The second + parameter \var{pp_name}, if non-NULL will be added to the list of + preprocessor symbols. + + This function returns \-1 upon failure or zero upon success. +\notes + A table should only be loaded one time and it is considered to be an + error on the part of the application if it loads a table more than + once. +\seealso{SLadd_intrin_var_table, SLadd_intrinsic_function, SLdefine_for_ifdef} +\done + +\function{SLadd_intrin_var_table} +\synopsis{Add a table of intrinsic variables to the interpreter} +\usage{int SLadd_intrin_var_table (SLang_Intrin_Var_Type *tbl, char *pp_name);} +\description + The \var{SLadd_intrin_var_table} function adds an array, or table, of + \var{SLang_Intrin_Var_Type} objects to the interpreter. The first + parameter, \var{tbl} specifies the table to be added. The second + parameter \var{pp_name}, if non-NULL will be added to the list of + preprocessor symbols. + + This function returns \-1 upon failure or zero upon success. +\notes + A table should only be loaded one time and it is considered to be an + error on the part of the application if it loads a table more than + once. +\seealso{SLadd_intrin_var_table, SLadd_intrinsic_function, SLdefine_for_ifdef} +\done + + +\function{SLang_load_file} +\synopsis{Load a file into the interpreter} +\usage{int SLang_load_file (char *fn)} +\description + The \var{SLang_load_file} function opens the file whose name is + specified by \var{fn} and feeds it to the interpreter, line by line, + for execution. If \var{fn} is \var{NULL}, the function will take + input from \var{stdin}. + + If no error occurs, it returns \exmp{0}; otherwise, + it returns \exmp{-1}, and sets \var{SLang_Error} accordingly. For + example, if it fails to open the file, it will return \exmp{-1} with + \var{SLang_Error} set to \var{SL_OBJ_NOPEN}. +\notes + If the hook \var{SLang_Load_File_Hook} declared as +#v+ + int (*SLang_Load_File_Hook)(char *); +#v- + is non-NULL, the function point to by it will be used to load the + file. For example, the \jed editor uses this hook to load files + via its own routines. +\seealso{SLang_load_object, SLang_load_string} +\done + + +\function{SLang_restart} +\synopsis{Reset the interpreter after an error} +\usage{void SLang_restart (int full)} +\description + The \var{SLang_restart} function should be called by the + application at top level if an error occurs. If the parameter + \var{full} is non-zero, any objects on the \slang run time stack + will be removed from the stack; otherwise, the stack will be left + intact. Any time the stack is believed to be trashed, this routine + should be called with a non-zero argument (e.g., if + \var{setjmp}/\var{longjmp} is called). + + Calling \var{SLang_restart} does not reset the global variable + \var{SLang_Error} to zero. It is up to the application to reset + that variable to zero after calling \var{SLang_restart}. +\example +#v+ + while (1) + { + if (SLang_Error) + { + SLang_restart (1); + SLang_Error = 0; + } + (void) SLang_load_file (NULL); + } +#v- +\seealso{SLang_init_slang, SLang_load_file} +\done + + +\function{SLang_byte_compile_file} +\synopsis{Byte-compile a file for faster loading} +\usage{int SLang_byte_compile_file(char *fn, int reserved)} +\description + The \var{SLang_byte_compile_file} function ``byte-compiles'' the + file \var{fn} for faster loading by the interpreter. This produces + a new file whose filename is equivalent to the one specified by + \var{fn}, except that a \var{'c'} is appended to the name. For + example, if \var{fn} is set to \exmp{init.sl}, then the new file + will have the name exmp{init.slc}. The meaning of the second + parameter, \var{reserved}, is reserved for future use. For now, set + it to \var{0}. + + The function returns zero upon success, or \exmp{-1} upon error and + sets SLang_Error accordingly. +\seealso{SLang_load_file, SLang_init_slang} +\done + + +\function{SLang_autoload} +\synopsis{Autoload a function from a file} +\usage{int SLang_autoload(char *funct, char *filename)} +\description + The \var{SLang_autoload} function may be used to associate a + \var{slang} function name \var{funct} with the file \var{filename} + such that if \var{funct} has not already been defined when needed, + it will be loaded from \var{filename}. + + \var{SLang_autoload} has no effect if \var{funct} has already been + defined. Otherwise it declares \var{funct} as a user-defined \slang + function. It returns \exmp{0} upon success, or \exmp{-1} upon error. +\seealso{SLang_load_file, SLang_is_defined} +\done + + +\function{SLang_load_string} +\synopsis{Interpret a string} +\usage{int SLang_load_string(char *str)} +\description + The \var{SLang_load_string} function feeds the string specified by + \var{str} to the interpreter for execution. It returns zero upon + success, or \exmp{-1} upon failure. +\seealso{SLang_load_file, SLang_load_object} +\done + + +\function{SLdo_pop} +\synopsis{Delete an object from the stack} +\usage{int SLdo_pop(void)} +\description + This function removes an object from the top of the interpeter's + run-time stack and frees any memory associated with it. It returns + zero upon success, or \var{-1} upon error (most likely due to a + stack-underflow). +\seealso{SLdo_pop_n, SLang_pop_integer, SLang_pop_string} +\done + +\function{SLdo_pop_n} +\synopsis{Delete n objects from the stack} +\usage{int SLdo_pop_n (unsigned int n)} +\description + The \var{SLdo_pop_n} function removes the top \var{n} objects from + the interpreter's run-time stack and frees all memory associated + with the objects. It returns zero upon success, or \var{-1} upon + error (most likely due to a stack-underflow). +\seealso{SLdo_pop, SLang_pop_integer, SLang_pop_string} +\done + + +\function{SLang_pop_integer} +\synopsis{Pop an integer off the stack} +\usage{int SLang_pop_integer (int *i)} +\description + The \var{SLang_pop_integer} function removes an integer from the + top of the interpreter's run-time stack and returns its value via + the pointer \var{i}. If successful, it returns zero. However, if + the top stack item is not of type \var{SLANG_INT_TYPE}, or the + stack is empty, the function will return \exmp{-1} and set + \var{SLang_Error} accordingly. +\seealso{SLang_push_integer, SLang_pop_double} +\done + + +\function{SLpop_string} +\synopsis{Pop a string from the stack} +\usage{int SLpop_string (char **strptr);} +\description + The \var{SLpop_string} function pops a string from the stack and + returns it as a malloced pointer. It is up to the calling routine + to free this string via a call to \var{free} or \var{SLfree}. If + successful, \var{SLpop_string} returns zero. However, if the top + stack item is not of type \var{SLANG_STRING_TYPE}, or the stack is + empty, the function will return \exmp{-1} and set + \var{SLang_Error} accordingly. +\example +#v+ + define print_string (void) + { + char *s; + if (-1 == SLpop_string (&s)) + return; + fputs (s, stdout); + SLfree (s); + } +#v- +\notes + This function should not be confused with \var{SLang_pop_slstring}, + which pops a \em{hashed} string from the stack. +\seealso{SLang_pop_slstring. SLfree} +\done + + +\function{SLang_pop_string} +\synopsis{Pop a string from the stack} +\usage{int SLang_pop_string(char **strptr, int *do_free)} +\description + The \var{SLpop_string} function pops a string from the stack and + returns it as a malloced pointer via \var{strptr}. After the + function returns, the integer pointed to by the second parameter + will be set to a non-zero value if \var{*strptr} should be freed via + \var{free} or \var{SLfree}. If successful, \var{SLpop_string} + returns zero. However, if the top stack item is not of type + \var{SLANG_STRING_TYPE}, or the stack is empty, the function will + return \exmp{-1} and set \var{SLang_Error} accordingly. +\notes + This function is considered obsolete and should not be used by + applications. If one requires a malloced string for modification, + \var{SLpop_string} should be used. If one requires a constant + string that will not be modifed by the application, + \var{SLang_pop_slstring} should be used. +\seealso{SLang_pop_slstring, SLpop_string} +\done + + +\function{SLang_pop_slstring} +\synopsis{Pop a hashed string from the stack} +\usage{int SLang_pop_slstring (char **s_ptr)} +\description + The \var{SLang_pop_slstring} function pops a hashed string from the + \slang run-time stack and returns it via \var{s_ptr}. It returns + zero if successful, or \-1 upon failure. The resulting string + should be freed via a call to \var{SLang_free_slstring} after use. +\example +#v+ + void print_string (void) + { + char *s; + if (-1 == SLang_pop_slstring (&s)) + return; + fprintf (stdout, "%s\n", s); + SLang_free_slstring (s); + } +#v- +\notes + \var{SLang_free_slstring} is the preferred function for popping + strings. This is a result of the fact that the interpreter uses + hashed strings as the native representation for string data. + + One must \em{never} free a hashed string using \var{free} or + \var{SLfree}. In addition, one must never make any attempt to + modify a hashed string and doing so will result in memory + corruption. +\seealso{SLang_free_slstring, SLpop_string} +\done + +\function{SLang_pop_double} +\synopsis{Pop a double from the stack} +\usage{int SLang_pop_double (double *dptr, int *iptr, int *conv)} +\description + The \var{SLang_pop_double} function pops a double precision number + from the stack and returns it via \var{dptr}. If the number was + derived from an integer, \var{*conv} will be set to \exmp{1} upon + return, otherwise, \var{*conv} will be set to \exmp{0}. This + function returns \0 upon success, otherwise it returns \-1 and sets + \var{SLang_Error} accordingly. +\notes + If one does not care whether or not \exmp{*dptr} was derived from + an integer, \var{iptr} and \var{conv} may be passed as \var{NULL} + pointers. +\seealso{SLang_pop_integer, SLang_push_double} +\done + + +\function{SLang_pop_complex} +\synopsis{Pop a complex number from the stack} +\usage{int SLang_pop_complex (double *re, double *im)} +\description + \var{SLang_pop_complex} pops a complex number from the stack and + returns it via the parameters \var{re} and \var{im} as the real and + imaginary parts of the complex number, respectively. This function + automatically converts objects of type \var{SLANG_DOUBLE_TYPE} and + \var{SLANG_INT_TYPE} to \var{SLANG_COMPLEX_TYPE}, if necessary. + It returns zero upon success, or \-1 upon error setting + \var{SLang_Error} accordingly. +\seealso{SLang_pop_integer, SLang_pop_double, SLang_push_complex} +\done + + +\function{SLang_push_complex} +\synopsis{Push a complex number onto the stack} +\usage{int SLang_push_complex (double re, double im)} +\description + \var{SLang_push_complex} may be used to push the complex number + whose real and imaginary parts are given by \var{re} and \var{im}, + respectively. It returns zero upon success, or \-1 upon error + setting \var{SLang_Error} accordingly. +\seealso{SLang_pop_complex, SLang_push_double} +\done + + +\function{SLang_push_double} +\synopsis{Push a double onto the stack} +\usage{int SLang_push_double(double d)} +\description + \var{SLang_push_double} may be used to push the double precision + floating point number \var{d} onto the interpreter's run-time + stack. It returns zero upon success, or \-1 upon error setting + \var{SLang_Error} accordingly. +\seealso{SLang_pop_double, SLang_push_integer} +\done + + +\function{SLang_push_string} +\synopsis{Push a string onto the stack} +\usage{int SLang_push_string (char *s)} +\description + \var{SLang_push_string} pushes a copy of the string specified by + \var{s} onto the interpreter's run-time stack. It returns zero + upon success, or \-1 upon error setting \var{SLang_Error} + accordingly. +\notes + If \var{s} is \var{NULL}, this function pushes \var{NULL} + (\var{SLANG_NULL_TYPE}) onto the stack. +\seealso{SLang_push_malloced_string} +\done + +\function{SLang_push_integer} +\synopsis{Push an integer onto the stack} +\usage{int SLang_push_integer (int i)} +\description + \var{SLang_push_integer} the integer \var{i} onto the interpreter's + run-time stack. It returns zero upon success, or \-1 upon error + setting \var{SLang_Error} accordingly. +\seealso{SLang_pop_integer, SLang_push_double, SLang_push_string} +\done + +\function{SLang_push_malloced_string} +\synopsis{Push a malloced string onto the stack} +\usage{int SLang_push_malloced_string (char *s);} +\description + \var{SLang_push_malloced_string} may be used to push a malloced + string onto the interpreter's run-time stack. It returns zero upon + success, or \-1 upon error setting \var{SLang_Error} accordingly. +\example + The following example illustrates that it is up to the calling + routine to free the string if \var{SLang_push_malloced_string} fails: +#v+ + int push_hello (void) + { + char *s = malloc (6); + if (s == NULL) return -1; + strcpy (s, "hello"); + if (-1 == SLang_push_malloced_string (s)) + { + free (s); + return -1; + } + return 0; + } +#v- +\example + The function \var{SLang_create_slstring} returns a hashed string. + Such a string may not be malloced and should not be passed to + \var{SLang_push_malloced_string}. +\notes + If \var{s} is \var{NULL}, this function pushes \var{NULL} + (\var{SLANG_NULL_TYPE}) onto the stack. +\seealso{SLang_push_string, SLmake_string} +\done + + +\function{SLang_is_defined} +\synopsis{Check to see if the interpreter defines an object} +\usage{int SLang_is_defined (char *nm)} +\description + The \var{SLang_is_defined} function may be used to determine + whether or not a variable or function whose name is given by + \var{em} has been defined. It returns zero if no such object has + been defined. Othewise it returns a non-zero value whose meaning + is given by the following table: +#v+ + 1 intrinsic function (SLANG_INTRINSIC) + 2 user-defined slang function (SLANG_FUNCTION) + -1 intrinsic variable (SLANG_IVARIABLE) + -2 user-defined global variable (SLANG_GVARIABLE) +#v- +\seealso{SLadd_intrinsic_function, SLang_run_hooks, SLang_execute_function} +\done + + +\function{SLang_run_hooks} +\synopsis{Run a user-defined hook with arguments} +\usage{int SLang_run_hooks (char *fname, unsigned int n, ...)} +\description + The \var{SLang_run_hooks} function may be used to execute a + user-defined function named \var{fname}. Before execution of the + function, the \var{n} string arguments specified by the variable + parameter list are pushed onto the stack. If the function + \var{fname} does not exist, \var{SLang_run_hooks} returns zero; + otherwise, it returns \exmp{1} upon successful execution of the + function, or \-1 if an error occurred. +\example + The \jed editor uses \var{SLang_run_hooks} to setup the mode of a + buffer based on the filename extension of the file associated with + the buffer: +#v+ + char *ext = get_filename_extension (filename); + if (ext == NULL) return -1; + if (-1 == SLang_run_hooks ("mode_hook", 1, ext)) + return -1; + return 0; +#v- +\seealso{SLang_is_defined, SLang_execute_function} +\done + + +\function{SLang_execute_function} +\synopsis{Execute a user or intrinsic function} +\usage{int SLang_execute_function (char *fname)} +\description + This function may be used to execute either a user-defined function + or an intrinisic function. The name of the function is specified + by \var{fname}. It returns zero if \var{fname} is not defined, or + \exmp{1} if the function was successfully executed, or \-1 upon + error. +\notes + The function \var{SLexecute_function} may be a better alternative + for some uses. +\seealso{SLang_run_hooks, SLexecute_function, SLang_is_defined} +\done + +\function{SLang_verror} +\synopsis{Signal an error with a message} +\usage{void SLang_verror (int code, char *fmt, ...);} +\description + The \var{SLang_verror} function sets \var{SLang_Error} to + \var{code} if \var{SLang_Error} is 0. It also displays the error + message implied by the \var{printf} variable argument list using + \var{fmt} as the format. +\example +#v+ + FILE *open_file (char *file) + { + char *file = "my_file.dat"; + if (NULL == (fp = fopen (file, "w"))) + SLang_verror (SL_INTRINSIC_ERROR, "Unable to open %s", file); + return fp; + } +#v- +\seealso{SLang_vmessage, SLang_exit_error} +\done + + +\function{SLang_doerror} +\synopsis{Signal an error} +\usage{void SLang_doerror (char *err_str)} +\description + The \var{SLang_doerror} function displays the string \var{err_str} + to the error device and signals a \slang error. +\notes + \var{SLang_doerror} is considered to obsolete. Applications should + use the \var{SLang_verror} function instead. +\seealso{SLang_verror, SLang_exit_error} +\done + + +\function{SLang_get_function} +\synopsis{Get a pointer to a \slang function} +\usage{SLang_Name_Type *SLang_get_function (char *fname)} +\description + This function returns a pointer to the internal \slang table entry + of a function whose name is given by \var{fname}. It returns + \var{NULL} upon failure. The value returned by this function can be + used \var{SLexecute_function} to call the function directly + from C. +\seealso{SLexecute_function} +\done + + + +\function{SLexecute_function} +\synopsis{Execute a \slang or intrinsic function} +\usage{int SLexecute_function (SLang_Name_Type *nt)} +\description + The \var{SLexecute_function} allows an application to call the + \slang function specified by the \var{SLang_Name_Type} pointer + \var{nt}. This parameter must be non \var{NULL} and must have been + previously obtained by a call to \var{SLang_get_function}. +\example + Consider the \slang function: +#v+ + define my_fun (x) + { + return x^2 - 2; + } +#v- + Suppose that it is desired to call this function many times with + different values of x. There are at least two ways to do this. + The easiest way is to use \var{SLang_execute_function} by passing + the string \exmp{"my_fun"}. A better way that is much faster is to + use \var{SLexecute_function}: +#v+ + int sum_a_function (char *fname, double *result) + { + double sum, x, y; + SLang_Name_Type *nt; + + if (NULL == (nt = SLang_get_function (fname))) + return -1; + + sum = 0; + for (x = 0; x < 10.0; x += 0.1) + { + SLang_start_arg_list (); + if (-1 == SLang_push_double (x)) + return -1; + SLang_end_arg_list (); + if (-1 == SLexecute_function (nt)) + return -1; + if (-1 == SLang_pop_double (&y, NULL, NULL)) + return -1; + + sum += y; + } + return sum; + } +#v- + Although not necessary in this case, \var{SLang_start_arg_list} and + \var{SLang_end_arg_list} were used to provide the function with + information about the number of parameters passed to it. +\seealso{SLang_get_function, SLang_start_arg_list, SLang_end_arg_list} +\done + + +\function{SLang_peek_at_stack} +\synopsis{Find the type of object on the top of the stack} +\usage{int SLang_peek_at_stack (void)} +\description + The \var{SLang_peek_at_stack} function is useful for determining the + data type of the object at the top of the stack. It returns the + data type, or -1 upon a stack-underflow error. It does not remove + anything from the stack. +\seealso{SLang_pop_string, SLang_pop_integer} +\done + + +\function{SLmake_string} +\synopsis{Duplicate a string} +\usage{char *SLmake_string (char *s)} +\description + The \var{SLmake_string} function creates a new copy of the string + \var{s}, via \var{malloc}, and returns it. Upon failure it returns + \var{NULL}. Since the resulting string is malloced, it should be + freed when nolonger needed via a call to either \var{free} or + \var{SLfree}. +\notes + \var{SLmake_string} should not be confused with the function + \var{SLang_create_slstring}, which performs a similar function. +\seealso{SLmake_nstring, SLfree, SLmalloc, SLang_create_slstring} +\done + + +\function{SLmake_nstring} +\synopsis{Duplicate a substring} +\usage{char *SLmake_nstring (char *s, unsigned int n)} +\description + This function is like \var{SLmake_nstring} except that it creates a + null terminated string formed from the first \var{n} characters of + \var{s}. Upon failure, it returns \var{NULL}, otherwise it returns + the new string. When nolonger needed, the returned string should be + freed with either \var{free} or \var{SLfree}. +\seealso{SLmake_nstring, SLfree, SLang_create_nslstring} +\done + + +\function{SLang_create_nslstring} +\synopsis{Created a hashed substring} +\usage{char *SLang_create_nslstring (char *s, unsigned int n)} +\description + \var{SLang_create_nslstring} is like \var{SLang_create_slstring} + except that only the first \var{n} characters of \var{s} are used to + perform the string. Upon error, it returns \var{NULL}, otherwise it + returns the hashed substring. Such a string must be freed by the + function \var{SLang_free_slstring}. +\notes + Do not use \var{free} or \var{SLfree} to free the string returned by + \var{SLang_create_slstring} or \var{SLang_create_nslstring}. Also + it is important that no attempt is made to modify the hashed string + returned by either of these functions. If one needs to modify a + string, the functions \var{SLmake_string} or \var{SLmake_nstring} + should be used instead. +\seealso{SLang_free_slstring, SLang_create_slstring, SLmake_nstring} +\done + +\function{SLang_create_slstring} +\synopsis{Create a hashed string} +\usage{char *SLang_create_slstring (char *s)} +\description + The \var{SLang_create_slstring} creates a copy of \var{s} and + returns it as a hashed string. Upon error, the function returns + \var{NULL}, otherwise it returns the hashed string. Such a string + must only be freed via the \var{SLang_free_slstring} function. +\notes + Do not use \var{free} or \var{SLfree} to free the string returned by + \var{SLang_create_slstring} or \var{SLang_create_nslstring}. Also + it is important that no attempt is made to modify the hashed string + returned by either of these functions. If one needs to modify a + string, the functions \var{SLmake_string} or \var{SLmake_nstring} + should be used instead. +\seealso{SLang_free_slstring, SLang_create_nslstring, SLmake_string} +\done + + +\function{SLang_free_slstring} +\synopsis{Free a hashed string} +\usage{void SLang_free_slstring (char *s)} +\description + The \var{SLang_free_slstring} function is used to free a hashed + string such as one returned by \var{SLang_create_slstring}, + \var{SLang_create_nslstring}, or \var{SLang_create_static_slstring}. + If \var{s} is \var{NULL}, the routine does nothing. +\seealso{SLang_create_slstring, SLang_create_nslstring, SLang_create_static_slstring} +\done + + +\function{SLang_concat_slstrings} +\synopsis{Concatenate two strings to produce a hashed string} +\usage{char *SLang_concat_slstrings (char *a, char *b)} +\description + The \var{SLang_concat_slstrings} function concatenates two strings, + \var{a} and \var{b}, and returns the result as a hashed string. + Upon failure, \var{NULL} is returned. +\notes + A hashed string can only be freed using \var{SLang_free_slstring}. + Never use either \var{free} or \var{SLfree} to free a hashed string, + otherwise memory corruption will result. +\seealso{SLang_free_slstring, SLang_create_slstring} +\done + +\function{SLang_create_static_slstring} +\synopsis{Create a hashed string} +\usage{char *SLang_create_static_slstring (char *s_literal)} +\description + The \var{SLang_create_static_slstring} creates a hashed string from + the string literal \var{s_literal} and returns the result. Upon + failure it returns \var{NULL}. +\example +#v+ + char *create_hello (void) + { + return SLang_create_static_slstring ("hello"); + } +#v- +\notes + This function should only be used with string literals. +\seealso{SLang_create_slstring, SLang_create_nslstring} +\done + + +\function{SLmalloc} +\synopsis{Allocate some memory} +\usage{char *SLmalloc (unsigned int nbytes)} +\description + This function uses \var{malloc} to allocate \var{nbytes} of memory. + Upon error it returns \var{NULL}; otherwise it returns a pointer to + the allocated memory. One should use \var{SLfree} to free the + memory after used. +\seealso{SLfree, SLrealloc, SLcalloc} +\done + + +\function{SLcalloc} +\synopsis{Allocate some memory} +\usage{char *SLcalloc (unsigned int num_elem, unsigned int elem_size)} +\description + This function uses \var{calloc} to allocate memory for + \var{num_elem} objects with each of size \var{elem_size} and returns + the result. In addition, the newly allocated memory is zeroed. + Upon error it returns \var{NULL}; otherwise it returns a pointer to + the allocated memory. One should use \var{SLfree} to free the + memory after used. +\seealso{SLmalloc, SLrealloc, SLfree} +\done + + +\function{SLfree} +\synopsis{Free some allocated memory} +\usage{void SLfree (char *ptr)} +\description + The \var{SLfree} function uses \var{free} to deallocate the memory + specified by \var{ptr}, which may be \var{NULL} in which case the + function does nothing. +\notes + Never use this function to free a hashed string returned by one of + the family of \var{slstring} functions, e.g., + \var{SLang_pop_slstring}. +\seealso{SLmalloc, SLcalloc, SLrealloc, SLmake_string} +\done + + +\function{SLrealloc} +\synopsis{Resize a dynamic memory block} +\usage{char *SLrealloc (char *ptr, unsigned int new_size)} +\description + The \var{SLrealloc} uses the \var{realloc} function to resize the + memory block specified by \var{ptr} to the new size \var{new_size}. + If \var{ptr} is \var{NULL}, the function call is equivalent to + \exmp{SLmalloc(new_size)}. Similarly, if \var{new_size} is zero, + the function call is equivalent to \var{SLfree(ptr)}. + + If the function fails, or if \var{new_size} is zero, \var{NULL} is + returned. Otherwise a pointer is returned to the (possibly moved) + new block of memory. +\seealso{SLfree, SLmalloc, SLcalloc} +\done + + +\function{SLcurrent_time_string} +\synopsis{Get the current time as a string} +\usage{char *SLcurrent_time_string (void)} +\description + The \var{SLcurrent_time_string} function uses the C library function + \var{ctime} to obtain a string representation of the + current date and time in the form +#v+ + "Wed Dec 10 12:50:28 1997" +#v- + However, unlike the \var{ctime} function, a newline character is not + present in the string. + + The returned value points to a statically allocated memory block + which may get overwritten on subsequent function calls. +\seealso{SLmake_string} +\done + + + +\function{SLatoi} +\synopsis{Convert a text string to an integer} +\usage{int SLatoi(unsigned char *str} +\description + \var{SLatoi} parses the string \var{str} to interpret it as an + integer value. Unlike \var{atoi}, \var{SLatoi} can also parse + strings containing integers expressed in + hexidecimal (e.g., \exmp{"0x7F"}) and octal (e.g., \exmp{"012"}.) + notation. +\seealso{SLang_guess_type} +\done + + +\function{SLang_pop_fileptr} +\synopsis{Pop a file pointer} +\usage{int SLang_pop_fileptr (SLang_MMT_Type **mmt, FILE **fp)} +\description + \var{SLang_pop_fileptr} pops a file pointer from the \slang + run-time stack. It returns zero upon success, or \-1 upon failure. + + A \slang file pointer (SLANG_FILEPTR_TYPE) is actually a memory + managed object. For this reason, \var{SLang_pop_fileptr} also + returns the memory managed object via the argument list. It is up + to the calling routine to call \var{SLang_free_mmt} to free the + object. +\example + The following example illustrates an application defined intrinsic + function that writes a user defined double precision number to a + file. Note the use of \var{SLang_free_mmt}: +#v+ + int write_double (void) + { + double t; + SLang_MMT_Type *mmt; + FILE *fp; + int status; + + if (-1 == SLang_pop_double (&d, NULL, NULL)) + return -1; + if (-1 == SLang_pop_fileptr (&mmt, &fp)) + return -1; + + status = fwrite (&d, sizeof (double), 1, fp); + SLang_free_mmt (mmt); + return status; + } +#v- + This function can be used by a \slang function as follows: +#v+ + define write_some_values () + { + variable fp, d; + + fp = fopen ("myfile.dat", "wb"); + if (fp == NULL) + error ("file failed to open"); + for (d = 0; d < 10.0; d += 0.1) + { + if (-1 == write_double (fp, d)) + error ("write failed"); + } + if (-1 == fclose (fp)) + error ("fclose failed"); + } +#v- +\seealso{SLang_free_mmt, SLang_pop_double} +\done + + +\function{SLadd_intrinsic_function} +\synopsis{Add a new intrinsic function to the interpreter} +\usage{int SLadd_intrinsic_function (name, f, type, nargs, ...)} +#v+ + char *name + FVOID_STAR f + unsigned char type + unsigned int nargs +#v- +\description + The \var{SLadd_intrinsic_function} function may be used to add a new + intrinsic function. The \slang name of the function is specified by + \var{name} and the actual function pointer is given by \var{f}, cast + to \var{FVOID_STAR}. The third parameter, \var{type} specifies the + return type of the function and must be one of the following values: +#v+ + SLANG_VOID_TYPE (returns nothing) + SLANG_INT_TYPE (returns int) + SLANG_DOUBLE_TYPE (returns double) + SLANG_STRING_TYPE (returns char *) +#v- + The \var{nargs} parameter specifies the number of parameters to pass + to the function. The variable argument list following \var{nargs} + must consists of \var{nargs} integers which specify the data type of + each argument. + + The function returns zero upon success or \-1 upon failure. +\example + The \jed editor uses this function to change the \var{system} + intrinsic function to the following: +#v+ + static int jed_system (char *cmd) + { + if (Jed_Secure_Mode) + { + msg_error ("Access denied."); + return -1; + } + return SLsystem (cmd); + } +#v- + After initializing the interpreter with \var{SLang_init_slang}, + \jed calls \var{SLadd_intrinsic_function} to substitute the above + definition for the default \slang definition: +#v+ + if (-1 == SLadd_intrinsic_function ("system", (FVOID_STAR)jed_system, + SLANG_INT_TYPE, 1, + SLANG_STRING_TYPE)) + return -1; +#v- +\seealso{SLadd_intrinsic_variable, SLadd_intrinsic_array} +\done + +\function{SLadd_intrinsic_variable} +\synopsis{Add an intrinsic variable to the interpreter} +\usage{int SLadd_intrinsic_variable (name, addr, type, rdonly)} +#v+ + char *name + VOID_STAR type + unsigned char type + int rdonly +#v- +\description + The \var{SLadd_intrinsic_variable} function adds an intrinsic + variable called \var{name} to the interpeter. The second parameter + \var{addr} specifies the address of the variable (cast to + \var{VOID_STAR}). The third parameter, \var{type}, specifies the + data type of the variable. If the fourth parameter, \var{rdonly}, + is non-zero, the variable will interpreted by the interpreter as + read-only. + + If successful, \var{SLadd_intrinsic_variable} returns zero, + otherwise it returns \-1. +\example + Suppose that \var{My_Global_Int} is a global variable (at least not + a local one): +#v+ + int My_Global_Int; +#v- + It can be added to the interpreter via the function call +#v+ + if (-1 == SLadd_intrinsic_variable ("MyGlobalInt", + (VOID_STAR)&My_Global_Int, + SLANG_INT_TYPE, 0)) + exit (1); +#v- +\notes + The current implementation requires all pointer type intrinsic + variables to be read-only. For example, +#v+ + char *My_Global_String; +#v- + is of type \var{SLANG_STRING_TYPE}, and must be declared as + read-only. Finally, not that +#v+ + char My_Global_Char_Buf[256]; +#v- + is \em{not} a \var{SLANG_STRING_TYPE} object. This difference is + very important because internally the interpreter dereferences the + address passed to it to get to the value of the variable. +\seealso{SLadd_intrinsic_function, SLadd_intrinsic_array} +\done +} + + +\function{SLclass_add_unary_op} +\synopsis{??} +\usage{int SLclass_add_unary_op (unsigned char,int (*) (int, unsigned char, VOID_STAR, unsigned int, VOID_STAR), int (*) (int, unsigned char, unsigned char *));} +\description +?? +\seealso{??} +\done + + +\function{SLclass_add_app_unary_op} +\synopsis{??} +\usage{int SLclass_add_app_unary_op (unsigned char, int (*) (int,unsigned char, VOID_STAR, unsigned int,VOID_STAR),int (*) (int, unsigned char, unsigned char *));} +\description +?? +\seealso{??} +\done + +\function{SLclass_add_binary_op} +\synopsis{??} +\usage{int SLclass_add_binary_op (unsigned char, unsigned char,int (*)(int, unsigned char, VOID_STAR, unsigned int,unsigned char, VOID_STAR, unsigned int,VOID_STAR),int (*) (int, unsigned char, unsigned char, unsigned char *));} +\description +?? +\seealso{??} +\done + +\function{SLclass_add_math_op} +\synopsis{??} +\usage{int SLclass_add_math_op (unsigned char,int (*)(int,unsigned char, VOID_STAR, unsigned int,VOID_STAR),int (*)(int, unsigned char, unsigned char *));} +\description +?? +\seealso{??} +\done + +\function{SLclass_add_typecast} +\synopsis{??} +\usage{int SLclass_add_typecast (unsigned char, unsigned char int (*)_PROTO((unsigned char, VOID_STAR, unsigned int,unsigned char, VOID_STAR)),int);} +\description +?? +\seealso{??} +\done + +\function{SLang_init_tty} +\synopsis{Initialize the terminal keyboard interface} +\usage{int SLang_init_tty (int intr_ch, int no_flow_ctrl, int opost)} +\description + \var{SLang_init_tty} initializes the terminal for single character + input. If the first parameter \var{intr_ch} is in the range 0-255, + it will be used as the interrupt character, e.g., under Unix this + character will generate a \var{SIGINT} signal. Otherwise, if it is + \exmp{-1}, the interrupt character will be left unchanged. + + If the second parameter \var{no_flow_ctrl} is non-zero, flow control + (\var{XON}/\var{XOFF}) processing will be + enabled. + + If the last parmeter \var{opost} is non-zero, output processing by the + terminal will be enabled. If one intends to use this function in + conjunction with the \slang screen management routines + (\var{SLsmg}), this paramete shold be set to zero. + + \var{SLang_init_tty} returns zero upon success, or \-1 upon error. +\notes + Terminal I/O is a complex subject. The \slang interface presents a + simplification that the author has found useful in practice. For + example, the only special character processing that + \var{SLang_init_tty} enables is that of the \var{SIGINT} character, + and the generation of other signals via the keyboard is disabled. + However, generation of the job control signal \var{SIGTSTP} is possible + via the \var{SLtty_set_suspend_state} function. + + Under Unix, the integer variable \var{SLang_TT_Read_FD} is used to + specify the input descriptor for the terminal. If + \var{SLang_TT_Read_FD} represents a terminal device as determined + via the \var{isatty} system call, then it will be used as the + terminal file descriptor. Otherwise, the terminal device + \exmp{/dev/tty} will used as the input device. The default value of + \var{SLang_TT_Read_FD} is \-1 which causes \exmp{/dev/tty} to be + used. So, if you prefer to use \var{stdin} for input, then set + \var{SLang_TT_Read_FD} to \exmp{fileno(stdin)} \em{before} calling + \var{SLang_init_tty}. + + If the variable \var{SLang_TT_Baud_Rate} is zero when this function + is called, the function will attempt to determine the baud rate by + querying the terminal driver and set \var{SLang_TT_Baud_Rate} to + that value. +\seealso{SLang_reset_tty, SLang_getkey, SLtty_set_suspend_state} +\done + + +\function{SLang_reset_tty} +\synopsis{Reset the terminal} +\usage{void SLang_reset_tty (void)} +\description + \var{SLang_reset_tty} resets the terminal interface back to the + state it was in before \var{SLang_init_tty} was called. +\seealso{SLang_init_tty} +\done + + +\function{SLtty_set_suspend_state} +\synopsis{Enable or disable keyboard suspension} +\usage{void SLtty_set_suspend_state (int s)} +\description + The \var{SLtty_set_suspend_state} function may be used to enable or + disable keyboard generation of the \var{SIGTSTP} job control signal. + If \var{s} is non-zero, generation of this signal via the terminal + interface will be enabled, otherwise it will be disabled. + + This function should only be called after the terminal driver has be + initialized via \var{SLang_init_tty}. The \var{SLang_init_tty} + always disables the generation of \var{SIGTSTP} via the keyboard. +\seealso{SLang_init_tty} +\done + +\function{SLang_getkey} +\synopsis{Read a character from the keyboard} +\usage{unsigned int SLang_getkey (void);} +\description + The \var{SLang_getkey} reads a single character from the terminal + and returns it. The terminal must first be initialized via a call + to \var{SLang_init_tty} before this function can be called. Upon + success, \var{SLang_getkey} returns the character read from the + terminal, otherwise it returns \var{SLANG_GETKEY_ERROR}. +\seealso{SLang_init_tty, SLang_input_pending, SLang_ungetkey} +\done + +\function{SLang_ungetkey_string} +\synopsis{Unget a key string} +\usage{int SLang_ungetkey_string (unsigned char *buf, unsigned int n)} +\description + The \var{SLang_ungetkey_string} function may be used to push the + \var{n} characters pointed to by \var{buf} onto the buffered input + stream that \var{SLgetkey} uses. If there is not enough room for + the characters, \-1 is returned and none are buffered. Otherwise, + it returns zero. +\notes + The difference between \var{SLang_buffer_keystring} and + \var{SLang_ungetkey_string} is that the \var{SLang_buffer_keystring} + appends the characters to the end of the getkey buffer, whereas + \var{SLang_ungetkey_string} inserts the characters at the beginning + of the input buffer. +\seealso{SLang_ungetkey, SLang_getkey} +\done + + +\function{SLang_buffer_keystring} +\synopsis{Append a keystring to the input buffer} +\usage{int SLang_buffer_keystring (unsigned char *b, unsigned int len)} +\description + \var{SLang_buffer_keystring} places the \var{len} characters + specified by \var{b} at the \em{end} of the buffer that + \var{SLang_getkey} uses. Upon success it returns 0; otherwise, no + characters are buffered and it returns \-1. +\notes + The difference between \var{SLang_buffer_keystring} and + \var{SLang_ungetkey_string} is that the \var{SLang_buffer_keystring} + appends the characters to the end of the getkey buffer, whereas + \var{SLang_ungetkey_string} inserts the characters at the beginning + of the input buffer. +\seealso{SLang_getkey, SLang_ungetkey, SLang_ungetkey_string} +\done + + +\function{SLang_ungetkey} +\synopsis{Push a character back onto the input buffer} +\usage{int SLang_ungetkey (unsigned char ch)} +\description + \var{SLang_ungetkey} pushes the character \var{ch} back onto the + \var{SLgetkey} input stream. Upon success, it returns zero, + otherwise it returns \1. +\example + This function is implemented as: +#v+ + int SLang_ungetkey (unsigned char ch) + { + return SLang_ungetkey_string(&ch, 1); + } +#v- +\seealso{SLang_getkey, SLang_ungetkey_string} +\done + + +\function{SLang_flush_input} +\synopsis{Discard all keyboard input waiting to be read} +\usage{void SLang_flush_input (void)} +\description + \var{SLang_flush_input} discards all input characters waiting to be + read by the \var{SLang_getkey} function. +\seealso{SLang_getkey} +\done + + +\function{SLang_input_pending} +\synopsis{Check to see if input is pending} +\usage{int SLang_input_pending (int tsecs)} +\description + \var{SLang_input_pending} may be used to see if an input character + is available to be read without causing \var{SLang_getkey} to block. + It will wait up to \var{tsecs} tenths of a second if no characters + are immediately available for reading. If \var{tsecs} is less than + zero, then \var{SLang_input_pending} will wait \exmp{-tsecs} + milliseconds for input, otherwise \var{tsecs} represents \var{1/10} + of a second intervals. +\notes + Not all systems support millisecond resolution. +\seealso{SLang_getkey} +\done + + +\function{SLang_set_abort_signal} +\synopsis{Set the signal to trap SIGINT} +\usage{void SLang_set_abort_signal (void (*f)(int));} +\description + \var{SLang_set_abort_signal} sets the function that gets + triggered when the user presses the interrupt key (\var{SIGINT}) to + the function \var{f}. If \var{f} is \var{NULL} the default handler + will get installed. +\example + The default interrupt handler on a Unix system is: +#v+ + static void default_sigint (int sig) + { + SLKeyBoard_Quit = 1; + if (SLang_Ignore_User_Abort == 0) SLang_Error = SL_USER_BREAK; + SLsignal_intr (SIGINT, default_sigint); + } +#v- +\notes + For Unix programmers, the name of this function may appear + misleading since it is associated with \var{SIGINT} and not + \var{SIGABRT}. The origin of the name stems from the original intent + of the function: to allow the user to abort the running of a \slang + interpreter function. +\seealso{SLang_init_tty, SLsignal_intr} +\done + + +\function{SLkm_define_key} +\synopsis{Define a key in a keymap} +\usage{int SLkm_define_key (char *seq, FVOID_STAR f, SLKeyMap_List_Type *km)} +\description + \var{SLkm_define_key} associates the key sequence \var{seq} with the + function pointer \var{f} in the keymap specified by \var{km}. Upon + success, it returns zero, otherwise it returns a negative integer + upon error. +\seealso{SLkm_define_keysym, SLang_define_key} +\done + + + +\function{SLang_define_key} +\synopsis{Define a key in a keymap} +\usage{int SLang_define_key(char *seq, char *fun, SLKeyMap_List_Type *km)} +\description + \var{SLang_define_key} associates the key sequence \var{seq} with + the function whose name is \var{fun} in the keymap specified by + \var{km}. +\seealso{SLkm_define_keysym, SLkm_define_key} +\done + + +\function{SLkm_define_keysym} +\synopsis{Define a keysym in a keymap} +\usage{int SLkm_define_keysym (seq, ks, km)} +#v+ + char *seq; + unsigned int ks; + SLKeyMap_List_Type *km; +#v- +\description + \var{SLkm_define_keysym} associates the key sequence \var{seq} with + the keysym \var{ks} in the keymap \var{km}. Keysyms whose value is + less than or equal to \exmp{0x1000} is reserved by the library and + should not be used. +\seealso{SLkm_define_key, SLang_define_key} +\done + +\function{SLang_undefine_key} +\synopsis{Undefined a key from a keymap} +\usage{void SLang_undefine_key(char *seq, SLKeyMap_List_Type *km);} +\description + \var{SLang_undefine_key} removes the key sequence \var{seq} from the + keymap \var{km}. +\seealso{SLang_define_key} +\done + +\function{SLang_create_keymap} +\synopsis{Create a new keymap} +\usage{SLKeyMap_List_Type *SLang_create_keymap (name, km)} +#v+ + char *name; + SLKeyMap_List_Type *km; +#v- +\description + \var{SLang_create_keymap} creates a new keymap called \var{name} by + copying the key definitions from the keymap \var{km}. If \var{km} + is \var{NULL}, the newly created keymap will be empty and it is up + to the calling routine to initialize it via the + \var{SLang_define_key} and \var{SLkm_define_keysym} functions. + \var{SLang_create_keymap} returns a pointer to the new keymap, or + \var{NULL} upon failure. +\seealso{SLang_define_key, SLkm_define_keysym} +\done + + +\function{SLang_do_key} +\synopsis{Read a keysequence and return its keymap entry} +\usage{SLang_Key_Type *SLang_do_key (kml, getkey)} +#v+ + SLKeyMap_List_Type *kml; + int (*getkey)(void); +#v- +\description + The \var{SLang_do_key} function reads characters using the function + specified by the \var{getkey} function pointer and uses the + key sequence to return the appropriate entry in the keymap specified + by \var{kml}. + + \var{SLang_do_key} returns \var{NULL} if the key sequence is not + defined by the keymap, otherwise it returns a pointer to an object + of type \var{SLang_Key_Type}, which is defined in \exmp{slang.h} as +#v+ + #define SLANG_MAX_KEYMAP_KEY_SEQ 14 + typedef struct SLang_Key_Type + { + struct SLang_Key_Type *next; + union + { + char *s; + FVOID_STAR f; + unsigned int keysym; + } + f; + unsigned char type; /* type of function */ + #define SLKEY_F_INTERPRET 0x01 + #define SLKEY_F_INTRINSIC 0x02 + #define SLKEY_F_KEYSYM 0x03 + unsigned char str[SLANG_MAX_KEYMAP_KEY_SEQ + 1];/* key sequence */ + } +SLang_Key_Type; + +#v- + The \var{type} field specifies which field of the union \var{f} + should be used. If \var{type} is \var{SLKEY_F_INTERPRET}, then + \var{f.s} is a string that should be passed to the interpreter for + evaluation. If \var{type} is \var{SLKEY_F_INTRINSIC}, then + \var{f.f} refers to function that should be called. Otherwise, + \var{type} is \var{SLKEY_F_KEYSYM} and \var{f.keysym} represents the + value of the keysym that is associated with the key sequence. +\seealso{SLkm_define_keysym, SLkm_define_key} +\done + + +\function{SLang_find_key_function} +\synopsis{Obtain a function pointer associated with a keymap} +\usage{FVOID_STAR SLang_find_key_function (fname, km);} +#v+ + char *fname; + SLKeyMap_List_Type *km; +#v- +\description + The \var{SLang_find_key_function} routine searches through the + \var{SLKeymap_Function_Type} list of functions associated with the + keymap \var{km} for the function with name \var{fname}. + If a matching function is found, a pointer to the function will + be returned, otherwise \var{SLang_find_key_function} will return + \var{NULL}. +\seealso{SLang_create_keymap, SLang_find_keymap} +\done + + +\function{SLang_find_keymap} +\synopsis{Find a keymap} +\usage{SLKeyMap_List_Type *SLang_find_keymap (char *keymap_name);} +\description + The \var{SLang_find_keymap} function searches through the list of + keymaps looking for one whose name is \var{keymap_name}. If a + matching keymap is found, the function returns a pointer to the + keymap. It returns \var{NULL} if no such keymap exists. +\seealso{SLang_create_keymap, SLang_find_key_function} +\done + +\function{SLang_process_keystring} +\synopsis{Un-escape a key-sequence} +\usage{char *SLang_process_keystring (char *kseq);} +\description + The \var{SLang_process_keystring} function converts an escaped key + sequence to its raw form by converting two-character combinations + such as \var{^A} to the \em{single} character \exmp{Ctrl-A} (ASCII + 1). In addition, if the key sequence contains constructs such as + \exmp{^(XX)}, where \exmp{XX} represents a two-character termcap + specifier, the termcap escape sequence will be looked up and + substituted. + + Upon success, \var{SLang_process_keystring} returns a raw + key-sequence whose first character represents the total length of + the key-sequence, including the length specifier itself. It returns + \var{NULL} upon failure. +\example + Consider the following examples: +#v+ + SLang_process_keystring ("^X^C"); + SLang_process_keystring ("^[[A"); +#v- + The first example will return a pointer to a buffer of three characters + whose ASCII values are given by \exmp{\{3,24,3\}}. Similarly, the + second example will return a pointer to the four characters + \exmp{\{4,27,91,65\}}. Finally, the result of +#v+ + SLang_process_keystring ("^[^(ku)"); +#v- + will depend upon the termcap/terminfo capability \exmp{"ku"}, which + represents the escape sequence associated with the terminal's UP + arrow key. For an ANSI terminal whose UP arrow produces + \exmp{"ESC [ A"}, the result will be \exmp{5,27,27,91,65}. +\notes + \var{SLang_process_keystring} returns a pointer to a static area + that will be overwritten on subsequent calls. +\seealso{SLang_define_key, SLang_make_keystring} +\done + +\function{SLang_make_keystring} +\synopsis{Make a printable key sequence} +\usage{char *SLang_make_keystring (unsigned char *ks);} +\description + The \var{SLang_make_keystring} function takes a raw key sequence + \var{ks} and converts it to a printable form by converting + characters such as ASCII 1 (ctrl-A) to \exmp{^A}. That is, it + performs the opposite function of \var{SLang_process_keystring}. +\notes + This function returns a pointer to a static area that will be + overwritten on the next call to \var{SLang_make_keystring}. +\seealso{SLang_process_keystring} +\done + + +\function{SLextract_list_element} +\synopsis{Extract a substring of a delimited string} +\usage{int SLextract_list_element (dlist, nth, delim, buf, buflen)} +#v+ + char *dlist; + unsigned int nth; + char delim; + char *buf; + unsigned int buflen; +#v- +\description + \var{SLextract_list_element} may be used to obtain the \var{nth} + element of a list of strings, \var{dlist}, that are delimited by the + character \var{delim}. The routine copies the \var{nth} element of + \var{dlist} to the buffer \var{buf} whose size is \var{buflen} + characters. It returns zero upon success, or \-1 if \var{dlist} + does not contain an \var{nth} element. +\example + A delimited list of strings may be turned into an array of strings + as follows. For conciseness, all malloc error checking has been + omitted. +#v+ + int list_to_array (char *list, char delim, char ***ap) + { + unsigned int nth; + char **a; + char buf[1024]; + + /* Determine the size of the array */ + nth = 0; + while (0 == SLextract_list_element (list, nth, delim, buf, sizeof(buf))) + nth++; + + ap = (char **) SLmalloc ((nth + 1) * sizeof (char **)); + nth = 0; + while (0 == SLextract_list_element (list, nth, delim, buf, sizeof(buf))) + { + a[nth] = SLmake_string (buf); + nth++; + } + a[nth] = NULL; + *ap = a; + return 0; + } +#v- +\seealso{SLmalloc, SLmake_string} +\done + + +#%+ +\function{SLprep_open_prep} +\synopsis{??} +\usage{int SLprep_open_prep (SLPreprocess_Type *);} +\description +?? +\seealso{??} +\done + + +\function{SLprep_close_prep} +\synopsis{??} +\usage{void SLprep_close_prep (SLPreprocess_Type *);} +\description +?? +\seealso{??} +\done + + +\function{SLprep_line_ok} +\synopsis{??} +\usage{int SLprep_line_ok (char *, SLPreprocess_Type *);} +\description +?? +\seealso{??} +\done + + +\function{SLdefine_for_ifdef} +\synopsis{??} +\usage{int SLdefine_for_ifdef (char *);} +\description +?? +\seealso{??} +\done + +\function{SLang_Read_Line_Type * SLang_rline_save_line (SLang_RLine_Info_Type *);} +\synopsis{??} +\usage{SLang_Read_Line_Type * SLang_rline_save_line (SLang_RLine_Info_Type *);} +\description +?? +\seealso{??} +\done + + +\function{int SLang_init_readline (SLang_RLine_Info_Type *);} +\synopsis{??} +\usage{int SLang_init_readline (SLang_RLine_Info_Type *);} +\description +?? +\seealso{??} +\done + + +\function{int SLang_read_line (SLang_RLine_Info_Type *);} +\synopsis{??} +\usage{int SLang_read_line (SLang_RLine_Info_Type *);} +\description +?? +\seealso{??} +\done + + +\function{int SLang_rline_insert (char *);} +\synopsis{??} +\usage{int SLang_rline_insert (char *);} +\description +?? +\seealso{??} +\done + + +\function{void SLrline_redraw (SLang_RLine_Info_Type *);} +\synopsis{??} +\usage{void SLrline_redraw (SLang_RLine_Info_Type *);} +\description +?? +\seealso{??} +\done + + +\function{int SLtt_flush_output (void);} +\synopsis{??} +\usage{int SLtt_flush_output (void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_set_scroll_region(int, int);} +\synopsis{??} +\usage{void SLtt_set_scroll_region(int, int);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_reset_scroll_region(void);} +\synopsis{??} +\usage{void SLtt_reset_scroll_region(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_reverse_video (int);} +\synopsis{??} +\usage{void SLtt_reverse_video (int);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_bold_video (void);} +\synopsis{??} +\usage{void SLtt_bold_video (void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_begin_insert(void);} +\synopsis{??} +\usage{void SLtt_begin_insert(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_end_insert(void);} +\synopsis{??} +\usage{void SLtt_end_insert(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_del_eol(void);} +\synopsis{??} +\usage{void SLtt_del_eol(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_goto_rc (int, int);} +\synopsis{??} +\usage{void SLtt_goto_rc (int, int);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_delete_nlines(int);} +\synopsis{??} +\usage{void SLtt_delete_nlines(int);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_delete_char(void);} +\synopsis{??} +\usage{void SLtt_delete_char(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_erase_line(void);} +\synopsis{??} +\usage{void SLtt_erase_line(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_normal_video(void);} +\synopsis{??} +\usage{void SLtt_normal_video(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_cls(void);} +\synopsis{??} +\usage{void SLtt_cls(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_beep(void);} +\synopsis{??} +\usage{void SLtt_beep(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_reverse_index(int);} +\synopsis{??} +\usage{void SLtt_reverse_index(int);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_smart_puts(unsigned short *, unsigned short *, int, int);} +\synopsis{??} +\usage{void SLtt_smart_puts(unsigned short *, unsigned short *, int, int);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_write_string (char *);} +\synopsis{??} +\usage{void SLtt_write_string (char *);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_putchar(char);} +\synopsis{??} +\usage{void SLtt_putchar(char);} +\description +?? +\seealso{??} +\done + + +\function{int SLtt_init_video (void);} +\synopsis{??} +\usage{int SLtt_init_video (void);} +\description +?? +\seealso{??} +\done + + +\function{int SLtt_reset_video (void);} +\synopsis{??} +\usage{int SLtt_reset_video (void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_get_terminfo(void);} +\synopsis{??} +\usage{void SLtt_get_terminfo(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_get_screen_size (void);} +\synopsis{??} +\usage{void SLtt_get_screen_size (void);} +\description +?? +\seealso{??} +\done + + +\function{int SLtt_set_cursor_visibility (int);} +\synopsis{??} +\usage{int SLtt_set_cursor_visibility (int);} +\description +?? +\seealso{??} +\done + + + +\function{int SLtt_initialize (char *);} +\synopsis{??} +\usage{int SLtt_initialize (char *);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_enable_cursor_keys(void);} +\synopsis{??} +\usage{void SLtt_enable_cursor_keys(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_set_term_vtxxx(int *);} +\synopsis{??} +\usage{void SLtt_set_term_vtxxx(int *);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_set_color_esc (int, char *);} +\synopsis{??} +\usage{void SLtt_set_color_esc (int, char *);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_wide_width(void);} +\synopsis{??} +\usage{void SLtt_wide_width(void);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_narrow_width(void);} +\synopsis{??} +\usage{void SLtt_narrow_width(void);} +\description +?? +\seealso{??} +\done + + +\function{int SLtt_set_mouse_mode (int, int);} +\synopsis{??} +\usage{int SLtt_set_mouse_mode (int, int);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_set_alt_char_set (int);} +\synopsis{??} +\usage{void SLtt_set_alt_char_set (int);} +\description +?? +\seealso{??} +\done + + +\function{int SLtt_write_to_status_line (char *, int);} +\synopsis{??} +\usage{int SLtt_write_to_status_line (char *, int);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_disable_status_line (void);} +\synopsis{??} +\usage{void SLtt_disable_status_line (void);} +\description +?? +\seealso{??} +\done + + +\function{char *SLtt_tgetstr (char *);} +\synopsis{??} +\usage{char *SLtt_tgetstr (char *);} +\description +?? +\seealso{??} +\done + + +\function{int SLtt_tgetnum (char *);} +\synopsis{??} +\usage{int SLtt_tgetnum (char *);} +\description +?? +\seealso{??} +\done + + +\function{int SLtt_tgetflag (char *);} +\synopsis{??} +\usage{int SLtt_tgetflag (char *);} +\description +?? +\seealso{??} +\done + + +\function{char *SLtt_tigetent (char *);} +\synopsis{??} +\usage{char *SLtt_tigetent (char *);} +\description +?? +\seealso{??} +\done + + +\function{char *SLtt_tigetstr (char *, char **);} +\synopsis{??} +\usage{char *SLtt_tigetstr (char *, char **);} +\description +?? +\seealso{??} +\done + + +\function{int SLtt_tigetnum (char *, char **);} +\synopsis{??} +\usage{int SLtt_tigetnum (char *, char **);} +\description +?? +\seealso{??} +\done + + +\function{SLtt_Char_Type SLtt_get_color_object (int);} +\synopsis{??} +\usage{SLtt_Char_Type SLtt_get_color_object (int);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_set_color_object (int, SLtt_Char_Type);} +\synopsis{??} +\usage{void SLtt_set_color_object (int, SLtt_Char_Type);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_set_color (int, char *, char *, char *);} +\synopsis{??} +\usage{void SLtt_set_color (int, char *, char *, char *);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_set_mono (int, char *, SLtt_Char_Type);} +\synopsis{??} +\usage{void SLtt_set_mono (int, char *, SLtt_Char_Type);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_add_color_attribute (int, SLtt_Char_Type);} +\synopsis{??} +\usage{void SLtt_add_color_attribute (int, SLtt_Char_Type);} +\description +?? +\seealso{??} +\done + + +\function{void SLtt_set_color_fgbg (int, SLtt_Char_Type, SLtt_Char_Type);} +\synopsis{??} +\usage{void SLtt_set_color_fgbg (int, SLtt_Char_Type, SLtt_Char_Type);} +\description +?? +\seealso{??} +\done + + + +\function{int SLkp_define_keysym (char *, unsigned int);} +\synopsis{??} +\usage{int SLkp_define_keysym (char *, unsigned int);} +\description +?? +\seealso{??} +\done + + + +\function{int SLkp_init (void);} +\synopsis{??} +\usage{int SLkp_init (void);} +\description +?? +\seealso{??} +\done + + +\function{int SLkp_getkey (void);} +\synopsis{??} +\usage{int SLkp_getkey (void);} +\description +?? +\seealso{??} +\done + + + +\function{int SLscroll_find_top (SLscroll_Window_Type *);} +\synopsis{??} +\usage{int SLscroll_find_top (SLscroll_Window_Type *);} +\description +?? +\seealso{??} +\done + + +\function{int SLscroll_find_line_num (SLscroll_Window_Type *);} +\synopsis{??} +\usage{int SLscroll_find_line_num (SLscroll_Window_Type *);} +\description +?? +\seealso{??} +\done + + +\function{unsigned int SLscroll_next_n (SLscroll_Window_Type *, unsigned int);} +\synopsis{??} +\usage{unsigned int SLscroll_next_n (SLscroll_Window_Type *, unsigned int);} +\description +?? +\seealso{??} +\done + + +\function{unsigned int SLscroll_prev_n (SLscroll_Window_Type *, unsigned int);} +\synopsis{??} +\usage{unsigned int SLscroll_prev_n (SLscroll_Window_Type *, unsigned int);} +\description +?? +\seealso{??} +\done + + +\function{int SLscroll_pageup (SLscroll_Window_Type *);} +\synopsis{??} +\usage{int SLscroll_pageup (SLscroll_Window_Type *);} +\description +?? +\seealso{??} +\done + + +\function{int SLscroll_pagedown (SLscroll_Window_Type *);} +\synopsis{??} +\usage{int SLscroll_pagedown (SLscroll_Window_Type *);} +\description +?? +\seealso{??} +\done + + + +\function{SLSig_Fun_Type *SLsignal (int, SLSig_Fun_Type *);} +\synopsis{??} +\usage{SLSig_Fun_Type *SLsignal (int, SLSig_Fun_Type *);} +\description +?? +\seealso{??} +\done + + +\function{SLSig_Fun_Type *SLsignal_intr (int, SLSig_Fun_Type *);} +\synopsis{??} +\usage{SLSig_Fun_Type *SLsignal_intr (int, SLSig_Fun_Type *);} +\description +?? +\seealso{??} +\done + + +\function{int SLsig_block_signals (void);} +\synopsis{??} +\usage{int SLsig_block_signals (void);} +\description +?? +\seealso{??} +\done + + +\function{int SLsig_unblock_signals (void);} +\synopsis{??} +\usage{int SLsig_unblock_signals (void);} +\description +?? +\seealso{??} +\done + + +\function{int SLsystem (char *);} +\synopsis{??} +\usage{int SLsystem (char *);} +\description +?? +\seealso{??} +\done + + +\function{void SLadd_at_handler (long *, char *);} +\synopsis{??} +\usage{void SLadd_at_handler (long *, char *);} +\description +?? +\seealso{??} +\done + + + +\function{void SLang_define_case(int *, int *);} +\synopsis{??} +\usage{void SLang_define_case(int *, int *);} +\description +?? +\seealso{??} +\done + + +\function{void SLang_init_case_tables (void);} +\synopsis{??} +\usage{void SLang_init_case_tables (void);} +\description +?? +\seealso{??} +\done + + + +\function{unsigned char *SLang_regexp_match(unsigned char *, unsigned int, SLRegexp_Type *);} +\synopsis{??} +\usage{unsigned char *SLang_regexp_match(unsigned char *, unsigned int, SLRegexp_Type *);} +\description +?? +\seealso{??} +\done + + + +\function{int SLang_regexp_compile (SLRegexp_Type *);} +\synopsis{??} +\usage{int SLang_regexp_compile (SLRegexp_Type *);} +\description +?? +\seealso{??} +\done + + +\function{char *SLregexp_quote_string (char *, char *, unsigned int);} +\synopsis{??} +\usage{char *SLregexp_quote_string (char *, char *, unsigned int);} +\description +?? +\seealso{??} +\done + + +\function{int SLcmd_execute_string (char *, SLcmd_Cmd_Table_Type *);} +\synopsis{??} +\usage{int SLcmd_execute_string (char *, SLcmd_Cmd_Table_Type *);} +\description +?? +\seealso{??} +\done + + + +\function{int SLsearch_init (char *, int, int, SLsearch_Type *);} +\synopsis{??} +\usage{int SLsearch_init (char *, int, int, SLsearch_Type *);} +\description +?? +/* This routine must first be called before any search can take place. + * The second parameter specifies the direction of the search: greater than + * zero for a forwrd search and less than zero for a backward search. The + * third parameter specifies whether the search is case sensitive or not. + * The last parameter is a pointer to a structure that is filled by this + * function and it is this structure that must be passed to SLsearch. + */ +\seealso{??} +\done + + +\function{unsigned char *SLsearch (unsigned char *, unsigned char *, SLsearch_Type *);} +\synopsis{??} +\usage{unsigned char *SLsearch (unsigned char *, unsigned char *, SLsearch_Type *);} +\description +?? +/* To use this routine, you must first call 'SLsearch_init'. Then the first + * two parameters p1 and p2 serve to define the region over which the search + * is to take place. The third parameter is the structure that was previously + * initialized by SLsearch_init. + * + * The routine returns a pointer to the match if found otherwise it returns + * NULL. + */ +\seealso{??} +\done + + +\function{SLcomplex_abs} +\synopsis{Returns the norm of a complex number} +\usage{double SLcomplex_abs (double *z)}} +\description + The \var{SLcomplex_abs} function returns the absolute value or the + norm of the complex number given by \var{z}. +\seealso{SLcomplex_times} +\done + + +\function{double *SLcomplex_times (double *, double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_times (double *, double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_divide (double *, double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_divide (double *, double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_sin (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_sin (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_cos (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_cos (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_tan (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_tan (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_asin (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_asin (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_acos (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_acos (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_atan (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_atan (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_exp (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_exp (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_log (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_log (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_log10 (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_log10 (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_sqrt (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_sqrt (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_sinh (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_sinh (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_cosh (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_cosh (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_tanh (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_tanh (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_pow (double *, double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_pow (double *, double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double SLmath_hypot (double x, double y);} +\synopsis{??} +\usage{double SLmath_hypot (double x, double y);} +\description +?? +\seealso{??} +\done + + + +extern double *SLcomplex_asinh (double *, double *); +\function{double *SLcomplex_acosh (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_acosh (double *, double *);} +\description +?? +\seealso{??} +\done + + +\function{double *SLcomplex_atanh (double *, double *);} +\synopsis{??} +\usage{double *SLcomplex_atanh (double *, double *);} +\description +?? +\seealso{??} +\done + + + + +\function{char *SLdebug_malloc (unsigned long);} +\synopsis{??} +\usage{char *SLdebug_malloc (unsigned long);} +\description +?? +\seealso{??} +\done + + +\function{char *SLdebug_calloc (unsigned long, unsigned long);} +\synopsis{??} +\usage{char *SLdebug_calloc (unsigned long, unsigned long);} +\description +?? +\seealso{??} +\done + + +\function{char *SLdebug_realloc (char *, unsigned long);} +\synopsis{??} +\usage{char *SLdebug_realloc (char *, unsigned long);} +\description +?? +\seealso{??} +\done + + +\function{void SLdebug_free (char *);} +\synopsis{??} +\usage{void SLdebug_free (char *);} +\description +?? +\seealso{??} +\done + + +\function{void SLmalloc_dump_statistics (void);} +\synopsis{??} +\usage{void SLmalloc_dump_statistics (void);} +\description +?? +\seealso{??} +\done + + +\function{char *SLstrcpy(register char *, register char *);} +\synopsis{??} +\usage{char *SLstrcpy(register char *, register char *);} +\description +?? +\seealso{??} +\done + + +\function{int SLstrcmp(register char *, register char *);} +\synopsis{??} +\usage{int SLstrcmp(register char *, register char *);} +\description +?? +\seealso{??} +\done + + +\function{char *SLstrncpy(char *, register char *, register int);} +\synopsis{??} +\usage{char *SLstrncpy(char *, register char *, register int);} +\description +?? +\seealso{??} +\done + + + +\function{void SLmemset (char *, char, int);} +\synopsis{??} +\usage{void SLmemset (char *, char, int);} +\description +?? +\seealso{??} +\done + + +extern int SLang_add_intrinsic_array (char *, /* name */ + unsigned char, /* type */ + int, /* readonly */ + VOID_STAR, /* data */ + unsigned int, ...); /* num dims */ + + + +\function{void SLexpand_escaped_string (register char *, register char *, register char *);} +\synopsis{??} +\usage{void SLexpand_escaped_string (register char *, register char *, register char *);} +\description +?? +\seealso{??} +\done + + + +\function{void SLmake_lut (unsigned char *, unsigned char *, unsigned char);} +\synopsis{??} +\usage{void SLmake_lut (unsigned char *, unsigned char *, unsigned char);} +\description +?? +\seealso{??} +\done + + + +\function{int SLang_guess_type (char *);} +\synopsis{??} +\usage{int SLang_guess_type (char *);} +\description +?? +\seealso{??} +\done + +#%- + +\end{\documentstyle} diff --git a/libslang/doc/tm/cslang.tm b/libslang/doc/tm/cslang.tm new file mode 100644 index 0000000..acc82c6 --- /dev/null +++ b/libslang/doc/tm/cslang.tm @@ -0,0 +1,2033 @@ +#c -*- mode: tm; mode: fold -*- + +#c text-macro definitions #%{{{ +#i linuxdoc.tm + +#d slang \bf{S-Lang} +#d slrn \bf{slrn} +#d jed \bf{jed} +#d key#1 $1 +#d footnote#1 $1 +#d grp#1 $1 +#d file#1 $1 +#d -1 -1 +#d 0 0 +#d 1 1 + +#d kw#1 \tt{$1} +#d exmp#1 \tt{$1} +#d var#1 \tt{$1} + +#d cfun#1 \tt{$1} +#d ivar#1 \tt{$1} +#d ifun#1 \tt{$1} +#d exfile#1 \tt{$1} +#d exns#1 \tt{$1} +#d exstr#1 \tt{"$1"} + +#d ldots ... +#d times * +#d sc#1 \tt{$1} +#d verb#1 \tt{$1} +#d sldxe \bf{sldxe} +#d url#1 +#d slang-library-reference \bf{The \slang Library Reference} +#d chapter#1 $1

+#d tag#1 $1 +#d appendix + +#d kbd#1 $1 + +#d documentstyle book + +#%}}} + +\linuxdoc + +\begin{\documentstyle} + +\title S-Lang Library C Programmer's Guide, V1.4.9 +\author John E. Davis, \tt{davis@space.mit.edu} +\date \__today__ + +\toc + +#i preface.tm + +\chapter{Introduction} #%{{{ + + \slang is a C programmer's library that includes routines for the rapid + development of sophisticated, user friendly, multi-platform applications. + The \slang library includes the following: + +\begin{itemize} +\item Low level tty input routines for reading single characters at a time. +\item Keymap routines for defining keys and manipulating multiple keymaps. +\item A high-level keyprocessing interface (\verb{SLkp}) for + handling function and arrow keys. +\item High level screen management routines for manipulating both + monochrome and color terminals. These routines are \em{very} + efficient. (\tt{SLsmg}) +\item Low level terminal-independent routines for manipulating the display + of a terminal. (\tt{SLtt}) +\item Routines for reading single line input with line editing and recall + capabilities. (\tt{SLrline}) +\item Searching functions: both ordinary searches and regular expression + searches. (\tt{SLsearch}) +\item An embedded stack-based language interpreter with a C-like syntax. +\end{itemize} + + The library is currently available for OS/2, MSDOS, Unix, and VMS + systems. For the most part, the interface to library routines has + been implemented in such a way that it appears to be platform + independent from the point of view of the application. In addition, + care has been taken to ensure that the routines are ``independent'' + of one another as much as possible. For example, although the + keymap routines require keyboard input, they are not tied to + \slang's keyboard input routines--- one can use a different keyboard + \verb{getkey} routine if one desires. This also means that linking + to only part of the \slang library does not pull the whole library + into the application. Thus, \slang applications tend to be + relatively small in comparison to programs that use libraries with + similar capabilities. + +#%}}} + +\chapter{Interpreter Interface} #%{{{ + + The \slang library provides an interpreter that when embedded into + an application, makes the application extensible. Examples of + programs that embed the interpreter include the \jed editor and the + \slrn newsreader. + + Embedding the interpreter is easy. The hard part is to decide what + application specific built-in or intrinsic functions should be + provided by the application. The \slang library provides some + pre-defined intrinsic functions, such as string processing + functions, and simple file input-output routines. However, the + basic philosophy behind the interpreter is that it is not a + standalone program and it derives much of its power from the + application that embeds it. + +\sect{Embedding the Interpreter} #%{{{ + + Only one function needs to be called to embed the \slang interpreter + into an application: \cfun{SLang_init_slang}. This function + initializes the interpreter's data structures and adds some intrinsic + functions: +#v+ + if (-1 == SLang_init_slang ()) + exit (EXIT_FAILURE); +#v- + This function does not provide file input output intrinsic nor does + it provide mathematical functions. To make these as well as some + posix system calls available use +#v+ + if ((-1 == SLang_init_slang ()) /* basic interpreter functions */ + || (-1 == SLang_init_slmath ()) /* sin, cos, etc... */ + || (-1 == SLang_init_stdio ()) /* stdio file I/O */ + || (-1 == SLang_init_posix_dir ()) /* mkdir, stat, etc. */ + || (-1 == SLang_init_posix_process ()) /* getpid, umask, etc. */ + ) + exit (EXIT_FAILURE); +#v- + If you intend to enable all intrinsic functions, then it is simpler + to initialize the interpreter via +#v+ + if (-1 == SLang_init_all ()) + exit (EXIT_FAILURE); +#v- + See the \slang-run-time-library for more information about the + intrinsic functions. + + +#%}}} + +\sect{Calling the Interpreter} #%{{{ + + There are several ways of calling the interpreter. The two most common + method is to load a file containing \slang code, or to load a + string. + +\sect1{Loading Files} + The \cfun{SLang_load_file} and \cfun{SLns_load_file} functions may + be used to interpret a file. Both these functions return zero if + successful, or \-1 upon failure. If either of these functions fail, + the interpreter will accept no more code unless the error state is + cleared. This is done by calling \cfun{SLang_restart} function to + set the interpreter to its default state, \em{and} setting + \ivar{SLang_Error} to 0, e.g., +#v+ + if (-1 == SLang_load_file ("site.sl")) + { + /* Clear the error and rest the interpreter */ + SLang_restart (1); + SLang_Error = 0; + } +#v- + + When a file is loaded via \cfun{SLang_load_file}, any non-public + variables and functions defined in the file will be placed into a + namespace that is local to the file itself. The + \cfun{SLns_load_file} function may be used to load a file using a + specified namespace, e.g., +#v+ + if (-1 == SLns_load_file ("site.sl", "NS")) + { + SLang_restart (1); + SLang_Error = 0; + } +#v- + will load \exfile{site.sl} into a namespace called \exns{NS}. If such a + namespace does not exist, then it will be created. + + Both the \cfun{SLang_load_file} and \cfun{SLns_load_file} functions + search for files along an application-specified search path. This + path may be set using the \cfun{SLpath_set_load_path} function, as + well as from interpeted code via the \ifun{set_slang_load_path} + function. By default, no search path is defined. + + Files are searched as follows: If the name begins with the + equivalent of \exstr{./} or \exstr{../}, then it is searched for + with respect to the current directory, and not along the load-path. + If no such file exists, then an error will be generated. Otherwise, + the file is searched for in each of the directories of the load-path + by concatenating the path element with the specified file name. The + first such file found to exist by this process will be loaded. If a + matching file still has not been found, and the file name lacks an + extension, then the path is searched with \exstr{.sl} and + \exstr{.slc} appended to the filename. If two such files are found + (one ending with \exstr{.sl} and the other with \exstr{.slc}), then + the more recent of the two will be used. If no matching file has + been found by this process, then the search will cease and an error + generated. + + The search path is a delimiter separated list of directories that + specify where the interpreter looks for files. By default, the + value of the delimiter is OS-dependent following the convention of + the underlying OS. For example, on Unix the delimiter is + represented by a colon, on DOS/Windows it is a semi-colon, and on + VMS it is a space. The \cfun{SLpath_set_delimiter} and + \cfun{SLpath_get_delimiter} may be used to set and query the + delimiter's value, respectively. + +\sect1{Loading Strings} + There are several other mechanisms for interacting with the + interpreter. For example, the \cfun{SLang_load_string} function + loads a string into the interpreter and interprets it: +#v+ + if (-1 == SLang_load_string ("message (\"hello\");")) + { + SLang_restart (1); + SLang_Error = 0; + } +#v- + Similarly, the \cfun{SLns_load_string} function may be used to load + a string into a specified namespace. + + Typically, an interactive application will load a file via + \cfun{SLang_load_file} and then go into a loop that consists of + reading lines of input and sending them to the interpreter, e.g., +#v+ + while (EOF != fgets (buf, sizeof (buf), stdin)) + { + if (-1 == SLang_load_string (buf)) + SLang_restart (1); + SLang_Error = 0; + } +#v- + + Finally, some applications such as \jed and \slrn use another method of + interacting with the interpreter. They read key sequences from the + keyboard and map those key sequences to interpreter functions via + the \slang keymap interface. + +#%}}} + +\sect{Intrinsic Functions} #%{{{ + + An intrinsic function is simply a function that is written in C and + is made available to the interpreter as a built-in function. For + this reason, the words `intrinsic' and `built-in' are often used + interchangeably. + + Applications are expected to add application specific functions to + the interpreter. For example, \jed adds nearly 300 editor-specific + intrinsic functions. The application designer should think + carefully about what intrinsic functions to add to the interpreter. + +\sect1{Restrictions on Intrinsic Functions} #%{{{ + + When implementing intrinsic functions, it is necessary to follow a + few rules to cooperate with the interpreter. + + The C version of an intrinsic function takes only pointer arguments. + This is because when the interpreter calls an intrinsic function, it + passes values to the function by reference and \em{not} by value. For + example, intrinsic with the declarations: +#v+ + int intrinsic_0 (void); + int intrinsic_1 (char *s); + void intrinsic_2 (char *s, int *i); + void intrinsic_3 (int *i, double *d, double *e); +#v- + are all valid. However, +#v+ + int invalid_1 (char *s, int len); +#v- + is not valid since the \var{len} parameter is not a pointer. + + The return value of an intrinsic function must be one of the + following types: \var{void}, \var{char}, \var{short}, \var{int}, + \var{long}, \var{double}, \var{char *}, as well as unsigned versions + of the integer types. A function such as +#v+ + int *invalid (void); +#v- + is not permitted since \var{int*} is not a valid return-type for an + intrinsic function. Any other type of value can be passed back to + the interpreter by explicitly pushing the object onto the + interpreter's stack via the appropriate "push" function. + + The current implementation limits the number of arguments of an + intrinsic function to \exmp{7}. The "pop" functions can be used to + allow the function to take an arbitrary number as seen from an + interpreter script. + + Another restriction is that the intrinsic function should regard all its + parameters as pointers to constant objects and make no attempt to + modify the value to which they point. For example, +#v+ + void truncate (char *s) + { + s[0] = 0; + } +#v- + is illegal since the function modifies the string \var{s}. + + +#%}}} + +\sect1{Adding a New Intrinsic} #%{{{ + + There are two basic mechanisms for adding an intrinsic function to the + interpreter: \cfun{SLadd_intrinsic_function} and + \cfun{SLadd_intrin_fun_table}. Functions may be added to a specified + namespace via \cfun{SLns_add_intrinsic_function} and + \cfun{SLns_add_intrin_fun_table} functions. + + As an specific example, consider a function that will cause the + program to exit via the \var{exit} C library function. It is not + possible to make this function an intrinsic because it does not meet + the specifications for an intrinsic function that were described + earlier. However, one can call \var{exit} from a function that is + suitable, e.g., +#v+ + void intrin_exit (int *code) + { + exit (*code); + } +#v- + This function may be made available to the interpreter as an + intrinsic via the \cfun{SLadd_intrinsic_function} routine: +#v+ + if (-1 == SLadd_intrinsic_function ("exit", (FVOID_STAR) intrin_exit, + SLANG_VOID_TYPE, 1, + SLANG_INT_TYPE)) + exit (EXIT_FAILURE); +#v- + This statement basically tells the interpreter that + \var{intrin_exit} is a function that returns nothing and takes a + single argument: a pointer to an integer (\var{SLANG_INT_TYPE}). + A user can call this function from within the interpreter + via +#v+ + message ("Calling the exit function"); + exit (0); +#v- + After printing a message, this will cause the \var{intrin_exit} + function to execute, which in turn calls \var{exit}. + + The most convenient mechanism for adding new intrinsic functions is + to create a table of \cfun{SLang_Intrin_Fun_Type} objects and add the + table via the \cfun{SLadd_intrin_fun_table} function. The table will + look like: +#v+ + SLang_Intrin_Fun_Type My_Intrinsics [] = + { + /* table entries */ + MAKE_INTRINSIC_N(...), + MAKE_INTRINSIC_N(...), + . + . + MAKE_INTRINSIC_N(...), + SLANG_END_INTRIN_FUN_TABLE + }; +#v- + Construction of the table entries may be facilitated using a set of + \var{MAKE_INTRINSIC} macros defined in \var{slang.h}. The main + macro is called \var{MAKE_INTRINSIC_N} and takes 11 arguments: +#v+ + MAKE_INTRINSIC_N(name, funct-ptr, return-type, num-args, + arg-1-type, arg-2-type, ... arg-7-type) +#v- + Here \var{name} is the name of the intrinsic function that the + interpreter is to give to the function. \var{func-ptr} is a pointer + to the intrinsic function taking \var{num-args} and returning + \var{ret-type}. The final \exmp{7} arguments specifiy the argument + types. For example, the \var{intrin_exit} intrinsic described above + may be added to the table using +#v+ + MAKE_INTRINSIC_N("exit", intrin_exit, SLANG_VOID_TYPE, 1, + SLANG_INT_TYPE, 0,0,0,0,0,0) +#v- + + While \var{MAKE_INTRINSIC_N} is the main macro for constructing + table entries, \var{slang.h} defines other macros that may prove + useful. In particular, an entry for the \var{intrin_exit} function + may also be created using any of the following forms: +#v+ + MAKE_INTRINSIC_1("exit", intrin_exit, SLANG_VOID_TYPE, SLANG_INT_TYPE) + MAKE_INTRINSIC_I("exit", intrin_exit, SLANG_VOID_TYPE) +#v- + See \var{slang.h} for related macros. You are also encouraged to + look at, e.g., \var{slang/src/slstd.c} for a more extensive examples. + + The table may be added via the \cfun{SLadd_intrin_fun_table} + function, e.g., +#v+ + if (-1 == SLadd_intrin_fun_table (My_Intrinsics, NULL)) + { + /* an error occurred */ + } +#v- + Please note that there is no need to load a given table more than + once, and it is considered to be an error on the part of the + application it adds the same table multiple times. For performance + reasons, no checking is performed by the library to see if a table + has already been added. + + Earlier it was mentioned that intrinsics may be added to a specified + namespace. To this end, one must first get a pointer to the + namespace via the \cfun{SLns_create_namespace} function. The + following example illustrates how this function is used to add the + \var{My_Intrinsics} table to a namespace called \exmp{my}: +#v+ + SLang_NameSpace_Type *ns = SLns_create_namespace ("my"); + if (ns == NULL) + return -1; + + return SLns_add_intrin_fun_table (ns, My_Intrinsics, "__MY__")); +#v- + +#%}}} + +\sect1{More Complicated Intrinsics} #%{{{ + The intrinsic functions described in the previous example were + functions that took a fixed number of arguments. In this section we + explore more complex intrinsics such as those that take a variable + number of arguments. + + Consider a function that takes two double precision numbers and + returns the lesser: +#v+ + double intrin_min (double *a, double *b) + { + if (*a < *b) return *a; + return *b; + } +#v- + This function may be added to a table of intrinsics using +#v+ + MAKE_INTRINSIC_2("vmin", intrin_min, SLANG_DOUBLE_TYPE, + SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE) +#v- + It is useful to extend this function to take an arbitray number of + arguments and return the lesser. Consider the following variant: +#v+ + double intrin_min_n (int *num_ptr) + { + double min_value, x; + unsigned int num = (unsigned int) *num_ptr; + + if (-1 == SLang_pop_double (&min_value, NULL, NULL)) + return 0.0; + num--; + + while (num > 0) + { + num--; + if (-1 == SLang_pop_double (&x, NULL, NULL)) + return 0.0; + if (x < min_value) min_value = x; + } + return min_value; + } +#v- + Here the number to compare is passed to the function and the actual + numbers are removed from the stack via the \cfun{SLang_pop_double} + function. A suitable table entry for it is +#v+ + MAKE_INTRINSIC_I("vmin", intrin_min_n, SLANG_DOUBLE_TYPE) +#v- + This function would be used in an interpreter script via a statement + such as +#v+ + variable xmin = vmin (x0, x1, x2, x3, x4, 5); +#v- + which computes the smallest of \exmp{5} values. + + The problem with this intrinsic function is that the user must + explicitly specify how many numbers to compare. It would be more + convenient to simply use +#v+ + variable xmin = vmin (x0, x1, x2, x3, x4); +#v- + An intrinsic function can query the value of the variable + \var{SLang_Num_Function_Args} to obtain the necessary information: +#v+ + double intrin_min (void) + { + double min_value, x; + + unsigned int num = SLang_Num_Function_Args; + + if (-1 == SLang_pop_double (&min_value, NULL, NULL)) + return 0.0; + num--; + + while (num > 0) + { + num--; + if (-1 == SLang_pop_double (&x, NULL, NULL)) + return 0.0; + if (x < min_value) min_value = x; + } + return min_value; + } +#v- + This may be declared as an intrinsic using: +#v+ + MAKE_INTRINSIC_0("vmin", intrin_min, SLANG_DOUBLE_TYPE) +#v- + + +#%}}} + +#%}}} + +\sect{Intrinsic Variables} #%{{{ + + It is possible to access an application's global variables from + within the interpreter. The current implementation supports the + access of variables of type \var{int}, \var{char *}, and + \var{double}. + + There are two basic methods of making an intrinsic variable + available to the interpreter. The most straight forward method is + to use the function \cfun{SLadd_intrinsic_variable}: +#v+ + int SLadd_intrinsic_variable (char *name, VOID_STAR addr, + unsigned char data_type, + int read_only); +#v- + For example, suppose that \var{I} is an integer variable, e.g., +#v+ + int I; +#v- + One can make it known to the interpreter as \var{I_Variable} via a + statement such as +#v+ + if (-1 == SLadd_intrinsic_variable ("I_Variable", &I, + SLANG_INT_TYPE, 0)) + exit (EXIT_FAILURE); +#v- + Similarly, if \var{S} is declared as +#v+ + char *S; +#v- + then +#v+ + if (-1 == SLadd_intrinsic_variable ("S_Variable", &S, + SLANG_STRING_TYPE, 1)) + exit (EXIT_FAILURE); +#v- + makes \var{S} available as a \em{read-only} variable with the name + \var{S_Variable}. Note that if a pointer variable is made available + to the interpreter, its value is managed by the interpreter and + not the application. For this reason, it is recommended that such + variables be declared as \em{read-only}. + + It is important to note that if \var{S} were declared as an array of + characters, e.g., +#v+ + char S[256]; +#v- + then it would not be possible to make it directly available to the + interpreter. However, one could create a pointer to it, i.e., +#v+ + char *S_Ptr = S; +#v- + and make \var{S_Ptr} available as a read-only variable. + + One should not make the mistake of trying to use the same address + for different variables as the following example illustrates: +#v+ + int do_not_try_this (void) + { + static char *names[3] = {"larry", "curly", "moe"}; + unsigned int i; + + for (i = 0; i < 3; i++) + { + int value; + if (-1 == SLadd_intrinsic_variable (names[i], (VOID_STAR) &value, + SLANG_INT_TYPE, 1)) + return -1; + } + return 0; + } +#v- + Not only does this piece of code create intrinsic variables that use + the same address, it also uses the address of a local variable that + will go out of scope. + + The most convenient method for adding many intrinsic variables to + the interpreter is to create an array of \var{SLang_Intrin_Var_Type} + objects and then add the array via \cfun{SLadd_intrin_var_table}. + For example, the array +#v+ + static SLang_Intrin_Var_Type Intrin_Vars [] = + { + MAKE_VARIABLE("I_Variable", &I, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("S_Variable", &S_Ptr, SLANG_STRING_TYPE, 1), + SLANG_END_TABLE + }; +#v- + may be added via +#v+ + if (-1 == SLadd_intrin_var_table (Intrin_Vars, NULL)) + exit (EXIT_FAILURE); +#v- + It should be rather obvious that the arguments to the + \var{MAKE_VARIABLE} macro correspond to the parameters of the + \cfun{SLadd_intrinsic_variable} function. + + Finally, variables may be added to a specific namespace via the + SLns_add_intrin_var_table and SLns_add_intrinsic_variable functions. + +#%}}} + +\sect{Aggregate Data Objects} #%{{{ + An aggregate data object is an object that can contain more than one + data value. The \slang interpreter supports several such objects: + arrays, structure, and associative arrays. In the following + sections, information about interacting with these objects is given. + +\sect1{Arrays} #%{{{ + An intrinsic function may interact with an array in several different + ways. For example, an intrinsic may create an array and return it. + The basic functions for manipulating arrays include: +#v+ + SLang_create_array + SLang_pop_array_of_type + SLang_push_array + SLang_free_array + SLang_get_array_element + SLang_set_array_element +#v- + The use of these functions will be illustrated via a few simple + examples. + + The first example shows how to create an return an array of strings + to the interpreter. In particular, the names of the four seasons of + the year will be returned: +#v+ + void months_of_the_year (void) + { + static char *seasons[4] = + { + "Spring", "Summer", "Autumn", "Winter" + }; + SLang_Array_Type *at; + int i, four; + + four = 4; + at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &four, 1); + if (at == NULL) + return; + + /* Now set the elements of the array */ + for (i = 0; i < 4; i++) + { + if (-1 == SLang_set_array_element (at, &i, &seasons[i])) + { + SLang_free_array (at); + return; + } + } + + (void) SLang_push_array (at, 0); + SLang_free_array (at); + } +#v- + This example illustrates several points. First of all, the + \cfun{SLang_create_array} function was used to create a 1 dimensional + array of 4 strings. Since this function could fail, its return value + was checked. Then the \cfun{SLang_set_array_element} function was + used to set the elements of the newly created array. Note that the + address containing the value of the array element was passed and not + the value of the array element itself. That is, +#v+ + SLang_set_array_element (at, &i, seasons[i]) +#v- + was not used. The return value from this function was also checked + because it too could also fail. Finally, the array was pushed onto + the interpreter's stack and then it was freed. It is important to + understand why it was freed. This is because arrays are + reference-counted. When the array was created, it was returned with + a reference count of \var{1}. When it was pushed, the reference + count was bumped up to \var{2}. Then since it was nolonger needed by + the function, \cfun{SLang_free_array} was called to decrement the + reference count back to \var{1}. For convenience, the second + argument to \cfun{SLang_push_array} determines whether or not it is to + also free the array. So, instead of the two function calls: +#v+ + (void) SLang_push_array (at, 0); + SLang_free_array (at); +#v- + it is preferable to combine them as +#v+ + (void) SLang_push_array (at, 1); +#v- + + The second example returns a diagonal array of a specified size to + the stack. A diagonal array is a 2-d array with all elements zero + except for those along the diagonal, which have a value of one: +#v+ + void make_diagonal_array (int n) + { + SLang_Array_Type *at; + int dims[2]; + int i, one; + + dims[0] = dims[1] = n; + at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, dims, 2); + if (at == NULL) + return; + + one = 1; + for (i = 0; i < n; i++) + { + dims[0] = dims[1] = i; + if (-1 == SLang_set_array_element (at, dims, &one)) + { + SLang_free_array (at); + return; + } + } + + (void) SLang_push_array (at, 1); + } +#v- + In this example, only the diagonal elements of the array were set. + This is bacause when the array was created, all its elements were + set to zero. + + Now consider an example that acts upon an existing array. In + particular, consider one that computes the trace of a 2-d matrix, + i.e., the sum of the diagonal elements: +#v+ + double compute_trace (void) + { + SLang_Array_Type *at; + double trace; + int dims[2]; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE)) + return 0.0; + + /* We want a 2-d square matrix. If the matrix is 1-d and has only one + element, then return that element. */ + trace = 0.0; + if (((at->num_dims == 1) && (at->dims[0] == 1)) + || ((at->num_dims == 2) && (at->dims[0] == at->dims[1]))) + { + double dtrace; + int n = at->dims[0]; + + for (i = 0; i < n; i++) + { + dims[0] = dims[1] = i; + (void) SLang_get_array_element (at, &dims, &dtrace); + trace += dtrace; + } + } + else SLang_verror (SL_TYPE_MISMATCH, "Expecting a square matrix"); + + SLang_free_array (at); + return trace; + } +#v- + In this example, \cfun{SLang_pop_array_of_type} was used to pop an + array of doubles from the stack. This function will make implicit + typecasts in order to return an array of the requested type. + +#%}}} + +\sect1{Structures} #%{{{ + + For the purposes of this section, we shall differentiate structures + according to whether or not they correspond to an application defined + C structure. Those that do are called intrinsic structures, and + those do not are called \slang interpreter structures. + +\sect2{Interpreter Structures} + + The following simple example shows one method that may be used to + create and return a structure with a string and integer field to the + interpreter's stack: +#v+ + int push_struct_example (char *string_value, int int_value) + { + char *field_names[2]; + unsigned char field_types[2]; + VOID_STAR field_values[2]; + + field_names[0] = "string_field"; + field_types[0] = SLANG_STRING_TYPE; + field_values[0] = &string_value; + + field_names[1] = "int_field"; + field_types[1] = SLANG_INT_TYPE; + field_values[1] = &int_value; + + if (-1 == SLstruct_create_struct (2, field_names, + field_types, field_values)) + return -1; + return 0; + } +#v- + Here, \cfun{SLstruct_create_struct} is used to push a + structure with the specified field names and values onto the + interpreter's stack. + + A simpler mechanism exists provided that one has already defined a C + structure with a description of how the structure is laid out. For + example, consider a C structure defined by +#v+ + typedef struct + { + char *s; + int i; + } + SI_Type; +#v- + Its layout may be specified via a table of + \var{SLang_CStruct_Field_Type} entries: +#v+ + SLang_CStruct_Field_Type SI_Type_Layout [] = + { + MAKE_CSTRUCT_FIELD(SI_Type, s, "string_field", SLANG_STRING_TYPE, 0), + MAKE_CSTRUCT_FIELD(SI_Type, i, "int_field", SLANG_INT_TYPE, 0), + SLANG_END_CSTRUCT_TABLE + }; +#v- + Here, MAKE_CSTRUCT_FIELD is a macro taking 5 arguments: +#v+ + MAKE_CSTRUCT_FIELD(C-structure-type, + C-field-name, + slang-field-name, + slang-data-type, + is-read-only) +#v- + The first argument is the structure type, the second is the name of + a field of the structure, the third is a string that specifies the + name of the corresponding field of the \slang structure, the fourth + argument specifies the field's type, and the last argument + specifies whether or not the field should be regarded as read-only. + + Once the layout of the structure has been specified, pushing a + \slang version of the structure is trival: +#v+ + int push_struct_example (char *string_value, int int_value) + { + SI_Type si; + + si.s = string_value; + si.i = int_value; + return SLang_push_cstruct ((VOID_STAR)&si, SI_Type_Layout); + } +#v- + + This mechanism of structure creation also permits a \slang + structure to be passed to an intrinsic function through the use of + the SLang_pop_cstruct routine, e.g., +#v+ + void print_si_struct (void) + { + SI_Type si; + if (-1 == SLang_pop_cstruct ((VOID_STAR)&si, SI_Type_Layout)) + return; + printf ("si.i=%d", si.i); + printf ("si.s=%s", si.s); + SLang_free_cstruct ((VOID_STAR)&si, SI_Type_Layout); + } +#v- + Assuming \exmp{print_si_struct} exists as an intrinsic function, + the \slang code +#v+ + variable s = struct {string_field, int_field}; + s.string_field = "hello"; + s.int_field = 20; + print_si_struct (s); +#v- + would result in the display of +#v+ + si.i=20; + si.s=hello +#v- + Note that the \cfun{SLang_free_cstruct} function was called after + the contents of \exmp{si} were nolonger needed. This was necessary + because \cfun{SLang_pop_cstruct} allocated memory to set the + \exmp{char *s} field of \exmp{si}. Calling + \cfun{SLang_free_cstruct} frees up such memory. + + Now consider the following: +#v+ + typedef struct + { + pid_t pid; + gid_t group; + } + X_t; +#v- + How should the layout of this structure be defined? One might be + tempted to use: +#v+ + SLang_CStruct_Field_Type X_t_Layout [] = + { + MAKE_CSTRUCT_FIELD(X_t, pid, "pid", SLANG_INT_TYPE, 0), + MAKE_CSTRUCT_FIELD(X_t, group, "group", SLANG_INT_TYPE, 0), + SLANG_END_CSTRUCT_TABLE + }; +#v- + However, this assumes \exmp{pid_t} and \exmp{gid_t} have been + typedefed as ints. But what if \exmp{gid_t} is a \exmp{short}? In + such a case, using +#v+ + MAKE_CSTRUCT_FIELD(X_t, group, "group", SLANG_SHORT_TYPE, 0), +#v- + would be the appropriate entry for the \exmp{group} field. Of + course, one has no way of knowing how \exmp{gid_t} is declared on + other systems. For this reason, it is preferable to use the + \var{MAKE_CSTRUCT_INT_FIELD} macro in cases involving integer valued + fields, e.g., +#v+ + SLang_CStruct_Field_Type X_t_Layout [] = + { + MAKE_CSTRUCT_INT_FIELD(X_t, pid, "pid", 0), + MAKE_CSTRUCT_INT_FIELD(X_t, group, "group", 0), + SLANG_END_CSTRUCT_TABLE + }; +#v- + + Before leaving this section, it is important to mention that + access to character array fields is not permitted via this + interface. That is, a structure such as +#v+ + typedef struct + { + char name[32]; + } + Name_Type; +#v- + is not supported since \exmp{char name[32]} is not a + \var{SLANG_STRING_TYPE} object. Always keep in mind that a + \var{SLANG_STRING_TYPE} object is a \exmp{char *}. + +\sect2{Intrinsic Structures} + + Here we show how to make intrinsic structures available to + the interpreter. + + The simplest interface is to structure pointers and not + to the actual structures themselves. The latter would require the + interpreter to be involved with the creation and destruction of the + structures. Dealing with the pointers themselves is far simpler. + + As an example, consider an object such as +#v+ + typedef struct _Window_Type + { + char *title; + int row; + int col; + int width; + int height; + } Window_Type; +#v- + which defines a window object with a title, size (\var{width}, + \var{height}), and location (\var{row}, \var{col}). + + We can make variables of type \var{Window_Type} available to the + interpreter via a table as follows: +#v+ + static SLang_IStruct_Field_Type Window_Type_Field_Table [] = + { + MAKE_ISTRUCT_FIELD(Window_Type, title, "title", SLANG_STRING_TYPE, 1), + MAKE_ISTRUCT_FIELD(Window_Type, row, "row", SLANG_INT_TYPE, 0), + MAKE_ISTRUCT_FIELD(Window_Type, col, "col", SLANG_INT_TYPE, 0), + MAKE_ISTRUCT_FIELD(Window_Type, width, "width", SLANG_INT_TYPE, 0), + MAKE_ISTRUCT_FIELD(Window_Type, height, "height", SLANG_INT_TYPE, 0), + SLANG_END_ISTRUCT_TABLE + }; +#v- + More precisely, this defines the layout of the \var{Window_Type} structure. + Here, the \var{title} has been declared as a read-only field. Using +#v+ + MAKE_ISTRUCT_FIELD(Window_Type, title, "title", SLANG_STRING_TYPE, 0), +#v- + would allow read-write access. + + Now suppose that \var{My_Window} is a pointer to a \var{Window_Type} + object, i.e., +#v+ + Window_Type *My_Window; +#v- + We can make this variable available to the interpreter via the + \cfun{SLadd_istruct_table} function: +#v+ + if (-1 == SLadd_istruct_table (Window_Type_Field_Table, + (VOID_STAR) &My_Window, + "My_Win")) + exit (1); +#v- + This creates a S-Lang interpreter variable called \var{My_Win} whose value + corresponds to the \var{My_Win} structure. This would permit one to + access the fields of \var{My_Window} via \slang statements such as +#v+ + define set_width_and_height (w,h) + { + My_Win.width = w; + My_Win.height = h; + } +#v- + + It is extremely important to understand that the interface described in + this section does not allow the interpreter to create new instances of + \var{Window_Type} objects. The interface merely defines an association or + correspondence between an intrinsic structure pointer and a \slang + variable. For example, if the value of \var{My_Window} is \var{NULL}, then + \var{My_Win} would also be \var{NULL}. + + One should be careful in allowing read/write access to character string + fields. If read/write access is allowed, then the application should + always use the \cfun{SLang_create_slstring} and \cfun{SLang_free_slstring} + functions to set the character string field of the structure. + +#%}}} + + +#%}}} + +#%}}} + +\chapter{Keyboard Interface} #%{{{ + +#%{{{ Overview + + \slang's keyboard interface has been designed to allow an + application to read keyboard input from the user in a + system-independent manner. The interface consists of a set of low + routines for reading single character data as well as a higher + level interface (\grp{SLkp}) which utilize \slang's keymap facility + for reading multi-character sequences. + + To initialize the interface, one must first call the function + \verb{SLang_init_tty}. Before exiting the program, the function + \verb{SLang_reset_tty} must be called to restore the keyboard + interface to its original state. Once initialized, the low-level + \verb{SLang_getkey} function may be used to read \em{simgle} + keyboard characters from the terminal. An application using the + higher-level \grp{SLkp} interface will read charcters using the + \verb{SLkp_getkey} function. + + In addition to these basic functions, there are also functions to + ``unget'' keyboard characters, flush the input, detect pending-input + with a timeout, etc. These functions are defined below. + +#%}}} + +\sect{Initializing the Keyboard Interface} #%{{{ + + The function \verb{SLang_init_tty} must be called to initialize the + terminal for single character input. This puts the terminal in a mode + usually referred to as ``raw'' mode. + + The prototype for the function is: +#v+ + int SLang_init_tty (int abort_char, int flow_ctrl, int opost); +#v- + It takes three parameters that are used to specify how the terminal is to + be initialized. +#%+ + Although the \slang keyboard interface has been + %designed to be as system independent as possible, there are semantic + % differences. +#%- + + The first parameter, \verb{abort_char}, is used to specify the interrupt + character (\tt{SIGINT}). Under MSDOS, this value corresponds to the scan + code of the character that will be used to generate the interrupt. For + example, under MSDOS, \verb{34} should be used to make \key{Ctrl-G} generate an + interrupt signal since 34 is the scan code for \key{G}. On other + systems, the value of \verb{abort_char} will simply be the ascii value of + the control character that will be used to generate the interrupt signal, + e.g., \tt{7} for \key{Ctrl-G}. If \verb{-1} is passed, the interrupt + character will not be changed. + + Pressing the interrupt character specified by the first argument will + generate a signal (\tt{SIGINT}) that may or not be caught by the + application. It is up to the application to catch this signal. \slang + provides the function \verb{Slang_set_abort_signal} to make it easy to + facilitate this task. + + The second parameter is used to specify whether or not flow control should + be used. If this parameter is zero, flow control is enabled otherwise + it is disabled. Disabling flow control is necessary to pass certain + characters to the application (e.g., \key{Ctrl-S} and \key{Ctrl-Q}). + For some systems such as MSDOS, this parameter is meaningless. + + The third parameter, \verb{opost}, is used to turn output processing on or + off. If \verb{opost} is zero, output processing is \em{not} turned on + otherwise, output processing is turned on. + + The \verb{SLang_init_tty} function returns -1 upon failure. In addition, + after it returns, the \slang global variable \verb{SLang_TT_Baud_Rate} + will be set to the baud rate of the terminal if this value can be + determined. + + Example: +#v+ + if (-1 == SLang_init_tty (7, 0, 0)) /* For MSDOS, use 34 as scan code */ + { + fprintf (stderr, "Unable to initialize the terminal.\n"); + exit (1); + } + SLang_set_abort_signal (NULL); +#v- + Here the terminal is initialized such that flow control and output + processing are turned off. In addition, the character + \key{Ctrl-G}\footnote{For MSDOS systems, use the \em{scan code} 34 + instead of 7 for \key{Ctrl-G}} has been specified to be the interrupt + character. The function \verb{SLang_set_abort_signal} is used to + install the default \slang interrupt signal handler. + +#%}}} + +\sect{Resetting the Keyboard Interface} #%{{{ + + The function \verb{SLang_reset_tty} must be called to reset the terminal + to the state it was in before the call to \verb{SLang_init_tty}. The + prototype for this function is: +#v+ + void SLang_reset_tty (void); +#v- + Usually this function is only called before the program exits. However, + if the program is suspended it should also be called just before suspension. + +#%}}} + +\sect{Initializing the \grp{SLkp} Routines} #%{{{ + + Extra initialization of the higher-level \grp{SLkp} functions are + required because they are layered on top of the lower level + routines. Since the \verb{SLkp_getkey} function is able to process + function and arrow keys in a terminal independent manner, it is + necessary to call the \verb{SLtt_get_terminfo} function to get + information about the escape character sequences that the terminal's + function keys send. Once that information is available, the + \verb{SLkp_init} function can construct the proper keymaps to + process the escape sequences. + + This part of the initialization process for an application using + this interface will look something like: + +#v+ + SLtt_get_terminfo (); + if (-1 == SLkp_init ()) + { + SLang_doerror ("SLkp_init failed."); + exit (1); + } + if (-1 == SLang_init_tty (-1, 0, 1)) + { + SLang_doerror ("SLang_init_tty failed."); + exit (1); + } +#v- + + It is important to check the return status of the \verb{SLkp_init} + function which can failed if it cannot allocate enough memory for + the keymap. + +#%}}} + +\sect{Setting the Interrupt Handler} #%{{{ + + The function \verb{SLang_set_abort_signal} may be used to associate an + interrupt handler with the interrupt character that was previously + specified by the \verb{SLang_init_tty} function call. The prototype for + this function is: +#v+ + void SLang_set_abort_signal (void (*)(int)); +#v- + This function returns nothing and takes a single parameter which is a + pointer to a function taking an integer value and returning + \verb{void}. If a \verb{NULL} pointer is passed, the default \slang + interrupt handler will be used. The \slang default interrupt handler + under Unix looks like: +#v+ + static void default_sigint (int sig) + { + SLsignal_intr (SIGINT, default_sigint); + SLKeyBoard_Quit = 1; + if (SLang_Ignore_User_Abort == 0) SLang_Error = USER_BREAK; + } +#v- + It simply sets the global variable \verb{SLKeyBoard_Quit} to one and + if the variable \verb{SLang_Ignore_User_Abort} is non-zero, + \verb{SLang_Error} is set to indicate a user break condition. (The + function \verb{SLsignal_intr} is similar to the standard C + \verb{signal} function \em{except that it will interrupt system + calls}. Some may not like this behavior and may wish to call + this \verb{SLang_set_abort_signal} with a different handler.) + + Although the function expressed above is specific to Unix, the + analogous routines for other operating systems are equivalent in + functionality even though the details of the implementation may vary + drastically (e.g., under MSDOS, the hardware keyboard interrupt + \verb{int 9h} is hooked). + +#%}}} + +\sect{Reading Keyboard Input with SLang_getkey} #%{{{ + + After initializing the keyboard via \verb{SLang_init_tty}, + the \slang function \verb{SLang_getkey} may be used to read + characters from the terminal interface. In addition, the function + \verb{SLang_input_pending} may be used to determine whether or not + keyboard input is available to be read. + + These functions have prototypes: +#v+ + unsigned int SLang_getkey (void); + int SLang_input_pending (int tsecs); +#v- + The \verb{SLang_getkey} function returns a single character from the + terminal. Upon failure, it returns \verb{0xFFFF}. If the interrupt + character specified by the \verb{SLang_init_tty} function is pressed + while this function is called, the function will return the value of the + interrupt character and set the \slang global variable + \verb{SLKeyBoard_Quit} to a non-zero value. In addition, if the default + \slang interrupt handler has been specified by a \verb{NULL} argument to + the \verb{SLang_set_abort_signal} function, the global variable + \verb{SLang_Error} will be set to \verb{USER_BREAK} \em{unless} the + variable \verb{SLang_Ignore_User_Abort} is non-zero. + + The \verb{SLang_getkey} function waits until input is available to be + read. The \verb{SLang_input_pending} function may be used to determine + whether or not input is ready. It takes a single parameter that indicates + the amount of time to wait for input before returning with information + regarding the availability of input. This parameter has units of one + tenth (1/10) of a second, i.e., to wait one second, the value of the + parameter should be \tt{10}. Passing a value of zero causes the function + to return right away. \verb{SLang_input_pending} returns a positive + integer if input is available or zero if input is not available. It will + return -1 if an error occurs. + + Here is a simple example that reads keys from the terminal until one + presses \key{Ctrl-G} or until 5 seconds have gone by with no input: +#v+ + #include + #include "slang.h" + int main () + { + int abort_char = 7; /* For MSDOS, use 34 as scan code */ + unsigned int ch; + + if (-1 == SLang_init_tty (abort_char, 0, 1)) + { + fprintf (stderr, "Unable to initialize the terminal.\n"); + exit (-1); + } + SLang_set_abort_signal (NULL); + while (1) + { + fputs ("\nPress any key. To quit, press Ctrl-G: ", stdout); + fflush (stdout); + if (SLang_input_pending (50) == 0) /* 50/10 seconds */ + { + fputs ("Waited too long! Bye\n", stdout); + break; + } + + ch = SLang_getkey (); + if (SLang_Error == USER_BREAK) + { + fputs ("Ctrl-G pressed! Bye\n", stdout); + break; + } + putc ((int) ch, stdout); + } + SLang_reset_tty (); + return 0; + } +#v- + + +#%}}} + +\sect{Reading Keyboard Input with SLkp_getkey} #%{{{ + + Unlike the low-level function \verb{SLang_getkey}, the + \verb{SLkp_getkey} function can read a multi-character sequence + associated with function keys. The \verb{SLkp_getkey} function uses + \verb{SLang_getkey} and \slang's keymap facility to process escape + sequences. It returns a single integer which describes the key that + was pressed: +#v+ + int SLkp_getkey (void); +#v- + That is, the \verb{SLkp_getkey} function simple provides a mapping + between keys and integers. In this context the integers are called + \em{keysyms}. + + For single character input such as generated by the \key{a} key on + the keyboard, the function returns the character that was generated, + e.g., \verb{'a'}. For single characters, \verb{SLkp_getkey} will + always return an keysym whose value ranges from 0 to 256. For + keys that generate multiple character sequences, e.g., a function or + arrow key, the function returns an keysym whose value is greater + that 256. The actual values of these keysyms are represented as + macros defined in the \file{slang.h} include file. For example, the + up arrow key corresponds to the keysym whose value is + \verb{SL_KEY_UP}. + + Since it is possible for the user to enter a character sequence that + does not correspond to any key. If this happens, the special keysym + \verb{SL_KEY_ERR} will be returned. + + Here is an example of how \verb{SLkp_getkey} may be used by a file + viewer: +#v+ + switch (SLkp_getkey ()) + { + case ' ': + case SL_KEY_NPAGE: + next_page (); + break; + case 'b': + case SL_KEY_PPAGE: + previous_page (); + break; + case '\r': + case SL_KEY_DOWN: + next_line (); + break; + . + . + case SL_KEY_ERR: + default: + SLtt_beep (); + } +#v- + + Unlike its lower-level counterpart, \verb{SLang_getkey}, there do + not yet exist any functions in the library that are capable of + ``ungetting'' keysyms. In particular, the \verb{SLang_ungetkey} + function will not work. + +#%}}} + +\sect{Buffering Input} #%{{{ + + \slang has several functions pushing characters back onto the + input stream to be read again later by \verb{SLang_getkey}. It + should be noted that none of the above functions are designed to + push back keysyms read by the \verb{SLkp_getkey} function. These + functions are declared as follows: +#v+ + void SLang_ungetkey (unsigned char ch); + void SLang_ungetkey_string (unsigned char *buf, int buflen); + void SLang_buffer_keystring (unsigned char *buf, int buflen); +#v- + + \verb{SLang_ungetkey} is the most simple of the three functions. It takes + a single character a pushes it back on to the input stream. The next call to + \verb{SLang_getkey} will return this character. This function may be used + to \em{peek} at the character to be read by first reading it and then + putting it back. + + \verb{SLang_ungetkey_string} has the same function as + \verb{SLang_ungetkey} except that it is able to push more than one + character back onto the input stream. Since this function can push back + null (ascii 0) characters, the number of characters to push is required as + one of the parameters. + + The last of these three functions, \verb{SLang_buffer_keystring} can + handle more than one charater but unlike the other two, it places the + characters at the \em{end} of the keyboard buffer instead of at the + beginning. + + Note that the use of each of these three functions will cause + \verb{SLang_input_pending} to return right away with a non-zero value. + + Finally, the \slang keyboard interface includes the function + \verb{SLang_flush_input} with prototype +#v+ + void SLang_flush_input (void); +#v- + It may be used to discard \em{all} input. + + Here is a simple example that looks to see what the next key to be read is + if one is available: +#v+ + int peek_key () + { + int ch; + if (SLang_input_pending (0) == 0) return -1; + ch = SLang_getkey (); + SLang_ungetkey (ch); + return ch; + } +#v- + + +#%}}} + +\sect{Global Variables} #%{{{ + Although the following \slang global variables have already been + mentioned earlier, they are gathered together here for completeness. + + \verb{int SLang_Ignore_User_Abort;} + If non-zero, pressing the interrupt character will not result in + \verb{SLang_Error} being set to \verb{USER_BREAK}. + + \verb{volatile int SLKeyBoard_Quit;} + This variable is set to a non-zero value when the interrupt + character is pressed. If the interrupt character is pressed when + \verb{SLang_getkey} is called, the interrupt character will be + returned from \verb{SLang_getkey}. + + \verb{int SLang_TT_Baud_Rate;} + On systems which support it, this variable is set to the value of the + terminal's baud rate after the call to \verb{SLang_init_tty}. + +#%}}} + +#%}}} + +\chapter{Screen Management} #%{{{ + + The \slang library provides two interfaces to terminal independent + routines for manipulating the display on a terminal. The highest level + interface, known as the \verb{SLsmg} interface is discussed in this + section. It provides high level screen management functions more + manipulating the display in an optimal manner and is similar in spirit to + the \verb{curses} library. The lowest level interface, or the + \verb{SLtt} + interface, is used by the \verb{SLsmg} routines to actually perform the + task of writing to the display. This interface is discussed in another + section. Like the keyboard routines, the \verb{SLsmg} routines are + \em{platform independent} and work the same on MSDOS, OS/2, Unix, and VMS. + + The screen management, or \verb{SLsmg}, routines are initialized by + function \verb{SLsmg_init_smg}. Once initialized, the application uses + various \verb{SLsmg} functions to write to a \em{virtual} display. This does + not cause the \em{physical} terminal display to be updated immediately. + The physical display is updated to look like the virtual display only + after a call to the function \verb{SLsmg_refresh}. Before exiting, the + application using these routines is required to call + \verb{SLsmg_reset_smg} to reset the display system. + + The following subsections explore \slang's screen management system in + greater detail. + +\sect{Initialization} + + The function \verb{SLsmg_init_smg} must be called before any other + \verb{SLsmg} function can be used. It has the simple prototype: +#v+ + int SLsmg_init_smg (void); +#v- + It returns zero if successful or -1 if it cannot allocate space for + the virtual display. + + For this routine to properly initialize the virtual display, the + capabilities of the terminal must be known as well as the size of + the \em{physical} display. For these reasons, the lower level \verb{SLtt} routines + come into play. In particular, before the first call to + \verb{SLsmg_init_smg}, the application is required to call the function + \verb{SLtt_get_terminfo} before calling \verb{SLsmg_init_smg}. + + The \verb{SLtt_get_terminfo} function sets the global variables + \verb{SLtt_Screen_Rows} and \verb{SLtt_Screen_Cols} to the values + appropriate for the terminal. It does this by calling the + \verb{SLtt_get_screen_size} function to query the terminal driver + for the appropriate values for these variables. From this point on, + it is up to the application to maintain the correct values for these + variables by calling the \verb{SLtt_get_screen_size} function + whenever the display size changes, e.g., in response to a + \verb{SIGWINCH} signal. Finally, if the application is going to read + characters from the keyboard, it is also a good idea to initialize + the keyboard routines at this point as well. + +\sect{Resetting SLsmg} + + Before the program exits or suspends, the function + \verb{SLsmg_reset_tty} + should be called to shutdown the display system. This function has the + prototype +#v+ + void SLsmg_reset_smg (void); +#v- + This will deallocate any memory allocated for the virtual screen and + reset the terminal's display. + + Basically, a program that uses the \verb{SLsmg} screen management functions + and \slang's keyboard interface will look something like: +#v+ + #include "slang.h" + int main () + { + SLtt_get_terminfo (); + SLang_init_tty (-1, 0, 0); + SLsmg_init_smg (); + + /* do stuff .... */ + + SLsmg_reset_smg (); + SLang_reset_tty (); + return 0; + } +#v- + If this program is compiled and run, all it will do is clear the screen + and position the cursor at the bottom of the display. In the following + sections, other \verb{SLsmg} functions will be introduced which may be used + to make this simple program do much more. + +\sect{Handling Screen Resize Events} + The function \verb{SLsmg_reinit_smg} is designed to be used in + conjunction with resize events. + + Under Unix-like operating systems, when the size of the display + changes, the application will be sent a \verb{SIGWINCH} signal. To + properly handle this signal, the \verb{SLsmg} routines must be + reinitialized to use the new display size. This may be accomplished + by calling \verb{SLtt_get_screen_size} to get the new size, followed by + \verb{SLsmg_reinit_smg} to reinitialize the \verb{SLsmg} interface + to use the new size. Keep in mind that these routines should + not be called from within the signal handler. The following code + illustrates the main ideas involved in handling such events: +#v+ + static volatile int Screen_Size_Changed; + static sigwinch_handler (int sig) + { + Screen_Size_Changed = 1; + SLsignal (SIGWINCH, sigwinch_handler); + } + + int main (int argc, char **argv) + { + SLsignal (SIGWINCH, sigwinch_handler); + SLsmg_init_smg (); + . + . + /* Now enter main loop */ + while (not_done) + { + if (Screen_Size_Changed) + { + SLtt_get_screen_size (); + SLsmg_reinit_smg (); + redraw_display (); + } + . + . + } + return 0; + } +#v- + + +\sect{SLsmg Functions} #%{{{ + + In the previous sections, functions for initializing and shutting down the + \verb{SLsmg} routines were discussed. In this section, the rest of the + \verb{SLsmg} functions are presented. These functions act only on the + \em{virtual} display. The \em{physical} display is updated when the + \verb{SLsmg_refresh} function is called and \em{not until that time}. + This function has the simple prototype: +#v+ + void SLsmg_refresh (void); +#v- + +\sect1{Positioning the cursor} + + The \verb{SLsmg_gotorc} function is used to position the cursor at a given + row and column. The prototype for this function is: +#v+ + void SLsmg_gotorc (int row, int col); +#v- + The origin of the screen is at the top left corner and is given the + coordinate (0, 0), i.e., the top row of the screen corresponds to + \verb{row = 0} and the first column corresponds to \verb{col = 0}. The last + row of the screen is given by \verb{row = SLtt_Screen_Rows - 1}. + + It is possible to change the origin of the coordinate system by using the + function \verb{SLsmg_set_screen_start} with prototype: +#v+ + void SLsmg_set_screen_start (int *r, int *c); +#v- + This function takes pointers to the new values of the first row and first + column. It returns the previous values by modifying the values of the + integers at the addresses specified by the parameter list. A + \verb{NULL} + pointer may be passed to indicate that the origin is to be set to its + initial value of 0. For example, +#v+ + int r = 10; + SLsmg_set_screen_start (&r, NULL); +#v- + sets the origin to (10, 0) and after the function returns, the variable + \verb{r} will have the value of the previous row origin. + +\sect1{Writing to the Display} + + \verb{SLsmg} has several routines for outputting text to the virtual + display. The following points should be understood: +\begin{itemize} +\item The text is output at the position of the cursor of the virtual + display and the cursor is advanced to the position that corresponds to + the end of the text. + +\item Text does \em{not} wrap at the boundary of the + display--- it is trucated. This behavior seems to be more useful in + practice since most programs that would use screen management tend to + be line oriented. + +\item Control characters are displayed in a two character sequence + representation with \verb{^} as the first character. That is, + \key{Ctrl-X} is output as \verb{^X}. + +\item The newline character does \em{not} cause the cursor to advance to + the next row. Instead, when a newline character is encountered when + outputting text, the output routine will return. That is, outputting + a string containing a newline character will only display the contents + of the string up to the newline character. +\end{itemize} + + Although the some of the above items might appear to be too restrictive, in + practice this is not seem to be the case. In fact, the design of the + output routines was influenced by their actual use and modified to + simplify the code of the application utilizing them. + + \verb{void SLsmg_write_char (char ch);} + Write a single character to the virtual display. + + \verb{void SLsmg_write_nchars (char *str, int len);} + Write \verb{len} characters pointed to by \verb{str} to the virtual display. + + \verb{void SLsmg_write_string (char *str);} + Write the null terminated string given by pointer \verb{str} to the virtual + display. This function is a wrapper around \verb{SLsmg_write_nchars}. + + \verb{void SLsmg_write_nstring (char *str, int n);} + Write the null terminated string given by pointer \verb{str} to the virtual + display. At most, only \verb{n} characters are written. If the length of + the string is less than \verb{n}, then the string will be padded with blanks. + This function is a wrapper around \verb{SLsmg_write_nchars}. + + \verb{void SLsmg_printf (char *fmt, ...);} + This function is similar to \verb{printf} except that it writes to the + \verb{SLsmg} virtual display. + + \verb{void SLsmg_vprintf (char *, va_list);} + Like \verb{SLsmg_printf} but uses a variable argument list. + +\sect1{Erasing the Display} + + The following functions may be used to fill portions of the display with + blank characters. The attributes of blank character are the current + attributes. (See below for a discussion of character attributes) + + \verb{void SLsmg_erase_eol (void);} + Erase line from current position to the end of the line. + + \verb{void SLsmg_erase_eos (void);} + Erase from the current position to the end of the screen. + + \verb{void SLsmg_cls (void);} + Clear the entire virtual display. + +\sect1{Setting Character Attributes} + + Character attributes define the visual characteristics the character + possesses when it is displayed. Visual characteristics include the + foreground and background colors as well as other attributes such as + blinking, bold, and so on. Since \verb{SLsmg} takes a different approach + to this problem than other screen management libraries an explanation of + this approach is given here. This approach has been motivated by + experience with programs that require some sort of screen management. + + Most programs that use \verb{SLsmg} are composed of specific textual + objects or objects made up of line drawing characters. For example, + consider an application with a menu bar with drop down menus. The menus + might be enclosed by some sort of frame or perhaps a shadow. The basic + idea is to associate an integer to each of the objects (e.g., menu bar, + shadow, current menu item, etc.) and create a mapping from the integer to + the set of attributes. In the terminology of \verb{SLsmg}, the integer is + simply called an \em{object}. + + For example, the menu bar might be associated with the object \verb{1}, the + drop down menu could be object \verb{2}, the shadow could be object + \verb{3}, + and so on. + + The range of values for the object integer is restricted from 0 up to + and including 255 on all systems except MSDOS where the maximum allowed + integer is 15\footnote{This difference is due to memory constraints + imposed by MSDOS. This restriction might be removed in a future version of + the library.}. The object numbered zero should not be regarding as an + object at all. Rather it should be regarded as all \em{other} objects + that have not explicitly been given an object number. \verb{SLsmg}, or + more precisely \verb{SLtt}, refers to the attributes of this special object + as the \em{default} or \em{normal} attributes. + + The \verb{SLsmg} routines know nothing about the mapping of the color to the + attributes associated with the color. The actual mapping takes place at a + lower level in the \verb{SLtt} routines. Hence, to map an object to the + actual set of attributes requires a call to any of the following + \verb{SLtt} + routines: +#v+ + void SLtt_set_color (int obj, char *name, char *fg, char *bg); + void SLtt_set_color_object (int obj, SLtt_Char_Type attr); + void SLtt_set_mono (int obj, char *, SLtt_Char_Type attr); +#v- + Only the first of these routines will be discussed briefly here. The + latter two functions allow more fine control over the object to attribute + mapping (such as assigning a ``blink'' attribute to the object). For a + more full explanation on all of these routines see the section about the + \verb{SLtt} interface. + + The \verb{SLtt_set_color} function takes four parameters. The first + parameter, \verb{obj}, is simply the integer of the object for which + attributes are to be assigned. The second parameter is currently + unused by these routines. The third and forth parameters, \verb{fg} + and \verb{bg}, are the names of the foreground and background color + to be used associated with the object. The strings that one can use + for the third and fourth parameters can be any one of the 16 colors: +#v+ + "black" "gray" + "red" "brightred" + "green" "brightgreen" + "brown" "yellow" + "blue" "brightblue" + "magenta" "brightmagenta" + "cyan" "brightcyan" + "lightgray" "white" +#v- + The value of the foreground parameter \verb{fg} can be anyone of these + sixteen colors. However, on most terminals, the background color will + can only be one of the colors listed in the first column\footnote{This is + also true on the Linux console. However, it need not be the case and + hopefully the designers of Linux will someday remove this restriction.}. + + Of course not all terminals are color terminals. If the \slang global + variable \verb{SLtt_Use_Ansi_Colors} is non-zero, the terminal is + assumed to be a color terminal. The \verb{SLtt_get_terminfo} will + try to determine whether or not the terminal supports colors and set + this variable accordingly. It does this by looking for the + capability in the terminfo/termcap database. Unfortunately many Unix + databases lack this information and so the \verb{SLtt_get_terminfo} + routine will check whether or not the environment variable + \verb{COLORTERM} exists. If it exists, the terminal will be assumed + to support ANSI colors and \verb{SLtt_Use_Ansi_Colors} will be set to one. + Nevertheless, the application should provide some other mechanism to set + this variable, e.g., via a command line parameter. + + When the \verb{SLtt_Use_Ansi_Colors} variable is zero, all objects + with numbers greater than one will be displayed in inverse + video\footnote{This behavior can be modified by using the + \tt{SLtt_set_mono} function call.}. + + With this background, the \verb{SLsmg} functions for setting the character + attributes can now be defined. These functions simply set the object + attributes that are to be assigned to \em{subsequent} characters written + to the virtual display. For this reason, the new attribute is called the + \em{current} attribute. + + \verb{void SLsmg_set_color (int obj);} + Set the current attribute to those of object \verb{obj}. + + \verb{void SLsmg_normal_video (void);} + This function is equivalent to \verb{SLsmg_set_color (0)}. + + \verb{void SLsmg_reverse_video (void);} + This function is equivalent to \verb{SLsmg_set_color (1)}. On monochrome + terminals, it is equivalent to setting the subsequent character attributes + to inverse video. + + Unfortunately there does not seem to be a standard way for the + application or, in particular, the library to determine which color + will be used by the terminal for the default background. Such + information would be useful in initializing the foreground and + background colors associated with the default color object (0). FOr + this reason, it is up to the application to provide some means for + the user to indicate what these colors are for the particular + terminal setup. To facilitate this, the \verb{SLtt_get_terminfo} + function checks for the existence of the \verb{COLORFGBG} + environment variable. If this variable exists, its value will be + used to initialize the colors associated with the default color + object. Specifically, the value is assumed to consist of a + foreground color name and a background color name separated by a + semicolon. For example, if the value of \verb{COLORTERM} is + \verb{lightgray;blue}, the default color object will be initialized + to represent a \verb{lightgray} foreground upon a \verb{blue} + background. + +\sect1{Lines and Alternate Character Sets} + The \slang screen management library also includes routines for turning + on and turning off alternate character sets. This is especially useful + for drawing horizontal and vertical lines. + + \verb{void SLsmg_set_char_set (int flag);} + If \verb{flag} is non-zero, subsequent write functions will use characters + from the alternate character set. If \verb{flag} is zero, the default, or, + ordinary character set will be used. + + \verb{void SLsmg_draw_hline (int len);} + Draw a horizontal line from the current position to the column that is + \verb{len} characters to the right. + + \verb{void SLsmg_draw_vline (int len);} + Draw a horizontal line from the current position to the row that is + \verb{len} rows below. + + \verb{void SLsmg_draw_box (int r, int c, int dr, int dc);} + Draw a box whose upper right corner is at row \verb{r} and column + \verb{c}. + The box spans \verb{dr} rows and \verb{dc} columns. The current position + will be left at row \verb{r} and column \verb{c}. + +\sect1{Miscellaneous Functions} + + \verb{void SLsmg_touch_lines (int r, int n);} + Mark screen rows numbered \verb{r}, \verb{r + 1}, \ldots \verb{r + + (n - 1)} as + modified. When \verb{SLsmg_refresh} is called, these rows will be + completely redrawn. + + \verb{unsigned short SLsmg_char_at(void);} + Returns the character and its attributes object number at the current + cursor position. The character itself occupies the lower byte and the + object attributes number forms the upper byte. The object returned + by this function call should not be written back out via any of the + functions that write characters or character strings. + + +#%}}} + +\sect{Variables} #%{{{ + + The following \slang global variables are used by the \verb{SLsmg} + interface. Some of these have been previously discussed. + + \verb{int SLtt_Screen_Rows;} + \verb{int SLtt_Screen_Cols;} + The number of rows and columns of the \em{physical} display. If either of + these numbers changes, the functions \verb{SLsmg_reset_smg} and + \verb{SLsmg_init_smg} should be called again so that the \verb{SLsmg} + routines can re-adjust to the new size. + + \verb{int SLsmg_Tab_Width;} + Set this variable to the tab width that will be used when expanding tab + characters. The default is 8. + + \verb{int SLsmg_Display_Eight_Bit} + This variable determines how characters with the high bit set are to be + output. Specifically, a character with the high bit set with a value + greater than or equal to this value is output as is; otherwise, it will be + output in a 7-bit representation. The default value for this variable is + \verb{128} for MSDOS and \verb{160} for other systems (ISO-Latin). + + \verb{int SLtt_Use_Ansi_Colors;} + If this value is non-zero, the terminal is assumed to support ANSI colors + otherwise it is assumed to be monochrome. The default is 0. + + \verb{int SLtt_Term_Cannot_Scroll;} + If this value is zero, the \verb{SLsmg} will attempt to scroll the physical + display to optimize the update. If it is non-zero, the screen management + routines will not perform this optimization. For some applications, this + variable should be set to zero. The default value is set by the + \verb{SLtt_get_terminfo} function. + +#%}}} + +\sect{Hints for using SLsmg} + + This section discusses some general design issues that one must face when + writing an application that requires some sort of screen management. + +#%}}} + +\chapter{Signal Functions} #%{{{ + + Almost all non-trivial programs must worry about signals. This is + especially true for programs that use the \slang terminal + input/output and screen management routines. Unfortunately, there is + no fixed way to handle signals; otherwise, the Unix kernel would take + care of all issues regarding signals and the application programmer + would never have to worry about them. For this reason, none of the + routines in the \slang library catch signals; however, some of the + routines block the delivery of signals during crucial moments. It is + up to the application programmer to install handlers for the various + signals of interest. + + For the interpreter, the most important signal to worry about is + \var{SIGINT}. This signal is usually generated when the user presses + \key{Ctrl-C} at the keyboard. The interpreter checks the value of the + \var{SLang_Error} variable to determine whether or not it should abort the + interpreting process and return control back to the application. + This means that if \var{SIGINT} is to be used to abort the interpreter, a + signal handler for \var{SIGINT} should be installed. The handler should + set the value of \var{SLang_Error} to \var{SL_USER_BREAK}. + + Applications that use the \grp{tty} \var{getkey} routines or the screen + management routines must worry about signals such as: +#v+ + SIGINT interrupt + SIGTSTP stop + SIGQUIT quit + SIGTTOU background write + SIGTTIN background read + SIGWINCH window resize +#v- + It is important that handlers be established for these signals while + the either the \var{SLsmg} routines or the \var{getkey} routines are + initialized. The \cfun{SLang_init_tty}, \cfun{SLang_reset_tty}, + \cfun{SLsmg_init_smg}, and \cfun{SLsmg_reset_smg} functions block these + signals from occuring while they are being called. + + Since a signal can be delivered at any time, it is important for the + signal handler to call only functions that can be called from a + signal handler. This usually means that such function must be + re-entrant. In particular, the \var{SLsmg} routines are \em{not} + re-entrant; hence, they should not be called when a signal is being + processed unless the application can ensure that the signal was not + delivered while an \var{SLsmg} function was called. This statement + applies to many other functions such as \var{malloc}, or, more + generally, any function that calls \var{malloc}. The upshot is that + the signal handler should not attempt to do too much except set a + global variable for the application to look at while not in a signal + handler. + + The \slang library provides two functions for blocking and unblocking the + above signals: +#v+ + int SLsig_block_signals (void); + int SLsig_unblock_signals (void); +#v- + It should be noted that for every call to \cfun{SLsig_block_signals}, a + corresponding call should be made to \cfun{SLsig_unblock_signals}, e.g., +#v+ + void update_screen () + { + SLsig_block_signals (); + + /* Call SLsmg functions */ + . + . + SLsig_unblock_signals (); + } +#v- + See \file{demo/pager.c} for examples. + + +#%}}} + +\chapter{Searching Functions} #%{{{ + + The S-Lang library incorporates two types of searches: Regular expression + pattern matching and ordinary searching. + +\sect{Regular Expressions} #%{{{ + + !!! No documentation available yet !!! + +#%}}} + +\sect{Simple Searches} #%{{{ + The routines for ordinary searching are defined in the + \verb{slsearch.c} file. + To use these routines, simply include "slang.h" in your program and simply + call the appropriate routines. + + The searches can go in either a forward or backward direction and can + either be case or case insensitive. The region that is searched may + contain null characters (ASCII 0) however, the search string cannot in the + current implementation. In addition the length of the string to be found + is currently limited to 256 characters. + + Before searching, the function \verb{SLsearch_init} must first be called to + \verb{`preprocess}' the search string. + +#%}}} + +\sect{Initialization} #%{{{ + The function \verb{SLsearch_init} must be called before a search can take place. + Its prototype is: +#v+ + int SLsearch_init (char *key, int dir, int case_sens, SLsearch_Type *st); +#v- + Here \verb{key} is the string to be searched for. \verb{dir} specifies the direction + of the search: a value greater than zero is used for searching forward and + a value less than zero is used for searching backward. The parameter + \verb{case_sens} specifies whether the search is case sensitive or not. A + non-zero value indicates that case is important. \verb{st} is a pointer to a + structure of type \verb{SLsearch_Type} defined in "slang.h". This structure is + initialized by this routine and must be passed to \verb{SLsearch} when the + search is actually performed. + + This routine returns the length of the string to be searched for. + +#%}}} + +\sect{SLsearch} #%{{{ + +#v+ + Prototype: unsigned char *SLsearch (unsigned char *pmin, + unsigned char *pmax, + SLsearch_Type *st); +#v- + + This function performs the search defined by a previous call to + \verb{SLsearch_init} over a region specified by the pointers + \verb{pmin} and \verb{pmax}. + + It returns a pointer to the start of the match if successful or it will + return \verb{NULL} if a match was not found. + + +#%}}} + +#%}}} + +\appendix + +#i copyright.tm + +\end{\documentstyle} diff --git a/libslang/doc/tm/fixtex.sl b/libslang/doc/tm/fixtex.sl new file mode 100644 index 0000000..787eb91 --- /dev/null +++ b/libslang/doc/tm/fixtex.sl @@ -0,0 +1,56 @@ +!if (is_defined ("__argv")) +{ + message ("You need a newer version of jed to run this script"); + quit_jed (); +} + +if (__argc != 4) +{ + message ("Usage: jed -script fixtex.sl "); + quit_jed (); +} + +variable file = __argv[3]; +() = read_file (file); + +% Patch up the >,< signs +bob (); +replace ("$<$", "<"); +replace ("$>$", ">"); + +% It appears that sgml2tex screws up _for in section titles, producing \_{for}. +replace ("ion\\_{", "ion{\\_"); + +% Make the first chapter a preface +bob (); +if (bol_fsearch ("\\chapter{Preface}")) +{ + push_spot (); + push_mark (); + go_right (8); insert ("*"); % \chapter{ --> \chapter*{ + () = bol_fsearch ("\\chapter{"); + push_spot (); + + insert("\\tableofcontents\n"); + eol (); + insert ("\n\\pagenumbering{arabic}"); + + pop_spot (); + narrow (); + bob (); + replace ("\\section{", "\\section*{"); + widen (); + + if (bol_bsearch ("\\tableofcontents")) + delete_line (); + + pop_spot (); + if (bol_bsearch ("\\maketitle")) + insert ("\\pagenumbering{roman}\n"); + +} + +save_buffer (); +quit_jed (); + + diff --git a/libslang/doc/tm/preface.tm b/libslang/doc/tm/preface.tm new file mode 100644 index 0000000..f5d9caa --- /dev/null +++ b/libslang/doc/tm/preface.tm @@ -0,0 +1,95 @@ + +\chapter{Preface} #%{{{ + + \slang is an interpreted language that was designed from the start + to be easily embedded into a program to provide it with a powerful + extension language. Examples of programs that use \slang as an + extension language include the \jed text editor, the \slrn + newsreader, and \sldxe (unreleased), a numerical computation + program. For this reason, \slang does not exist as a separate + application and many of the examples in this document are presented + in the context of one of the above applications. + + \slang is also a programmer's library that permits a programmer to + develop sophisticated platform-independent software. In addition to + providing the \slang extension language, the library provides + facilities for screen management, keymaps, low-level terminal I/O, + etc. However, this document is concerned only with the extension + language and does not address these other features of the \slang + library. For information about the other components of the library, + the reader is referred to the \slang-library-reference. + +\sect{A Brief History of \slang} #%{{{ + + I first began working on \slang sometime during the fall of 1992. + At that time I was writing a text editor (\jed), which I wanted to + endow with a macro language. It occured to me that an + application-independent language that could be embedded into the + editor would prove more useful because I could envision embedding it + into other programs. As a result, \slang was born. + + \slang was originally a stack language that supported a + postscript-like syntax. For that reason, I named it \slang, where + the \em{S} was supposed to emphasize its stack-based nature. About + a year later, I began to work on a preparser that would allow one to + write using a more traditional infix syntax making it easier to use + for those unfamiliar with stack based languages. Currently, the + syntax of the language resembles C, nevertheless some + postscript-like features still remain, e.g., the `\var{%}' character + is still used as a comment delimiter. + +#%}}} + +\sect{Acknowledgements} #%{{{ + + Since I first released \slang, I have received a lot feedback about + the library and the language from many people. This has given me + the opportunity and pleasure to interact with several people to + make the library portable and easy to use. In particular, I would + like to thank the following individuals: + + Luchesar Ionkov \tt{} for his comments and + criticisms of the syntax of the language. He was the person who + made me realize that the low-level byte-code engine should be + totally type-independent. He also improved the tokenizer and + preparser and impressed upon me that the language needed a + grammar. + + Mark Olesen \tt{} for his many patches to + various aspects of the library and his support on AIX. He also + contributed a lot to the pre-processing (\var{SLprep}) routines. + + John Burnell \tt{} for the OS/2 port of the + video and keyboard routines. He also made value suggestions + regarding the interpreter interface. + + Darrel Hankerson \tt{} for cleaning up and + unifying some of the code and the makefiles. + + Dominik Wujastyk \tt{} who was always willing to test + new releases of the library. + + Michael Elkins \tt{} for his work on the curses + emulation. + + Ulli Horlacher \tt{} and Oezguer Kesim + \tt{} for the \slang newsgroup and mailing list. + + Hunter Goatley, Andy Harper \tt{}, and Martin + P.J. Zinser \tt{} for their VMS support. + + Dave Sims \tt{} and Chin Huang + \tt{} for Windows 95 and Windows NT support. + + Lloyd Zusman \tt{} and Rich Roth \tt{} + for creating and maintaining \tt{www.s-lang.org}. + + I am also grateful to many other people who send in bug-reports and + bug-fixes, for without such community involvement, \slang would not + be as well-tested and stable as it is. Finally, I would like to + thank my wife for her support and understanding while I spent long + weekend hours developing the library. + +#%}}} + +#%}}} diff --git a/libslang/doc/tm/regexp.tm b/libslang/doc/tm/regexp.tm new file mode 100644 index 0000000..7874b49 --- /dev/null +++ b/libslang/doc/tm/regexp.tm @@ -0,0 +1,98 @@ +\chapter{Regular Expressions} + + The S-Lang library includes a regular expression (RE) package that + may be used by an application embedding the library. The RE syntax + should be familiar to anyone acquainted with regular expressions. In + this section the syntax of the \slang regular expressions is + discussed. + +\sect{\slang RE Syntax} + + A regular expression specifies a pattern to be matched against a + string, and has the property that the contcatenation of two REs is + also a RE. + + The \slang library supports the following standard regular + expressions: +#v+ + . match any character except newline + * matches zero or more occurences of previous RE + + matches one or more occurences of previous RE + ? matches zero or one occurence of previous RE + ^ matches beginning of a line + $ matches end of line + [ ... ] matches any single character between brackets. + For example, [-02468] matches `-' or any even digit. + and [-0-9a-z] matches `-' and any digit between 0 and 9 + as well as letters a through z. + \< Match the beginning of a word. + \> Match the end of a word. + \( ... \) + \1, \2, ..., \9 Matches the match specified by nth \( ... \) + expression. +#v- + In addition the following extensions are also supported: +#v+ + \c turn on case-sensitivity (default) + \C turn off case-sensitivity + \d match any digit + \e match ESC char +#v- +Here are some simple examples: + + \exmp{"^int "} matches the \exmp{"int "} at the beginning of a line. + + \exmp{"\\"} matches \exmp{"money"} but only if it appears + as a separate word. + + \exmp{"^$"} matches an empty line. + + A more complex pattern is +#v+ + "\(\<[a-zA-Z]+\>\)[ ]+\1\>" +#v- + which matches any word repeated consecutively. Note how the grouping + operators \exmp{\\(} and \exmp{\\)} are used to define the text + matched by the enclosed regular expression, and then subsequently + referred to \exmp{\\1}. + + Finally, remember that when used in string literals either in the + \slang language or in the C language, care must be taken to + "double-up" the \exmp{'\\'} character since both languages treat it + as an escape character. + +\sect{Differences between \slang and egrep REs} + + There are several differences between \slang regular expressions and, + e.g., \bf{egrep} regular expressions. + + The most notable difference is that the \slang regular expressions do + not support the \bf{OR} operator \exmp{|} in expressions. This means + that \exmp{"a|b"} or \exmp{"a\\|b"} do not have the meaning that they + have in regular expression packages that support egrep-style + expressions. + + The other main difference is that while \slang regular expressions + support the grouping operators \exmp{\\(} and \exmp{\\)}, they are + only used as a means of specifying the text that is matched. That + is, the expression +#v+ + "@\([a-z]*\)@.*@\1@" +#v- + matches \exmp{"xxx@abc@silly@abc@yyy"}, where the pattern \exmp{\\1} + matches the text enclosed by the \exmp{\\(} and \exmp{\\)} + expressions. However, in the current implementation, the grouping + operators are not used to group regular expressions to form a single + regular expression. Thus expression such as \exmp{"\\(hello\\)*"} is + \em{not} a pattern to match zero or more occurances of \exmp{"hello"} + as it is in e.g., \bf{egrep}. + + One question that comes up from time to time is why doesn't \slang + simply employ some posix-compatible regular expression library. The + simple answer is that, at the time of this writing, none exists that + is available across all the platforms that the \slang library + supports (Unix, VMS, OS/2, win32, win16, BEOS, MSDOS, and QNX) and + can be distributed under both the GNU and Artistic licenses. It is + particularly important that the library and the interpreter support a + common set of regular expressions in a platform independent manner. + diff --git a/libslang/doc/tm/rtl/array.tm b/libslang/doc/tm/rtl/array.tm new file mode 100644 index 0000000..7f55ba3 --- /dev/null +++ b/libslang/doc/tm/rtl/array.tm @@ -0,0 +1,378 @@ +\function{_isnull} +\synopsis{Check array for NULL elements} +\usage{Char_Type[] = _isnull (a[])} +\description + This function may be used to test for the presence of NULL elements + of an array. Specifically, it returns a \var{Char_Type} array of + with the same number of elements and dimensionality of the input + array. If an element of the input array is \NULL, then the + corresponding element of the output array will be set to \1, + otherwise it will be set to \0. +\example + Set all \NULL elements of a string array \exmp{A} to the empty + string \exmp{""}: +#v+ + A[where(_isnull(A))] = ""; +#v- +\notes + It is important to understand the difference between \exmp{A==NULL} + and \exmp{_isnull(A)}. The latter tests all elements of \exmp{A} + against \NULL, whereas the former only tests \exmp{A} itself. +\seealso{where, array_map} +\done + +\function{_reshape} +\synopsis{Copy an array to a new shape} +\usage{Array_Type _reshape (Array_Type A, Array_Type I)} +\description + The \var{_reshape} function creates a copy of an array \var{A}, + reshapes it to the form specified by \var{I} and returns the result. + The elements of \var{I} specify the new dimensions of the copy of + \var{A} and must be consistent with the number of elements \var{A}. +\example + If \var{A} is a \var{100} element 1-d array, a new array 2-d array of + size \var{20} by \var{5} may be created from the elements of \var{A} + by +#v+ + A = _reshape (A, [20, 5]); +#v- + In this example, the original array was no longer needed. Hence, it + is preferable to make use of the \var{__tmp} operator to avoid the + creation of a new array, i.e., +#v+ + A = _reshape (__tmp(A), [20,5]); +#v- +\notes + The \var{reshape} function performs a similar function to + \var{_reshape}. In fact, the \var{_reshape} function could have been + implemented via: +#v+ + define _reshape (a, i) + { + a = @a; % Make a new copy + reshape (a, i); + return a; + } +#v- +\seealso{reshape, array_info} +\done + +\function{array_info} +\synopsis{Returns information about an array} +\usage{(Array_Type, Integer_Type, DataType_Type) array_info (Array_Type a)} +\description + The \var{array_info} function returns information about the array \var{a}. + It returns three values: an 1-d integer array specifying the + size of each dimension of \var{a}, the number of dimensions of + \var{a}, and the data type of \var{a}. +\example + The \var{array_info} function may be used to find the number of rows + of an array: +#v+ + define num_rows (a) + { + variable dims, num_dims, data_type; + + (dims, num_dims, data_type) = array_info (a); + return dims [0]; + } +#v- + For 1-d arrays, this information is more easily obtained from the + \var{length} function. +\seealso{typeof, reshape, length, _reshape} +\done + +\function{array_map} +\synopsis{Apply a function to each element of an array} +\usage{Array_Type array_map (type, func, arg0, ...)} +#v+ + DataType_Type type; + Ref_Type func; +#v- +\description + The \var{array_map} function may be used to apply a function to each + element of an array and returns the result as an array of a + specified type. The \var{type} parameter indicates what kind of + array should be returned and generally corresponds to the return + type of the function. The \var{arg0} parameter should be an array + and is used to determine the dimensions of the resulting array. If + any subsequent arguments correspond to an array of the same size, + then those array elements will be passed in parallel with the first + arrays arguments. +\example + The first example illustrates how to apply the \var{strlen} function + to an array of strings: +#v+ + S = ["", "Train", "Subway", "Car"]; + L = array_map (Integer_Type, &strlen, S); +#v- + This is equivalent to: +#v+ + S = ["", "Train", "Subway", "Car"]; + L = Integer_Type [length (S)]; + for (i = 0; i < length (S); i++) L[i] = strlen (S[i]); +#v- + + Now consider an example involving the \var{strcat} function: +#v+ + files = ["slang", "slstring", "slarray"]; + + exts = ".c"; + cfiles = array_map (String_Type, &strcat, files, exts); + % ==> cfiles = ["slang.c slstring.c slarray.c"]; + + exts = [".a",".b",".c"]; + xfiles = array_map (String_Type, &strcat, files, exts); + % ==> xfiles = ["slang.a", "slstring.b", "slarray.c"]; +#v- +\notes + Many mathemetical functions already work transparantly on arrays. + For example, the following two statements produce identical results: +#v+ + B = sin (A); + B = array_map (Double_Type, &sin, A); +#v- +\seealso{array_info, strlen, strcat, sin} +\done + +\function{array_sort} +\synopsis{Sort an array} +\usage{Array_Type array_sort (Array_Type a [, String_Type or Ref_Type f])} +\description + \var{array_sort} sorts the array \var{a} into ascending order and + returns an integer array that represents the result of the sort. If + the optional second parameter \var{f} is present, the function + specified by \var{f} will be used to compare elements of \var{a}; + otherwise, a built-in sorting function will be used. + + If \var{f} is present, then it must be either a string representing + the name of the comparison function, or a reference to the function. + The sort function represented by \var{f} must be a \slang + user-defined function that takes two arguments. The function must + return an integer that is less than zero if the first parameter is + considered to be less than the second, zero if they are equal, and a + value greater than zero if the first is greater than the second. + + If the comparision function is not specified, then a built-in comparison + function appropriate for the data type will be used. For example, + if \var{a} is an array of character strings, then the sort will be + preformed using \var{strcmp}. + + The integer array returned by this function is simply an index that + indicates the order of the sorted array. The input array \var{a} is + not changed. +\example + An array of strings may be sorted using the \var{strcmp} function + since it fits the specification for the sorting function described + above: +#v+ + variable A = String_Type [3]; + A[0] = "gamma"; A[1] = "alpha"; A[2] = "beta"; + + variable I = array_sort (A, &strcmp); +#v- + Alternatively, one may use +#v+ + variable I = array_sort (A); +#v- + to use the built-in comparison function. + + After the \var{array_sort} has executed, the variable \var{I} will + have the values \exmp{[2, 0, 1]}. This array can be used to + re-shuffle the elements of \var{A} into the sorted order via the + array index expression \exmp{A = A[I]}. +\seealso{strcmp} +\done + +\function{cumsum} +\synopsis{Compute the cumulative sum of an array} +\usage{result = cumsum (Array_Type a [, Int_Type dim])} +\description + The \var{cumsum} function performs a cumulative sum over the + elements of a numeric array and returns the resulting. If a second + argument is given, then it specifies the dimension of the array to + be summed over. For example, the cumulative sum of + \exmp{[1,2,3,4]}, is the array \exmp{[1,1+2,1+2+3,1+2+3+4]}, i.e., + \exmp{[1,3,6,10]}. +\seealso{sum} +\done + +\function{init_char_array} +\synopsis{Initialize an array of characters} +\usage{init_char_array (Array_Type a, String_Type s)} +\description + The \var{init_char_array} function may be used to initialize a + character array \var{a} by setting the elements of the array + \var{a} to the corresponding characters of the string \var{s}. +\example + The statements +#v+ + variable a = Char_Type [10]; + init_char_array (a, "HelloWorld"); +#v- + creates an character array and initializes its elements to the + characters in the string \exmp{"HelloWorld"}. +\notes + The character array must be large enough to hold all the characters + of the initialization string. +\seealso{bstring_to_array, strlen, strcat} +\done + +\function{length} +\synopsis{Get the length of an object} +\usage{Integer_Type length (obj)} +\description + The \var{length} function may be used to get information about the + length of an object. For simple scalar data-types, it returns \1. + For arrays, it returns the total number of elements of the array. +\notes + If \var{obj} is a string, \var{length} returns \1 because a + \var{String_Type} object is considered to be a scalar. To get the + number of characters in a string, use the \var{strlen} function. +\seealso{array_info, typeof, strlen} +\done + +\function{max} +\synopsis{Get the maximum value of an array} +\usage{result = max (Array_Type a [,Int_Type dim])} +\description + The \var{max} function examines the elements of a numeric array and + returns the value of the largest element. If a second argument is + given, then it specifies the dimension of the array to be searched. + In this case, an array of dimension one less than that of the input array + will be returned with the corresponding elements in the specified + dimension replaced by the minimum value in that dimension. +\example + Consider the 2-d array +#v+ + 1 2 3 4 5 + 6 7 8 9 10 +#v- + generated by +#v+ + a = _reshape ([1:10], [2, 5]); +#v- + Then \exmp{max(a)} will return \exmp{10}, and \exmp{max(a,0)} will return + a 1-d array with elements +#v+ + 6 7 8 9 10 +#v- +\seealso{max, sum, reshape} +\done + +\function{min} +\synopsis{Get the minimum value of an array} +\usage{result = min (Array_Type a [,Int_Type dim])} +\description + The \var{min} function examines the elements of a numeric array and + returns the value of the smallest element. If a second argument is + given, then it specifies the dimension of the array to be searched. + In this case, an array of dimension one less than that of the input array + will be returned with the corresponding elements in the specified + dimension replaced by the minimum value in that dimension. +\example + Consider the 2-d array +#v+ + 1 2 3 4 5 + 6 7 8 9 10 +#v- + generated by +#v+ + a = _reshape ([1:10], [2, 5]); +#v- + Then \exmp{min(a)} will return \exmp{1}, and \exmp{min(a,0)} will return + a 1-d array with elements +#v+ + 1 2 3 4 5 +#v- +\seealso{max, sum, reshape} +\done + +\function{reshape} +\synopsis{Reshape an array} +\usage{reshape (Array_Type A, Array_Type I)} +\description + The \var{reshape} function changes the size of \var{A} to have the size + specified by the 1-d integer array \var{I}. The elements of \var{I} + specify the new dimensions of \var{A} and must be consistent with + the number of elements \var{A}. +\example + If \var{A} is a \var{100} element 1-d array, it can be changed to a + 2-d \var{20} by \var{5} array via +#v+ + reshape (A, [20, 5]); +#v- + However, \exmp{reshape(A, [11,5])} will result in an error because + the \exmp{[11,5]} array specifies \exmp{55} elements. +\notes + Since \var{reshape} modifies the shape of an array, and arrays are + treated as references, then all references to the array will + reference the new shape. If this effect is unwanted, then use the + \var{_reshape} function instead. +\seealso{_reshape, array_info} +\done + +\function{sum} +\synopsis{Sum over the elements of an array} +\usage{result = sum (Array_Type a [, Int_Type dim])} +\description + The \var{sum} function sums over the elements of a numeric array and + returns its result. If a second argument is given, then it + specifies the dimension of the array to be summed over. In this + case, an array of dimension one less than that of the input array + will be returned. + + If the input array is an integer type, then the resulting value will + be a \var{Double_Type}. If the input array is a \var{Float_Type}, + then the result will be a \var{Float_Type}. +\example + The mean of an array \exmp{a} of numbers is +#v+ + sum(a)/length(a) +#v- +\seealso{cumsum, transpose, reshape} +\done + +\function{transpose} +\synopsis{Transpose an array} +\usage{Array_Type transpose (Array_Type a)} +\description + The \var{transpose} function returns the transpose of a specified + array. By definition, the transpose of an array, say one with + elements \exmp{a[i,j,...k]} is an array whose elements are + \exmp{a[k,...,j,i]}. +\seealso{_reshape, reshape, sum, array_info} +\done + +\function{where} +\synopsis{Get indices where an integer array is non-zero} +\usage{Array_Type where (Array_Type a)} +\description + The \var{where} function examines an numeric array \var{a} and + returns an integer array giving the indices of \var{a} + where the corresponding element of \var{a} is non-zero. + + Although this function may appear to be simple or even trivial, it + is arguably one of the most important and powerful functions for + manipulating arrays. +\example + Consider the following: +#v+ + variable X = [0.0:10.0:0.01]; + variable A = sin (X); + variable I = where (A < 0.0); + A[I] = cos (X) [I]; +#v- + Here the variable \var{X} has been assigned an array of doubles + whose elements range from \exmp{0.0} through \exmp{10.0} in + increments of \var{0.01}. The second statement assigns \var{A} to + an array whose elements are the \var{sin} of the elements of \var{X}. + The third statement uses the where function to get the indices of + the elements of \var{A} that are less than \var{0.0}. Finally, the + last statement substitutes into \var{A} the \var{cos} of the + elements of \var{X} at the positions of \var{A} where the + corresponding \var{sin} is less than \var{0}. The end result is + that the elements of \var{A} are a mixture of sines and cosines. +\seealso{array_info, sin, cos} +\done + diff --git a/libslang/doc/tm/rtl/assoc.tm b/libslang/doc/tm/rtl/assoc.tm new file mode 100644 index 0000000..e5f0dc6 --- /dev/null +++ b/libslang/doc/tm/rtl/assoc.tm @@ -0,0 +1,76 @@ +\function{assoc_delete_key} +\synopsis{Delete a key from an Associative Array} +\usage{assoc_delete_key (Assoc_Type a, String_Type k)} +\description + The \var{assoc_delete_key} function deletes a key given by \var{k} + from the associative array \var{a}. If the specified key does not + exist in \var{a}, then this function has no effect. +\seealso{assoc_key_exists, assoc_get_keys} +\done + +\function{assoc_get_keys} +\synopsis{Return all the key names of an Associative Array} +\usage{String_Type[] assoc_get_keys (Assoc_Type a)} +\description + This function returns all the key names of an associative array + \var{a} as an ordinary one dimensional array of strings. If the + associative array contains no keys, an empty array will be returned. +\example + The following function computes the number of keys in an associative + array: +#v+ + define get_num_elements (a) + { + return length (assoc_get_keys (a)); + } +#v- +\seealso{assoc_get_values, assoc_key_exists, assoc_delete_key, length} +\done + +\function{assoc_get_values} +\synopsis{Return all the values of an Associative Array} +\usage{Array_Type assoc_get_keys (Assoc_Type a)} +\description + This function returns all the values in the associative array + \var{a} as an array of proper type. If the associative array + contains no keys, an empty array will be returned. +\example + Suppose that \var{a} is an associative array of type + \var{Integer_Type}, i.e., it was created via +#v+ + variable a = Assoc_Type[Integer_Type]; +#v- + The the following may be used to print the values of the array in + ascending order: +#v+ + static define int_sort_fun (x, y) + { + return sign (x - y); + } + define sort_and_print_values (a) + { + variable i, v; + + v = assoc_get_values (a); + i = array_sort (v, &int_sort_fun); + v = v[i]; + foreach (v) + { + variable vi = (); + () = fprintf (stdout, "%d\n", vi); + } + } +#v- +\seealso{assoc_get_values, assoc_key_exists, assoc_delete_key, array_sort} +\done + +\function{assoc_key_exists} +\synopsis{Check to see whether a key exists in an Associative Array} +\usage{Integer_Type assoc_key_exists (Assoc_Type a, String_Type k)} +\description + The \var{assoc_key_exists} function may be used to determine whether + or not a specified key \var{k} exists in an associative array \var{a}. + It returns \1 if the key exists, or \0 if it does not. +\seealso{assoc_get_keys, assoc_get_values, assoc_delete_key} +\done + diff --git a/libslang/doc/tm/rtl/bstr.tm b/libslang/doc/tm/rtl/bstr.tm new file mode 100644 index 0000000..ffe2825 --- /dev/null +++ b/libslang/doc/tm/rtl/bstr.tm @@ -0,0 +1,151 @@ +\function{array_to_bstring} +\synopsis{Convert an array to a binary string} +\usage{BString_Type array_to_bstring (Array_Type a)} +\description + The \var{array_to_bstring} function returns the elements of an + array \var{a} as a binary string. +\seealso{bstring_to_array, init_char_array} +\done + +\function{bstring_to_array} +\synopsis{Convert a binary string to an array of characters} +\usage{UChar_Type[] bstring_to_array (BString_Type b)} +\description + The \var{bstring_to_array} function returns an array of unsigned + characters whose elements correspond to the characters in the + binary string. +\seealso{array_to_bstring, init_char_array} +\done + +\function{bstrlen} +\synopsis{Get the length of a binary string} +\usage{UInt_Type bstrlen (BString_Type s)} +\description + The \var{bstrlen} function may be used to obtain the length of a + binary string. A binary string differs from an ordinary string (a C + string) in that a binary string may include null chracters. +\example +#v+ + variable s = "hello\0"; + len = bstrlen (s); % ==> len = 6 + len = strlen (s); % ==> len = 5 +#v- +\seealso{strlen, length} +\done + +\function{pack} +\synopsis{Pack objects into a binary string} +\usage{BString_Type pack (String_Type fmt, ...)} +\description + The \var{pack} function combines zero or more the objects (represented + by the ellipses above) into a binary string acording to the format + string \var{fmt}. + + The format string consists of one or more data-type specification + characters, and each may be followed by an optional decimal length + specifier. Specifically, the data-types are specified according to + the following table: +#v+ + c char + C unsigned char + h short + H unsigned short + i int + I unsigned int + l long + L unsigned long + j 16 bit int + J 16 unsigned int + k 32 bit int + K 32 bit unsigned int + f float + d double + F 32 bit float + D 64 bit float + s character string, null padded + S character string, space padded + x a null pad character +#v- + A decimal length specifier may follow the data-type specifier. With + the exception of the \var{s} and \var{S} specifiers, the length + specifier indicates how many objects of that data type are to be + packed or unpacked from the string. When used with the \var{s} or + \var{S} specifiers, it indicates the field width to be used. If the + length specifier is not present, the length defaults to one. + + With the exception of \var{c}, \var{C}, \var{s}, \var{S}, and + \var{x}, each of these may be prefixed by a character that indicates + the byte-order of the object: +#v+ + > big-endian order (network order) + < little-endian order + = native byte-order +#v- + The default is to use native byte order. + + When unpacking via the \var{unpack} function, if the length + specifier is greater than one, then an array of that length will be + returned. In addition, trailing whitespace and null character are + stripped when unpacking an object given by the \var{S} specifier. +\example +#v+ + a = pack ("cc", 'A', 'B'); % ==> a = "AB"; + a = pack ("c2", 'A', 'B'); % ==> a = "AB"; + a = pack ("xxcxxc", 'A', 'B'); % ==> a = "\0\0A\0\0B"; + a = pack ("h2", 'A', 'B'); % ==> a = "\0A\0B" or "\0B\0A" + a = pack (">h2", 'A', 'B'); % ==> a = "\0\xA\0\xB" + a = pack (" a = "\0B\0A" + a = pack ("s4", "AB", "CD"); % ==> a = "AB\0\0" + a = pack ("s4s2", "AB", "CD"); % ==> a = "AB\0\0CD" + a = pack ("S4", "AB", "CD"); % ==> a = "AB " + a = pack ("S4S2", "AB", "CD"); % ==> a = "AB CD" +#v- +\seealso{unpack, sizeof_pack, pad_pack_format, sprintf} +\done + +\function{pad_pack_format} +\synopsis{Add padding to a pack format} +\usage{BString_Type pad_pack_format (String_Type fmt)} +\description + The \var{pad_pack_format} function may be used to add the + appropriate padding to the format \var{fmt} such that the data types + specified by the format will be properly aligned for the system. + This is especially important when reading or writing files that + assume the native alignment. + + See the S-Lang User's Guide for more information about the use of + this function. +\seealso{pack, unpack, sizeof_pack} +\done + +\function{sizeof_pack} +\synopsis{Compute the size implied by a pack format string} +\usage{UInt_Type sizeof_pack (String_Type fmt)} +\description + The \var{sizeof_pack} function returns the size of the binary string + represented by the format string \var{fmt}. This information may be + needed when reading a structure from a file. +\notes +\seealso{pack, unpack, pad_pack_format} +\done + +\function{unpack} +\synopsis{Unpack Objects from a Binary String} +\usage{(...) = unpack (String_Type fmt, BString_Type s)} +\description + The \var{unpack} function unpacks objects from a binary string + \var{s} according to the format \var{fmt} and returns the objects to + the stack in the order in which they were unpacked. See the + documentation of the \var{pack} function for details about the + format string. +\example +#v+ + (x,y) = unpack ("cc", "AB"); % ==> x = 'A', y = 'B' + x = unpack ("c2", "AB"); % ==> x = ['A', 'B'] + x = unpack ("x x = 0xCDABuh + x = unpack ("xxs4", "a b c\0d e f"); % ==> x = "b c\0" + x = unpack ("xxS4", "a b c\0d e f"); % ==> x = "b c" +#v- +\seealso{pack, sizeof_pack, pad_pack_format} +\done + diff --git a/libslang/doc/tm/rtl/debug.tm b/libslang/doc/tm/rtl/debug.tm new file mode 100644 index 0000000..682c4b8 --- /dev/null +++ b/libslang/doc/tm/rtl/debug.tm @@ -0,0 +1,98 @@ +\function{_clear_error} +\synopsis{Clear an error condition} +\usage{_clear_error ()} +\description + This function may be used in error-blocks to clear the error that + triggered execution of the error block. Execution resumes following + the statement, in the scope of the error-block, that triggered the + error. +\example + Consider the following wrapper around the \var{putenv} function: +#v+ + define try_putenv (name, value) + { + variable status; + ERROR_BLOCK + { + _clear_error (); + status = -1; + } + status = 0; + putenv (sprintf ("%s=%s", name, value); + return status; + } +#v- + If \var{putenv} fails, it generates an error condition, which the + \var{try_putenv} function catches and clears. Thus \var{try_putenv} + is a function that returns \exmp{-1} upon failure and \var{0} upon + success. +\seealso{_trace_function, _slangtrace, _traceback} +\done + +\variable{_debug_info} +\synopsis{Configure debugging information} +\usage{Integer_Type _debug_info} +\description + The \var{_debug_info} variable controls whether or not extra code + should be generated for additional debugging and traceback + information. Currently, if \var{_debug_info} is zero, no extra code + will be generated; otherwise extra code will be inserted into the + compiled bytecode for additional debugging data. + + The value of this variable is local to each compilation unit and + setting its value in one unit has no effect upon its value in other + units. +\example +#v+ + _debug_info = 1; % Enable debugging information +#v- +\notes + Setting this variable to a non-zero value may slow down the + interpreter somewhat. +\seealso{_traceback, _slangtrace} +\done + +\variable{_slangtrace} +\synopsis{Turn function tracing on or off.} +\usage{Integer_Type _slangtrace} +\description + The \var{_slangtrace} variable is a debugging aid that when set to a + non-zero value enables tracing when function declared by + \var{_trace_function} is entered. If the value is greater than + zero, both intrinsic and user defined functions will get traced. + However, if set to a value less than zero, intrinsic functions will + not get traced. +\seealso{_trace_function, _traceback, _print_stack} +\done + +\function{_trace_function} +\synopsis{Set the function to trace} +\usage{_trace_function (String_Type f)} +\description + \var{_trace_function} declares that the \slang function with name + \var{f} is to be traced when it is called. Calling + \var{_trace_function} does not in itself turn tracing on. Tracing + is turned on only when the variable \var{_slangtrace} is non-zero. +\seealso{_slangtrace, _traceback} +\done + +\variable{_traceback} +\synopsis{Generate a traceback upon error} +\usage{Integer_Type _traceback} +\description + \var{_traceback} is an intrinsic integer variable whose value + controls whether or not a traceback of the call stack is to be + generated upon error. If \var{_traceback} is greater than zero, a + full traceback will be generated, which includes the values of local + variables. If the value is less than zero, a traceback will be + generated without local variable information, and if + \var{_traceback} is zero the traceback will not be generated. + + Local variables are represented in the form \var{$n} where \var{n} is an + integer numbered from zero. More explicitly, \var{$0} represents the + first local variable, \var{$1} represents the second, and so on. + Please note that function parameters are local variables and that the + first parameter corresponds to \var{$0}. +\seealso{_slangtrace, error} +\done + diff --git a/libslang/doc/tm/rtl/dir.tm b/libslang/doc/tm/rtl/dir.tm new file mode 100644 index 0000000..a25fc86 --- /dev/null +++ b/libslang/doc/tm/rtl/dir.tm @@ -0,0 +1,223 @@ +\function{chdir} +\synopsis{Change the current working directory.} +\usage{Integer_Type chdir (String_Type dir)} +\description + The \var{chdir} function may be used to changed the current working + directory to the directory specified by \var{dir}. Upon success it + returns zero; however, upon failure it returns \exmp{-1} and sets + \var{errno} accordingly. +\seealso{mkdir, stat_file} +\done + +\function{chmod} +\synopsis{Change the mode of a file} +\usage{Integer_Type chmod (String_Type file, Integer_Type mode)} +\description + The \var{chmod} function changes the permissions of \var{file} to those + specified by \var{mode}. It returns \exmp{0} upon success, or + \exmp{-1} upon failure setting \var{errno} accordingly. + + See the system specific documentation for the C library + function \var{chmod} for a discussion of the \var{mode} parameter. +\seealso{chown, stat_file} +\done + +\function{chown} +\synopsis{Change the owner of a file} +\usage{Integer_Type chown (String_Type file, Integer_Type uid, Integer_Type gid)} +\description + The \var{chown} function is used to change the user-id and group-id of + \var{file} to \var{uid} and \var{gid}, respectively. It returns + \var{zero} upon success and \exmp{-1} upon failure, with \var{errno} + set accordingly. +\notes + On most systems, only the super user can change the ownership of a + file. + + Some systems do not support this function. +\seealso{chmod, stat_file} +\done + +\function{getcwd} +\synopsis{Get the current working directory} +\usage{String_Type getcwd ()} +\description + The \var{getcwd} function returns the absolute pathname of the + current working directory. If an error occurs or it cannot + determine the working directory, it returns \var{NULL} and sets + \var{errno} accordingly. +\notes + Under Unix, OS/2, and MSDOS, the pathname returned by this function + includes the trailing slash character. Some versions also include + the drive specifier. +\seealso{mkdir, chdir, errno} +\done + +\function{listdir} +\synopsis{Get a list of the files in a directory} +\usage{String_Type[] listdir (String_Type dir)} +\description + The \var{listdir} function returns the directory listing of all the + files in the specified directory \var{dir} as an array of strings. + It does not return the special files \exmp{".."} and \exmp{"."} as + part of the list. +\seealso{stat_file, stat_is, length} +\done + +\function{lstat_file} +\synopsis{Get information about a symbolic link} +\usage{Struct_Type lstat_file (String_Type file)} +\description + The \var{lstat_file} function behaves identically to \var{stat_file} + but if \var{file} is a symbolic link, \var{lstat_file} returns + information about the link itself, and not the file that it + references. + + See the documentation for \var{stat_file} for more information. +\notes + On systems that do not support symbolic links, there is no + difference between this function and the \var{stat_file} function. +\seealso{stat_file, readlink} +\done + +\function{mkdir} +\synopsis{Create a new directory} +\usage{Integer_Type mkdir (String_Type dir, Integer_Type mode)} +\description + The \var{mkdir} function creates a directory whose name is specified + by the \var{dir} parameter with permissions specified by \var{mode}. + Upon success \var{mkdir} returns zero, or it returns \exmp{-1} and + sets \var{errno} accordingly. In particular, if the directory + already exists, the function will fail and set errno to + \var{EEXIST}. +\example +#v+ + define my_mkdir (dir) + { + if (0 == mkdir (dir, 0777)) return; + if (errno == EEXIST) return; + verror ("mkdir %s failed: %s", dir, errno_string (errno)); + } +#v- +\notes + The \var{mode} parameter may not be meaningful on all systems. On + systems where it is meaningful, the actual permissions on the newly + created directory are modified by the process's umask. +\seealso{rmdir, getcwd, chdir, fopen, errno} +\done + +\function{readlink} +\synopsis{String_Type readlink (String_Type path)} +\usage{Get the value of a symbolic link} +\description + The \var{readlink} function returns the value of a symbolic link and + returns it as a string. Upon failure, \NULL is returned and + \var{errno} set accordingly. +\notes + Not all systems support this function. +\seealso{lstat_file, stat_file, stat_is} +\done + +\function{remove} +\synopsis{Delete a file} +\usage{Integer_Type remove (String_Type file)} +\description + The \var{remove} function deletes a file. It returns \0 upon + success, or \-1 upon error and sets \var{errno} accordingly. +\seealso{rename, rmdir} +\done + +\function{rename} +\synopsis{Rename a file} +\usage{Integer_Type rename (String_Type old, String_Type new)} +\description + The \var{rename} function renames a file from \var{old} to \var{new} + moving it between directories if necessary. This function may fail + if the directories do not refer to the same file system. It returns + \0 upon success, or \-1 upon error and sets \var{errno} accordingly. +\seealso{remove, errno} +\done + +\function{rmdir} +\synopsis{Remove a directory} +\usage{Integer_Type rmdir (String_Type dir)} +\description + The \var{rmdir} function deletes a specified directory. It returns + \0 upon success or \-1 upon error and sets \var{errno} accordingly. +\notes + The directory must be empty before it can be removed. +\seealso{rename, remove, mkdir} +\done + +\function{stat_file} +\synopsis{Get information about a file} +\usage{Struct_Type stat_file (String_Type file)} +\description + The \var{stat_file} function returns information about \var{file} + through the use of the system \var{stat} call. If the stat call + fails, the function returns \var{NULL} and sets errno accordingly. + If it is successful, it returns a stat structure with the following + integer fields: +#v+ + st_dev + st_ino + st_mode + st_nlink + st_uid + st_gid + st_rdev + st_size + st_atime + st_mtime + st_ctime +#v- + See the man page for \var{stat} for a discussion of these fields. +\example + The following example shows how the \var{stat_file} function may be + used to get the size of a file: +#v+ + define file_size (file) + { + variable st; + st = stat_file(file); + if (st == NULL) verror ("Unable to stat %s", file); + return st.st_size; + } +#v- +\seealso{lstat_file, stat_is} +\done + +\function{stat_is} +\synopsis{Parse the \var{st_mode} field of a stat structure} +\usage{Char_Type stat_is (String_Type type, Integer_Type st_mode)} +\description + The \var{stat_is} function returns a signed character value about + the type of file specified by \var{st_mode}. Specifically, + \var{type} must be one of the strings: +#v+ + "sock" (socket) + "fifo" (fifo) + "blk" (block device) + "chr" (character device) + "reg" (regular file) + "lnk" (link) + "dir" (dir) +#v- + It returns a non-zero value if \var{st_mode} corresponds to + \var{type}. +\example + The following example illustrates how to use the \var{stat_is} + function to determine whether or not a file is a directory: +#v+ + define is_directory (file) + { + variable st; + + st = stat_file (file); + if (st == NULL) return 0; + return stat_is ("dir", st.st_mode); + } +#v- +\seealso{stat_file, lstat_file} +\done + diff --git a/libslang/doc/tm/rtl/eval.tm b/libslang/doc/tm/rtl/eval.tm new file mode 100644 index 0000000..3c1e66c --- /dev/null +++ b/libslang/doc/tm/rtl/eval.tm @@ -0,0 +1,119 @@ +\function{autoload} +\synopsis{Load a function from a file} +\usage{autoload (String_Type funct, String_Type file)} +\description + The \var{autoload} function is used to declare \var{funct} to the + interpreter and indicate that it should be loaded from \var{file} when + it is actually used. +\example + Suppose \var{bessel_j0} is a function defined in the file + \var{bessel.sl}. Then the statement +#v+ + autoload ("bessel_j0", "bessel.sl"); +#v- + will cause \var{bessel.sl} to be loaded prior to the execution of + \var{bessel_j0} +\seealso{evalfile} +\done + +\function{byte_compile_file} +\synopsis{Compile a file to byte-code for faster loading.} +\usage{byte_compile_file (String_Type file, Integer_Type method)} +\description + The \var{byte_compile_file} function byte-compiles \var{file} + producing a new file with the same name except a \var{'c'} is added + to the output file name. For example, \var{file} is + \exmp{"site.sl"}, then the function produces a new file named + \exmp{site.slc}. +\notes + The \var{method} parameter is not used in the current + implementation. Its use is reserved for the future. For now, set + it to \exmp{0}. +\seealso{evalfile} +\done + +\function{eval} +\synopsis{Interpret a string as \slang code} +\usage{eval (String_Type expression, [,String_Type namespace])} +\description + The \var{eval} function parses a string as S-Lang code and executes the + result. If called with the optional namespace argument, then the + string will be evaluated in the specified namespace. + + This is a useful function in many contexts such as dynamically + generating function definitions where there is no way to generate + them otherwise. +\example +#v+ + if (0 == is_defined ("my_function")) + eval ("define my_function () { message (\"my_function\"); }"); +#v- +\seealso{is_defined, autoload, evalfile} +\done + +\function{evalfile} +\synopsis{Interpret a file containing \slang code.} +\usage{Integer_Type evalfile (String_Type file, [,String_Type namespace])} +\description + The \var{evalfile} function loads \var{file} into the interpreter + and executes it. If called with the optional namespace argument, + the file will be loaded into the specified namespace, which will be + created if necessary. If no errors were encountered, \exmp{1} will + be returned; otherwise, a \slang error will be generated and the + function will return zero. +\example +#v+ + define load_file (file) + { + ERROR_BLOCK { _clear_error (); } + () = evalfile (file); + } +#v- +\notes + For historical reasons, the return value of this function is not + really useful. + + The file is searched along an application-defined load-path. The + \ifun{get_slang_load_path} and \ifun{set_slang_load_path} functions + may be used to set and query the path. +\seealso{eval, autoload, set_slang_load_path, get_slang_load_path} +\done + +\function{get_slang_load_path} +\synopsis{Get the value of the interpreter's load-path} +\usage{String_Type get_slang_load_path ()} +\description + This function retrieves the value of the delimiter-separated search + path used for loading files. +\notes + Some applications may not support the built-in load-path searching + facility provided by the underlying library. +\seealso{} +\done + +\function{set_slang_load_path} +\synopsis{Set the value of the interpreter's load-path} +\usage{set_slang_load_path (String_Type path)} +\description + This function may be used to set the value of the + delimiter-separated search path used by the \ifun{evalfile} and + \ifun{autoload} functions for locating files. +\example +#v+ + public define prepend_to_slang_load_path (p) + { + variable s = stat_file (p); + if (s == NULL) return; + if (0 == stat_is ("dir", s.st_mode)) + return; + + variable d = path_get_delimiter (); + set_slang_load_path (strcat (p, d, get_slang_load_path ())); + } +#v- +\notes + Some applications may not support the built-in load-path searching + facility provided by the underlying library. +\seealso{get_slang_load_path, path_get_delimiter, evalfile, autoload} +\done + diff --git a/libslang/doc/tm/rtl/import.tm b/libslang/doc/tm/rtl/import.tm new file mode 100644 index 0000000..54dd5b6 --- /dev/null +++ b/libslang/doc/tm/rtl/import.tm @@ -0,0 +1,51 @@ +\function{get_import_module_path} +\synopsis{Get the search path for dynamically loadable objects} +\usage{String_Type get_import_module_path ()} +\description + The \var{get_import_module_path} may be used to get the search path + for dynamically shared objects. Such objects may be made accessable + to the application via the \var{import} function. +\seealso{import, set_import_module_path} +\done + +\function{import} +\synopsis{Dynamically link to a specified module} +\usage{import (String_Type module [, String_Type namespace])} +\description + The \var{import} function causes the run-time linker to dynamically + link to the shared object specified by the \var{module} parameter. + It seaches for the shared object as follows: First a search is + performed along all module paths specified by the application. Then + a search is made along the paths defined via the + \var{set_import_module_path} function. If not found, a search is + performed along the paths given by the \var{SLANG_MODULE_PATH} + environment variable. Finally, a system dependent search is + performed (e.g., using the \var{LD_LIBRARY_PATH} environment + variable). + + The optional second parameter may be used to specify a namespace + for the intrinsic functions and variables of the module. If this + parameter is not present, the intrinsic objects will be placed into + the global namespace. + + This function signals an error if the specified module is not found. +\notes + The \var{import} function is not available on all systems. +\seealso{set_import_module_path, use_namespace, current_namespace, getenv, evalfile} +\done + +\function{set_import_module_path} +\synopsis{Set the search path for dynamically loadable objects} +\usage{set_import_module_path (String_Type path_list)} +\description + The \var{set_import_module_path} may be used to set the search path + for dynamically shared objects. Such objects may be made accessable + to the application via the \var{import} function. + + The actual syntax for the specification of the set of paths will + vary according to the operating system. Under Unix, a colon + character is used to separate paths in \var{path_list}. For win32 + systems a semi-colon is used. +\seealso{import, get_import_module_path} +\done + diff --git a/libslang/doc/tm/rtl/info.tm b/libslang/doc/tm/rtl/info.tm new file mode 100644 index 0000000..b476689 --- /dev/null +++ b/libslang/doc/tm/rtl/info.tm @@ -0,0 +1,202 @@ +\variable{_NARGS} +\synopsis{The number of parameters passed to a function} +\usage{Integer_Type _NARGS} + The value of the \var{_NARGS} variable represents the number of + arguments passed to the function. This variable is local to each + function. +\example + This example uses the \var{_NARGS} variable to print the list of + values passed to the function: +#v+ + define print_values () + { + variable arg; + + if (_NARGS == 0) + { + message ("Nothing to print"); + return; + } + foreach (__pop_args (_NARGS)) + { + arg = (); + vmessage ("Argument value is: %S", arg.value); + } + } +#v- +\seealso{__pop_args, __push_args, typeof} +\done + +\function{__get_defined_symbols} +\synopsis{Get the symbols defined by the preprocessor} +\usage{Integer_Type __get_defined_symbols ()} +\description + The \var{__get_defined_symbols} functions is used to get the list of + all the symbols defined by the \slang preprocessor. It pushes each + of the symbols on the stack followed by the number of items pushed. +\seealso{is_defined, _apropos, _get_namespaces} +\done + +\function{__is_initialized} +\synopsis{Determine whether or not a variable has a value} +\usage{Integer_Type __is_initialized (Ref_Type r)} +\description + This function returns non-zero of the object referenced by \var{r} + is initialized, i.e., whether it has a value. It returns \0 if the + referenced object has not been initialized. +\example + For example, the function: +#v+ + define zero () + { + variable f; + return __is_initialized (&f); + } +#v- + will always return zero, but +#v+ + define one () + { + variable f = 0; + return __is_initialized (&f); + } +#v- + will return one. +\notes + It is easy to see why a reference to the variable must be passed to + \var{__is_initialized} and not the variable itself; otherwise, the + value of the variable would be passed and the variable may have no + value if it was not initialized. +\seealso{__get_reference, __uninitialize, is_defined, typeof, eval} +\done + +\function{_apropos} +\synopsis{Generate a list of functions and variables} +\usage{Array_Type _apropos (String_Type ns, String_Type s, Integer_Type flags)} +\description + The \var{_apropos} function may be used to get a list of all defined + objects in the namespace \var{ns} whose name matches the regular + expression \var{s} and whose type matches those specified by + \var{flags}. It returns an array of strings representing the + matches. + + The second parameter \var{flags} is a bit mapped value whose bits + are defined according to the following table +#v+ + 1 Intrinsic Function + 2 User-defined Function + 4 Intrinsic Variable + 8 User-defined Variable +#v- +\example +#v+ + define apropos (s) + { + variable n, name, a; + a = _apropos ("Global", s, 0xF); + + vmessage ("Found %d matches:", length (a)); + foreach (a) + { + name = (); + message (name); + } + } +#v- + prints a list of all matches. +\notes + If the namespace specifier \var{ns} is the empty string \exmp{""}, + then the namespace will default to the static namespace of the + current compilation unit. +\seealso{is_defined, sprintf, _get_namespaces} +\done + +\function{_function_name} +\synopsis{Returns the name of the currently executing function} +\usage{String_Type _function_name ()} +\description + This function returns the name of the currently executing function. + If called from top-level, it returns the empty string. +\seealso{_trace_function, is_defined} +\done + +\function{_get_namespaces} +\synopsis{Returns a list of namespace names} +\usage{String_Type[] _get_namespaces ()} +\description + This function returns a string array containing the names of the + currently defined namespaces. +\seealso{_apropos, use_namespace, implements, __get_defined_symbols} +\done + +\variable{_slang_doc_dir} +\synopsis{Installed documentation directory} +\usage{String_Type _slang_doc_dir;} +\description + The \var{_slang_doc_dir} variable is a read-only whose value + specifies the installation location of the \slang documentation. +\seealso{get_doc_string_from_file} +\done + +\variable{_slang_version} +\synopsis{The S-Lang library version number} +\usage{Integer_Type _slang_version} +\description + The \var{_slang_version} variable is read-only and whose + value represents the number of the \slang library. +\seealso{_slang_version_string} +\done + +\variable{_slang_version_string} +\synopsis{The S-Lang library version number as a string} +\usage{String_Type _slang_version_string} +\description + The \var{_slang_version_string} variable is read-only and whose + value represents the version number of the \slang library. +\seealso{_slang_version} +\done + +\function{get_doc_string_from_file} +\synopsis{Read documentation from a file} +\usage{String_Type get_doc_string_from_file (String_Type f, String_Type t)} +\description + \var{get_doc_string_from_file} opens the documentation file \var{f} + and searches it for topic \var{t}. It returns the documentation for + \var{t} upon success, otherwise it returns \var{NULL} upon error. + It will fail if \var{f} could not be opened or does not contain + documentation for the topic. +\seealso{stat_file} +\seealso{_slang_doc_dir} +\done + +\function{is_defined} +\synopsis{Indicate whether a variable or function defined.} +\usage{Integer_Type is_defined (String_Type obj)} +\description + This function is used to determine whether or not a function or + variable whose name is \var{obj} has been defined. If \var{obj} is not + defined, the function returns 0. Otherwise, it returns a non-zero + value that defpends on the type of object \var{obj} represents. + Specifically, it returns one of the following values: +#v+ + +1 if an intrinsic function + +2 if user defined function + -1 if intrinsic variable + -2 if user defined variable + 0 if undefined +#v- +\example + For example, consider the function: +#v+ + define runhooks (hook) + { + if (2 == is_defined(hook)) eval(hook); + } +#v- + This function could be called from another \slang function to + allow customization of that function, e.g., if the function + represents a mode, the hook could be called to setup keybindings + for the mode. +\seealso{typeof, eval, autoload, __get_reference, __is_initialized} +\done + diff --git a/libslang/doc/tm/rtl/math.tm b/libslang/doc/tm/rtl/math.tm new file mode 100644 index 0000000..104589f --- /dev/null +++ b/libslang/doc/tm/rtl/math.tm @@ -0,0 +1,291 @@ +\function{Conj} +\synopsis{Compute the complex conjugate of a number} +\usage{z1 = Conj (z)} +\description + The \var{Conj} function returns the complex conjugate of a number. + If its argument is an array, the \var{Conj} function will be applied to each + element and the result returned as an array. +\seealso{Real, Imag, abs} +\done + +\function{Imag} +\synopsis{Compute the imaginary part of a number} +\usage{i = Imag (z)} +\description + The \var{Imag} function returns the imaginary part of a number. + If its argument is an array, the \var{Imag} function will be applied to each + element and the result returned as an array. +\seealso{Real, Conj, abs} +\done + +\function{Real} +\synopsis{Compute the real part of a number} +\usage{r = Real (z)} +\description + The \var{Real} function returns the real part of a number. If its + argument is an array, the \var{Real} function will be applied to + each element and the result returned as an array. +\seealso{Imag, Conj, abs} +\done + +\function{abs} +\synopsis{Compute the absolute value of a number} +\usage{y = abs(x)} +\description + The \var{abs} function returns the absolute value of an arithmetic + type. If its argument is a complex number (\var{Complex_Type}), + then it returns the modulus. If the argument is an array, a new + array will be created whose elements are obtained from the original + array by using the \var{abs} function. +\seealso{sign, sqr} +\done + +\function{acos} +\synopsis{Compute the arc-cosine of an number} +\usage{y = acos (x)} +\description + The \var{acos} function computes the arc-cosine of a number and + returns the result as an array. If its argument is an array, the + \var{acos} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{acosh} +\synopsis{Compute the inverse cosh of an number} +\usage{y = acosh (x)} +\description + The \var{acosh} function computes the inverse cosh of a number and + returns the result as an array. If its argument is an array, the + \var{acosh} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{asin} +\synopsis{Compute the arc-sine of an number} +\usage{y = asin (x)} +\description + The \var{asin} function computes the arc-sine of a number and + returns the result as an array. If its argument is an array, the + \var{asin} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{asinh} +\synopsis{Compute the inverse-sinh of an number} +\usage{y = asinh (x)} +\description + The \var{asinh} function computes the inverse-sinh of a number and + returns the result as an array. If its argument is an array, the + \var{asinh} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{atan} +\synopsis{Compute the arc-tangent of an number} +\usage{y = atan (x)} +\description + The \var{atan} function computes the arc-tangent of a number and + returns the result as an array. If its argument is an array, the + \var{atan} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{atanh} +\synopsis{Compute the inverse-tanh of an number} +\usage{y = atanh (x)} +\description + The \var{atanh} function computes the inverse-tanh of a number and + returns the result as an array. If its argument is an array, the + \var{atanh} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{cos} +\synopsis{Compute the cosine of an number} +\usage{y = cos (x)} +\description + The \var{cos} function computes the cosine of a number and + returns the result as an array. If its argument is an array, the + \var{cos} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{cosh} +\synopsis{Compute the hyperbolic cosine of an number} +\usage{y = cosh (x)} +\description + The \var{cosh} function computes the hyperbolic cosine of a number and + returns the result as an array. If its argument is an array, the + \var{cosh} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{exp} +\synopsis{Compute the exponential of an number} +\usage{y = exp (x)} +\description + The \var{exp} function computes the exponential of a number and + returns the result as an array. If its argument is an array, the + \var{exp} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{log} +\synopsis{Compute the logarithm of an number} +\usage{y = log (x)} +\description + The \var{log} function computes the logarithm of a number and + returns the result as an array. If its argument is an array, the + \var{log} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{log10} +\synopsis{Compute the base-10 logarithm of an number} +\usage{y = log10 (x)} +\description + The \var{log10} function computes the base-10 logarithm of a number and + returns the result as an array. If its argument is an array, the + \var{log10} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{mul2} +\synopsis{Multiply a number by 2} +\usage{y = mul2(x)} +\description + The \var{mul2} function multiplies an arithmetic type by two and + returns the result. If its argument is an array, a new array will + be created whose elements are obtained from the original array by + using the \var{mul2} function. +\seealso{sqr, abs} +\done + +\function{polynom} +\synopsis{Evaluate a polynomial} +\usage{Double_Type polynom(Double_Type a, b, ...c, Integer_Type n, Double_Type x)} +\description + The \var{polynom} function returns the value of the polynomial expression: +#v+ + ax^n + bx^(n - 1) + ... c +#v- +\notes + The \var{polynom} function should be extended to work with complex + and array data types. The current implementation is limited to + \var{Double_Type} quantities. +\seealso{exp} +\done + +\function{set_float_format} +\synopsis{Set the format for printing floating point values.} +\usage{set_float_format (String_Type fmt)} +\description + The \var{set_float_format} function is used to set the floating + point format to be used when floating point numbers are printed. + The routines that use this are the traceback routines and the + \var{string} function. The default value is \exmp{"%f"} +\example +#v+ + s = string (PI); % --> s = "3.14159" + set_float_format ("%16.10f"); + s = string (PI); % --> s = "3.1415926536" + set_float_format ("%10.6e"); + s = string (PI); % --> s = "3.141593e+00" +#v- +\seealso{string, sprintf, double} +\done + +\function{sign} +\synopsis{Compute the sign of a number} +\usage{y = sign(x)} +\description + The \var{sign} function returns the sign of an arithmetic type. If + its argument is a complex number (\var{Complex_Type}), it returns + the sign of the imaginary part of the number. If the argument is an + array, a new array will be created whose elements are obtained from + the original array by using the \var{sign} function. + + When applied to a real number or an integer, the \var{sign} function + returns \-1, \0, or \exmp{+1} according to whether the number is + less than zero, equal to zero, or greater than zero, respectively. +\seealso{abs} +\done + +\function{sin} +\synopsis{Compute the sine of an number} +\usage{y = sin (x)} +\description + The \var{sin} function computes the sine of a number and + returns the result as an array. If its argument is an array, the + \var{sin} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{sinh} +\synopsis{Compute the hyperbolic sine of an number} +\usage{y = sinh (x)} +\description + The \var{sinh} function computes the hyperbolic sine of a number and + returns the result as an array. If its argument is an array, the + \var{sinh} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{sqr} +\synopsis{Compute the square of a number} +\usage{y = sqr(x)} +\description + The \var{sqr} function returns the square of an arithmetic type. If its + argument is a complex number (\var{Complex_Type}), then it returns + the square of the modulus. If the argument is an array, a new array + will be created whose elements are obtained from the original array + by using the \var{sqr} function. +\seealso{abs, mul2} +\done + +\function{sqrt} +\synopsis{Compute the square root of an number} +\usage{y = sqrt (x)} +\description + The \var{sqrt} function computes the square root of a number and + returns the result as an array. If its argument is an array, the + \var{sqrt} function will be applied to each element and the result returned + as an array. +\seealso{sqr, cos, atan, acosh, cosh} +\done + +\function{tan} +\synopsis{Compute the tangent of an number} +\usage{y = tan (x)} +\description + The \var{tan} function computes the tangent of a number and + returns the result as an array. If its argument is an array, the + \var{tan} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + +\function{tanh} +\synopsis{Compute the hyperbolic tangent of an number} +\usage{y = tanh (x)} +\description + The \var{tanh} function computes the hyperbolic tangent of a number and + returns the result as an array. If its argument is an array, the + \var{tanh} function will be applied to each element and the result returned + as an array. +\seealso{cos, atan, acosh, cosh} +\done + diff --git a/libslang/doc/tm/rtl/message.tm b/libslang/doc/tm/rtl/message.tm new file mode 100644 index 0000000..e97f7cf --- /dev/null +++ b/libslang/doc/tm/rtl/message.tm @@ -0,0 +1,111 @@ +\function{error} +\synopsis{Generate an error condition} +\usage{error (String_Type msg} +\description + The \var{error} function generates a \slang error condition causing + the interpreter to start unwinding to top-level. It takes a single + string parameter which is displayed on the stderr output device. + The error condition may be cleared via an \var{ERROR_BLOCK} with the + \var{_clear_error} function. Consult \user-manual for more + information. +\example +#v+ + define add_txt_extension (file) + { + if (typeof (file) != String_Type) + error ("add_extension: parameter must be a string"); + file += ".txt"; + return file; + } +#v- +\seealso{verror, _clear_error, message} +\done + +\function{message} +\synopsis{Print a string onto the message device} +\usage{message (String_Type s} +\description + The \var{message} function will print the string specified by + \var{s} onto the message device. +\example +#v+ + define print_current_time () + { + message (time ()); + } +#v- +\notes + The message device will depend upon the application. For example, + the output message device for the \var{jed} editor correspond to the + line at the bottom of the display window. The default message + device is the standard output device. +\seealso{vmessage, sprintf, error} +\done + +\function{usage} +\synopsis{Generate a usage error} +\usage{usage (String_Type msg)} +\description + The \var{usage} function generates a usage exception and displays + \var{msg} to the message device. +\example + Suppose that some function \var{plot} plots an array of \var{x} and + \var{y} values. The such a function could be written to issue a + usage message if the wrong number of arguments were passed: +#v+ + define plot () + { + variable x, y; + + if (_NARGS != 2) + usage ("plot (x, y)"); + + (x, y) = (); + % Now do the hard part + . + . + } +#v- +\seealso{error, message} +\done + +\function{verror} +\synopsis{Generate an error condition} +\usage{verror (String_Type fmt, ...)} +\description + The \var{verror} function performs the same role as the \var{error} + function. The only difference is that instead of a single string + argument, \var{verror} takes a sprintf style argument list. +\example +#v+ + define open_file (file) + { + variable fp; + + fp = fopen (file, "r"); + if (fp == NULL) verror ("Unable to open %s", file); + return fp; + } +#v- +\notes + In the current implementation, strictly speaking, the \var{verror} + function is not an intrinsic function. Rather it is a predefined + \slang function using a combination of \var{Sprintf} and + \var{error}. +\seealso{error, Sprintf, vmessage} +\done + +\function{vmessage} +\synopsis{Print a formatted string onto the message device} +\usage{vmessage (String_Type fmt, ...)} +\description + The \var{vmessage} function formats a sprintf style argument list + and displays the resulting string onto the message device. +\notes + In the current implementation, strictly speaking, the \var{vmessage} + function is not an intrinsic function. Rather it is a predefined + \slang function using a combination of \var{Sprintf} and + \var{message}. +\seealso{message, Sprintf, verror} +\done + diff --git a/libslang/doc/tm/rtl/misc.tm b/libslang/doc/tm/rtl/misc.tm new file mode 100644 index 0000000..39cd62f --- /dev/null +++ b/libslang/doc/tm/rtl/misc.tm @@ -0,0 +1,201 @@ +\function{__class_id} +\synopsis{Return the class-id of a specified type} +\usage{Int_Type __class_id (DataType_Type type))} +\description + This function returns the internal class-id of a specified data type. +\seealso{typeof, _typeof, __class_type} +\done + +\function{__class_type} +\synopsis{Return the class-type of a specified type} +\usage{Int_Type __class_type (DataType_Type type))} +\description + Internally \slang objects are classified according to four types: + scalar, vector, pointer, and memory managed types. For example, an + integer is implemented as a scalar, a complex number as a vector, + and a string is represented as a pointer. The \var{__class_type} + function returns an integer representing the class-type associated + with the specified data type. Specifically, it returns: +#v+ + 0 memory-managed + 1 scalar + 2 vector + 3 pointer +#v- +\seealso{typeof, _typeof, __class_id} +\done + +\function{__eqs} +\synopsis{Test for equality between two objects} +\usage{Int_Type __eqs (a, b)} +\description + This function tests its two arguments for equalit and returns \1 + if they are equal, and \0 otherwise. To be equal, the data type of + the arguments must match and the values of the objects must + reference the same underlying object. +\example + __eqs (1, 1) ===> 1 + __eqs (1, 1.0) ===> 0 + __eqs ("a", 1) ===> 0 + __eqs ([1,2], [1,2]) ===> 0 +\seealso{typeof, __get_reference} +\notes + This function should be thought of as a test for "sameness". +\done + +\function{__get_reference} +\synopsis{Get a reference to a global object} +\usage{Ref_Type __get_reference (String_Type nm)} +\description + This function returns a reference to a global variable or function + whose name is specified by \var{nm}. If no such object exists, it + returns \var{NULL}, otherwise it returns a reference. +\example + For example, consider the function: +#v+ + define runhooks (hook) + { + variable f; + f = __get_reference (hook); + if (f != NULL) + @f (); + } +#v- + This function could be called from another \slang function to + allow customization of that function, e.g., if the function + represents a mode, the hook could be called to setup keybindings + for the mode. +\seealso{is_defined, typeof, eval, autoload, __is_initialized, __uninitialize} +\done + +\function{__uninitialize} +\synopsis{Uninitialize a variable} +\usage{__uninitialize (Ref_Type x)} +\description + The \var{__uninitialize} function may be used to uninitialize the + variable referenced by the parameter \var{x}. +\example + The following two lines are equivalent: +#v+ + () = __tmp(z); + __uninitialize (&z); +#v- +\seealso{__tmp, __is_initialized} +\done + +\variable{_auto_declare} +\synopsis{Set automatic variable declaration mode} +\usage{Integer_Type _auto_declare} +\description + The \var{_auto_declare} may be used to have all undefined variables + implicitely declared as \var{static}. If set to zero, any variable + must be declared witha \var{variable} declaration before it can be + used. If set to one, then any undeclared variabled will be declared + as a \var{static} global variable. + + The \var{_auto_declare} variable is local to each compilation unit and + setting its value in one unit has no effect upon its value in other + units. The value of this variable has no effect upon the variables + in a function. +\example + The following code will not compile if \var{X} not been + declared: +#v+ + X = 1; +#v- + However, +#v+ + _auto_declare = 1; % declare variables as static. + X = 1; +#v- + is equivalent to +#v+ + static variable X = 1; +#v- +\notes + This variable should be used sparingly and is intended primarily for + interactive applications where one types \slang commands at a prompt. +\done + +\function{current_namespace} +\synopsis{Get the name of the current namespace} +\usage{String_Type current_namespace ()} +\description + The \var{current_namespace} function returns the name of the + current namespace. If the current namespace is anonymous, that is, + has not been given a name via the \var{implements} function, the + empty string \exmp{""} will be returned. +\seealso{implements, use_namespace, import} +\done + +\function{getenv} +\synopsis{Get the value of an environment variable} +\usage{String_Type getenv(String_Type var)} +\description + The \var{getenv} function returns a string that represents the + value of an environment variable \var{var}. It will return + \var{NULL} if there is no environment variable whose name is given + by \var{var}. +\example +#v+ + if (NULL != getenv ("USE_COLOR")) + { + set_color ("normal", "white", "blue"); + set_color ("status", "black", "gray"); + USE_ANSI_COLORS = 1; + } +#v- +\seealso{putenv, strlen, is_defined} +\done + +\function{implements} +\synopsis{Name a private namespace} +\usage{implements (String_Type name);} +\description + The \var{implements} function may be used to name the private + namespace associated with the current compilation unit. Doing so + will enable access to the members of the namespace from outside the + unit. The name of the global namespace is \exmp{Global}. +\example + Suppose that some file \exmp{t.sl} contains: +#v+ + implements ("Ts_Private"); + static define message (x) + { + Global->vmessage ("Ts_Private message: %s", x); + } + message ("hello"); +#v- + will produce \exmp{"Ts_Private message: hello"}. This \var{message} + function may be accessed from outside via: +#v+ + Ts_Private->message ("hi"); +#v- +\notes + Since \var{message} is an intrinsic function, it is global and may + not be redefined in the global namespace. +\seealso{use_namespace, current_namespace, import} +\done + +\function{putenv} +\synopsis{Add or change an environment variable} +\usage{putenv (String_Type s)} +\description + This functions adds string \var{s} to the environment. Typically, + \var{s} should of the form \var{"name=value"}. The function + signals a \slang error upon failure. +\notes + This function is not available on all systems. +\seealso{getenv, sprintf} +\done + +\function{use_namespace} +\synopsis{Change to another namespace} +\usage{use_namespace (String_Type name)} +\description + The \var{use_namespace} function changes the current namespace to + the one specified by the parameter. If the specified namespace + does not exist, an error will be generated. +\seealso{implements, current_namespace, import} +\done + diff --git a/libslang/doc/tm/rtl/ospath.tm b/libslang/doc/tm/rtl/ospath.tm new file mode 100644 index 0000000..5604b8f --- /dev/null +++ b/libslang/doc/tm/rtl/ospath.tm @@ -0,0 +1,77 @@ +\function{path_basename} +\synopsis{Get the basename part of a pathname} +\usage{String_Type path_basename (String_Type path)} +\description + The \var{path_basename} function returns the basename associated + with the \var{path} parameter. The basename is the non-directory + part of the filename, e.g., on unix \exmp{c} is the basename of + \exmp{/a/b/c}. +\seealso{path_dirname, path_extname, path_concat, path_is_absolute} +\done + +\function{path_concat} +\synopsis{Combine elements of a pathname} +\usage{String_Type path_concat (String_Type dir, String_Type basename)} +\description + The \var{path_concat} function combines the arguments \var{dir} and + \var{basename} to produce a pathname. For example, on unix is + \var{dir} is \exmp{x/y} and \var{basename} is \exmp{z}, then the + function will return \exmp{x/y/z}. +\seealso{path_dirname, path_basename, path_extname, path_is_absolute} +\done + +\function{path_dirname} +\synopsis{Get the directory name part of a pathname} +\usage{String_Type path_dirname (String_Type path)} +\description + The \var{path_dirname} function returns the directory name + associated with a specified pathname. +\notes + On systems that include a drive specifier as part of the pathname, + the value returned by this function will include the driver + specifier. +\seealso{path_basename, path_extname, path_concat, path_is_absolute} +\done + +\function{path_extname} +\synopsis{Return the extension part of a pathname} +\usage{String_Type path_extname (String_Type path)} +\description + The \var{path_extname} function returns the extension portion of a + specified pathname. If an extension is present, this function will + also include the dot as part of the extension, i.e., if \var{path} + is \exmp{file.c}, then this function returns \exmp{".c"}. If no + extension is present, the function returns an empty string \exmp{""}. +\notes + Under VMS, the file version number is not returned as part of the + extension. +\seealso{path_sans_extname, path_dirname, path_basename, path_concat, path_is_absolute} +\done + +\function{path_get_delimiter} +\synopsis{Get the value of a search-path delimiter} +\usage{Char_Type path_get_delimiter ()} +\description + This function returns the value of the character used to delimit + fields of a search-path. +\seealso{set_slang_load_path, get_slang_load_path} +\done + +\function{path_is_absolute} +\synopsis{Determine whether or not a pathname is absolute} +\usage{Int_Type path_is_absolute (String_Type path)} +\description + The \var{path_is_absolute} function will return non-zero is + \var{path} refers to an absolute pathname, otherwise it returns zero. +\seealso{path_dirname, path_basename, path_extname, path_concat} +\done + +\function{path_sans_extname} +\synopsis{Strip the extension from a pathname} +\usage{String_Type path_sans_extname (String_Type path)} +\description + The \var{path_sans_extname} function removes the file name extension + (including the dot) from the path and returns the result. +\seealso{path_extname, path_basename, path_dirname, path_concat} +\done + diff --git a/libslang/doc/tm/rtl/posio.tm b/libslang/doc/tm/rtl/posio.tm new file mode 100644 index 0000000..cb7bc40 --- /dev/null +++ b/libslang/doc/tm/rtl/posio.tm @@ -0,0 +1,154 @@ +\function{close} +\synopsis{Close an open file descriptor} +\usage{Int_Type close (FD_Type fd)} +\description + The \var{close} function is used to open file descriptor of type + \var{FD_Type}. Upon success \0 is returned, otherwise the function + returns \-1 and sets \var{errno} accordingly. +\seealso{open, fclose, read, write} +\done + +\function{dup_fd} +\synopsis{Duplicate a file descriptor} +\usage{FD_Type dup_fd (FD_Type fd)} +\description + The \var{dup_fd} function duplicates and file descriptor and returns + its duplicate. If the function fails, \NULL will be returned and + \var{errno} set accordingly. +\notes + This function is essentually a wrapper around the POSIX \var{dup} + function. +\seealso{open, close} +\done + +\function{fileno} +\synopsis{Convert a stdio File_Type object to a FD_Type descriptor} +\usage{FD_Type fileno (File_Type fp)} +\description + The \var{fileno} function returns the \var{FD_Type} descriptor + associated with the \var{File_Type} file pointer. Upon failure, + \NULL is returned. +\seealso{fopen, open, fclose, close, dup_fd} +\done + +\function{isatty} +\synopsis{Determine if an open file descriptor refers to a terminal} +\usage{Int_Type isatty (FD_Type or File_Type fd)} +\description + This function returns \1 if the file descriptor \var{fd} refers to a + terminal; otherwise it returns \0. The object \var{fd} may either + be a \var{File_Type} stdio descriptor or an \var{FD_Type} object. +\seealso{fopen, fclose, fileno} +\done + +\function{lseek} +\synopsis{Reposition a file descriptor's file pointer} +\usage{Long_Type lseek (FD_Type fd, Long_Type ofs, int mode)} + The \var{lseek} function repositions the file pointer associated + with the open file descriptor \var{fp} to offset \var{ofs} + according to the mode parameter. Specifically, \var{mode} must be + one of the values: +#v+ + SEEK_SET Set the offset to ofs + SEEK_CUR Add ofs to the current offset + SEEK_END Add ofs to the current file size +#v- + Upon error, \var{lseek} returns \-1 and sets \var{errno}. If + successful, it returns the new filepointer offset. +\notes + Not all file descriptors are capable of supporting the seek + operation, e.g., a descriptor associated with a pipe. + + By using \var{SEEK_END} with a positive value of the \var{ofs} + parameter, it is possible to position the file pointer beyond the + current size of the file. +\seealso{fseek, ftell, open, close} +\done + +\function{open} +\synopsis{Open a file} +\usage{FD_Type open (String_Type filename, Int_Type flags [,Int_Type mode])} +\description + The \var{open} function attempts to open a file specified by the + \var{filename} parameter according to the \var{flags} parameter, + which must be one of the following values: +#v+ + O_RDONLY (read-only) + O_WRONLY (write-only) + O_RDWR (read/write) +#v- + In addition, \var{flags} may also be bitwise-or'd with any of the + following: +#v+ + O_BINARY (open the file in binary mode) + O_TEXT (open the file in text mode) + O_CREAT (create file if it does not exist) + O_EXCL (fail if the file already exists) + O_NOCTTY (do not make the device the controlling terminal) + O_TRUNC (truncate the file if it exists) + O_APPEND (open the file in append mode) + O_NONBLOCK (open the file in non-blocking mode) +#v- + Some of these flags only make sense when combined with other flags. + For example, if O_EXCL is used, then O_CREAT must also be + specified, otherwise unpredictable behavior may result. + + If \var{O_CREAT} is used for the \var{flags} parameter then the + \var{mode} parameter must be present. \var{mode} specifies the + permissions to use if a new file is created. The actual file + permissions will be affected by the process's \var{umask} via + \exmp{mode&~umask}. The \var{mode} parameter's value is + constructed via bitwise-or of the following values: +#v+ + S_IRWXU (Owner has read/write/execute permission) + S_IRUSR (Owner has read permission) + S_IWUSR (Owner has write permission) + S_IXUSR (Owner has execute permission) + S_IRWXG (Group has read/write/execute permission) + S_IRGRP (Group has read permission) + S_IWGRP (Group has write permission) + S_IXGRP (Group has execute permission) + S_IRWXO (Others have read/write/execute permission) + S_IROTH (Others have read permission) + S_IWOTH (Others have write permission) + S_IXOTH (Others have execute permission) +#v- + Upon success \var{open} returns a file descriptor object + (\var{FD_Type}), otherwise \var{NULL} is returned and \var{errno} + is set. +\notes + If you are not familiar with the \var{open} system call, then it + is recommended that you use \var{fopen} instead. +\seealso{fopen, close, read, write, stat_file} +\done + +\function{read} +\synopsis{Read from an open file descriptor} +\usage{UInt_Type read (FD_Type fd, Ref_Type buf, UInt_Type num)} +\description + The \var{read} function attempts to read at most \var{num} bytes + into the variable indicated by \var{buf} from the open file + descriptor \var{fd}. It returns the number of bytes read, or \-1 + and sets \var{errno} upon failure. The number of bytes read may be + less than \var{num}, and will be zero if an attempt is made to read + past the end of the file. +\notes + \var{read} is a low-level function and may return \-1 for a variety + of reasons. For example, if non-blocking I/O has been specified for + the open file descriptor and no data is available for reading then + the function will return \-1 and set \var{errno} to \var{EAGAIN}. +\seealso{fread, open, close, write} +\done + +\function{write} +\synopsis{Write to an open file descriptor} +\usage{UInt_Type write (FD_Type fd, BString_Type buf)} +\description + The \var{write} function attempts to write the bytes specified by + the \var{buf} parameter to the open file descriptor \var{fd}. It + returns the number of bytes successfully written, or \-1 and sets + \var{errno} upon failure. The number of bytes written may be less + than \exmp{length(buf)}. +\seealso{read, fwrite, open, close} +\done + diff --git a/libslang/doc/tm/rtl/posix.tm b/libslang/doc/tm/rtl/posix.tm new file mode 100644 index 0000000..d16b6eb --- /dev/null +++ b/libslang/doc/tm/rtl/posix.tm @@ -0,0 +1,285 @@ +\variable{errno} +\synopsis{Error code set by system functions.} +\usage{Integer_Type errno} +\description + A system function can fail for a variety of reasons. For example, a + file operation may fail because lack of disk space, or the process + does not have permission to perform the operation. Such functions + will return \var{-1} and set the variable \var{errno} to an error + code describing the reason for failure. + + Particular values of \var{errno} may be specified by the following + symbolic constants (read-only variables) and the corresponding + \var{errno_string} value: +#v+ + EPERM "Not owner" + ENOENT "No such file or directory" + ESRCH "No such process" + ENXIO "No such device or address" + ENOEXEC "Exec format error" + EBADF "Bad file number" + ECHILD "No children" + ENOMEM "Not enough core" + EACCES "Permission denied" + EFAULT "Bad address" + ENOTBLK "Block device required" + EBUSY "Mount device busy" + EEXIST "File exists" + EXDEV "Cross-device link" + ENODEV "No such device" + ENOTDIR "Not a directory" + EISDIR "Is a directory" + EINVAL "Invalid argument" + ENFILE "File table overflow" + EMFILE "Too many open files" + ENOTTY "Not a typewriter" + ETXTBSY "Text file busy" + EFBIG "File too large" + ENOSPC "No space left on device" + ESPIPE "Illegal seek" + EROFS "Read-only file system" + EMLINK "Too many links" + EPIPE "Broken pipe" + ELOOP "Too many levels of symbolic links" + ENAMETOOLONG "File name too long" +#v- +\example + The \var{mkdir} function will attempt to create a directory. If + that directory already exists, the function will fail and set + \var{errno} to \var{EEXIST}. +#v+ + define create_dir (dir) + { + if (0 == mkdir (dir)) return; + if (errno != EEXIST) + error ("mkdir %s failied: %s", dir, errno_string); + } +#v- +\seealso{errno_string, error, mkdir} +\done + +\function{errno_string} +\synopsis{Return a string describing an errno.} +\usage{String_Type errno_string (Integer_Type err)} +\description + The \var{errno_string} function returns a string describing the + integer error code \var{err}. The variable \var{err} usually + corresponds to the \var{errno} intrinsic function. See the + description for \var{errno} for more information. +\example + The \var{errno_string} function may be used as follows: +#v+ + define sizeof_file (file) + { + variable st = stat (file); + if (st == NULL) + verror ("%s: %s", file, errno_string (errno); + return st.st_size; + } +#v- +\seealso{errno, stat, verror} +\done + +\function{getegid} +\synopsis{Get the effective group id} +\usage{Int_Type getegid ()} +\description + The \var{getegid} function returns the effective group ID of the + current process. +\notes + This function is not supported by all systems. +\seealso{getgid, geteuid, setgid} +\done + +\function{geteuid} +\synopsis{Get the effective user-id of the current process} +\usage{Int_Type geteuid ()} +\description + The \var{geteuid} function returns the effective user-id of the + current process. +\notes + This function is not supported by all systems. +\seealso{getuid, setuid, setgid} +\done + +\function{getgid} +\synopsis{Get the group id} +\usage{Integer_Type getgid ()} +\description + The \var{getgid} function returns the real group id of the current + process. +\notes + This function is not supported by all systems. +\seealso{getpid, getppid} +\done + +\function{getpid} +\synopsis{Get the current process id} +\usage{Integer_Type getpid ()} +\description + The \var{getpid} function returns the current process identification + number. +\seealso{getppid, getgid} +\done + +\function{getppid} +\synopsis{Get the parent process id} +\usage{Integer_Type getppid ()} +\description + The \var{getpid} function returns the process identification + number of the parent process. +\notes + This function is not supported by all systems. +\seealso{getpid, getgid} +\done + +\function{getuid} +\synopsis{Get the user-id of the current process} +\usage{Int_Type getuid ()} +\description + The \var{getuid} function returns the user-id of the current + process. +\notes + This function is not supported by all systems. +\seealso{getuid, getegid} +\done + +\function{kill} +\synopsis{Send a signal to a process} +\usage{Integer_Type kill (Integer_Type pid, Integer_Type sig)} +\description + This function may be used to send a signal given by the integer \var{sig} + to the process specified by \var{pid}. The function returns zero upon + success and \exmp{-1} upon failure setting errno accordingly. +\example + The \var{kill} function may be used to determine whether or not + a specific process exists: +#v+ + define process_exists (pid) + { + if (-1 == kill (pid, 0)) + return 0; % Process does not exist + return 1; + } +#v- +\notes + This function is not supported by all systems. +\seealso{getpid} +\done + +\function{mkfifo} +\synopsis{Create a named pipe} +\usage{Int_Type mkfifo (String_Type name, Int_Type mode)} +\description + The \var{mkfifo} attempts to create a named pipe with the specified + name and mode (modified by the process's umask). The function + returns \0 upon success, or \-1 and sets \var{errno} upon failure. +\notes + Not all systems support the \var{mkfifo} function and even on + systems that do implement the \var{mkfifo} system call, the + underlying file system may not support the concept of a named pipe, + e.g, an NFS filesystem. +\seealso{stat_file} +\done + +\function{setgid} +\synopsis{Set the group-id of the current process} +\usage{Int_Type setgid (Int_Type gid)} +\description + The \var{setgid} function sets the effective group-id of the current + process. It returns zero upon success, or \-1 upon error and sets + \var{errno} appropriately. +\notes + This function is not supported by all systems. +\seealso{getgid, setuid} +\done + +\function{setpgid} +\synopsis{Set the process group-id} +\usage{Int_Type setpgid (Int_Type pid, Int_Type gid)} +\description + The \var{setpgid} function sets the group-id \var{gid} of the + process whose process-id is \var{pid}. If \var{pid} is \0, then the + current process-id will be used. If \var{pgid} is \0, then the pid + of the affected process will be used. + + If successful zero will be returned, otherwise the function will + return \-1 and set \var{errno} accordingly. +\notes + This function is not supported by all systems. +\seealso{setgid, setuid} +\done + +\function{setuid} +\synopsis{Set the user-id of the current process} +\usage{Int_Type setuid (Int_Type id)} +\description + The \var{setuid} function sets the effective user-id of the current + process. It returns zero upon success, or \-1 upon error and sets + \var{errno} appropriately. +\notes + This function is not supported by all systems. +\seealso{setgid, setpgid, getuid, geteuid} +\done + +\function{sleep} +\synopsis{Pause for a specified number of seconds} +\usage{sleep (Double_Type n)} +\description + The \var{sleep} function delays the current process for the + specified number of seconds. If it is interrupted by a signal, it + will return prematurely. +\notes + Not all system support sleeping for a fractional part of a second. +\done + +\function{system} +\synopsis{Execute a shell command} +\usage{Integer_Type system (String_Type cmd)} +\description + The \var{system} function may be used to execute the string + expression \var{cmd} in an inferior shell. This function is an + interface to the C \var{system} function which returns an + implementation-defined result. On Linux, it returns 127 if the + inferior shell could not be invoked, -1 if there was some other + error, otherwise it returns the return code for \var{cmd}. +\example +#v+ + define dir () + { + () = system ("DIR"); + } +#v- + displays a directory listing of the current directory under MSDOS or + VMS. +\seealso{popen, listdir} +\done + +\function{umask} +\synopsis{Set the file creation mask} +\usage{Int_Type umask (Int_Type m)} +\description + The \var{umask} function sets the file creation mask to \var{m} and + returns the previous mask. +\seealso{stat_file} +\done + +\function{uname} +\synopsis{Get the system name} +\usage{Struct_Tye uname ()} +\description + The \var{uname} function returns a structure containing information + about the operating system. The structure contains the following + fields: +#v+ + sysname (Name of the operating system) + nodename (Name of the node within the network) + release (Release level of the OS) + version (Current version of the release) + machine (Name of the hardware) +#v- +\notes + Not all systems support this function. +\seealso{getenv, pack, unpack} +\done + diff --git a/libslang/doc/tm/rtl/stack.tm b/libslang/doc/tm/rtl/stack.tm new file mode 100644 index 0000000..ad00a71 --- /dev/null +++ b/libslang/doc/tm/rtl/stack.tm @@ -0,0 +1,165 @@ +\function{__pop_args} +\synopsis{Remove n function arguments from the stack} +\usage{variable args = __pop_args(Integer_Type n);} +\description + This function together with the companion function \var{__push_args} + is useful for passing the arguments of a function to another function. + \var{__pop_args} returns an array of \var{n} structures with a + single structure field called \var{value}, which represents the value + of the argument. +\example + Consider the following \var{print} function. It prints all its + arguments to \var{stdout} separated by spaces: +#v+ + define print () + { + variable i; + variable args = __pop_args (_NARGS); + + for (i = 0; i < _NARGS; i++) + { + () = fputs (string (args[i].value), stdout); + () = fputs (" ", stdout); + } + () = fputs ("\n", stdout); + () = fflush (stdout); + } +#v- + Now consider the problem of defining a function called \var{ones} + that returns a multi-dimensional array with all the elements set to + 1. For example, \exmp{ones(10)} should return a 1-d array of ones, + whereas \exmp{ones(10,20)} should return a 10x20 array. +#v+ + define ones () + { + !if (_NARGS) return 1; + variable a; + + a = __pop_args (_NARGS); + return @Array_Type (Integer_Type, [__push_args (a)]) + 1; + } +#v- + Here, \var{__push_args} was used to push on the arguments passed to + the \var{ones} function onto the stack to be used when dereferencing + \var{Array_Type}. +\seealso{__push_args, typeof, _pop_n} +\done + +\function{__push_args} +\synopsis{Remove n function arguments onto the stack} +\usage{__push_args (Struct_Type args);} +\description + This function together with the companion function \var{__pop_args} + is useful for passing the arguments of one function to another. + See the desription of \var{__pop_args} for more information. +\seealso{__pop_args, typeof, _pop_n} +\done + +\function{_pop_n} +\synopsis{Remove objects from the stack} +\usage{_pop_n (Integer_Type n);} +\description + The \var{_pop_n} function pops \var{n} objects from the top of the + stack. +\example +#v+ + define add3 () + { + variable x, y, z; + if (_NARGS != 3) + { + _pop_n (_NARGS); + error ("add3: Expecting 3 arguments"); + } + (x, y, z) = (); + return x + y + z; + } +#v- +\seealso{_stkdepth, pop} +\done + +\function{_print_stack} +\synopsis{print the values on the stack.} +\usage{_print_stack ()} +\description + This function dumps out what is currently on the \slang. It does not + alter the stack and it is usually used for debugging purposes. +\seealso{_stkdepth, string} +\done + +\function{_stk_reverse} +\synopsis{Reverse the order of the objects on the stack.} +\usage{_stk_reverse (Integer_Type n)} +\description + The \var{_stk_reverse} function reverses the order of the top + \var{n} items on the stack. +\seealso{_stkdepth, _stk_roll} +\done + +\function{_stk_roll} +\synopsis{Roll items on the stack} +\usage{_stk_roll (Integer_Type n);} +\description + This function may be used to alter the arrangement of objects on the + stack. Specifically, if the integer \var{n} is positive, the top + \var{n} items on the stack are rotated up. If + \var{n} is negative, the top \var{abs(n)} items on the stack are + rotated down. +\example + If the stack looks like: +#v+ + item-0 + item-1 + item-2 + item-3 +#v- + where \exmp{item-0} is at the top of the stack, then + \exmp{_stk_roll(-3)} will change the stack to: +#v+ + item-2 + item-0 + item-1 + item-3 +#v- +\notes + This function only has an effect for \exmp{abs(n) > 1}. +\seealso{_stkdepth, _stk_reverse, _pop_n, _print_stack} +\done + +\function{_stkdepth} +\usage{Get the number of objects currently on the stack.} +\synopsis{Integer_Type _stkdepth ()} +\description + The \var{_stkdepth} function returns number of items on stack prior + to the call of \var{_stkdepth}. +\seealso{_print_stack, _stk_reverse, _stk_roll} +\done + +\function{dup} +\synopsis{Duplicate the value at the top of the stack} +\usage{dup ()} +\description + This function returns an exact duplicate of the object on top of the + stack. For some objects such as arrays or structures, it creates a + new reference to the array. However, for simple scalar S-Lang types such + as strings, integers, and doubles, it creates a new copy of the + object. +\seealso{pop, typeof} +\done + +\function{exch} +\synopsis{Exchange two items on the stack} +\usage{exch ()} +\description + The \var{exch} swaps the two top items on the stack. +\seealso{pop, _stk_reverse, _stk_roll} +\done + +\function{pop} +\synopsis{Discard an item from the stack} +\usage{pop ()} +\description + The \var{pop} function removes the top item from the stack. +\seealso{_pop_n} +\done + diff --git a/libslang/doc/tm/rtl/stdio.tm b/libslang/doc/tm/rtl/stdio.tm new file mode 100644 index 0000000..abb5ea8 --- /dev/null +++ b/libslang/doc/tm/rtl/stdio.tm @@ -0,0 +1,421 @@ +\function{clearerr} +\synopsis{Clear the error of a file stream} +\usage{clearerr (File_Type fp} +\description + The \var{clearerr} function clears the error and end-of-file flags + associated with the open file stream \var{fp}. +\seealso{ferror, feof, fopen} +\done + +\function{fclose} +\synopsis{Close a file} +\usage{Integer_Type fclose (File_Type fp)} +\description + The \var{fclose} function may be used to close an open file pointer + \var{fp}. Upon success it returns zero, and upon failure it sets + \var{errno} and returns \exmp{-1}. Failure usually indicates a that + the file system is full or that \var{fp} does not refer to an open file. +\notes + Many C programmers call \var{fclose} without checking the return + value. The \slang language requires the programmer to explicitly + handle any value returned by a \slang function. The simplest way to + handle the return value from \var{fclose} is to use it as: +#v+ + () = fclose (fp); +#v- +\seealso{fopen, fgets, fflush, pclose, errno} +\done + +\function{fdopen} +\synopsis{Convert a FD_Type file descriptor to a stdio File_Type object} +\usage{File_Type fdopen (FD_Type, String_Type mode)} +\description + The \var{fdopen} function creates and returns a stdio + \var{File_Type} object from the open \var{FD_Type} + descriptor \var{fd}. The \var{mode} parameter corresponds to the + \var{mode} parameter of the \var{fopen} function and must be + consistent with the mode of the descriptor \var{fd}. The function + returns \NULL upon failure and sets \var{errno}. +\notes + The \var{fclose} function does not close the \var{File_Type} object + returned from this function. The underlying file object must be + closed by the \var{close} function. +\seealso{fileno, fopen, open, close, fclose} +\done + +\function{feof} +\synopsis{Get the end-of-file status} +\usage{Integer_Type feof (File_Type fp)} +\description + This function may be used to determine the state of the end-of-file + indicator of the open file descriptor \var{fp}. It returns \var{0} + if the indicator is not set, or non-zero if it is. The end-of-file + indicator may be cleared by the \var{clearerr} function. +\seealso{ferror, clearerr, fopen} +\done + +\function{ferror} +\synopsis{Determine the error status of an open file descriptor} +\usage{Integer_Type ferror (File_Type fp)} +\description + This function may be used to determine the state of the error + indicator of the open file descriptor \var{fp}. It returns \var{0} + if the indicator is not set, or non-zero if it is. The error + indicator may be cleared by the \var{clearerr} function. +\seealso{feof, clearerr, fopen} +\done + +\function{fflush} +\synopsis{Flush an output stream} +\usage{Integer_Type fflush (File_Type fp)} +\description + The \var{fflush} function may be used to update the \em{output} + stream specified by \var{fp}. It returns \var{0} upon success, or + \var{-1} upon failure and sets \var{errno} accordingly. In + particular, this function will fail if \var{fp} does not represent + an output stream, or if \var{fp} is associated with a disk file and + there is insufficient disk space. +\example + This example illustrates how to use the \var{fflush} function + without regard to the return value: +#v+ + () = fputs ("Enter value> ", stdout); + () = fflush (stdout); +#v- +\notes + Many C programmers disregard the return value from the \var{fflush} + function. The above example illustrates how to properly do this in + the \slang langauge. +\seealso{fopen, fclose} +\done + +\function{fgets} +\synopsis{Read a line from a file.} +\usage{Integer_Type fgets (SLang_Ref_Type ref, File_Type fp)} +\description + \var{fgets} reads a line from the open file specified by \var{fp} + and places the characters in the variable whose reference is + specified by \var{ref}. + It returns \exmp{-1} if \var{fp} is not associated with an open file + or an attempt was made to read at the end the file; otherwise, it + returns the number of characters read. +\example + The following example returns the lines of a file via a linked list: +#v+ + define read_file (file) + { + variable buf, fp, root, tail; + variable list_type = struct { text, next }; + + root = NULL; + + fp = fopen(file, "r"); + if (fp == NULL) + error("fopen %s failed." file); + while (-1 != fgets (&buf, fp)) + { + if (root == NULL) + { + root = @list_type; + tail = root; + } + else + { + tail.next = @list_type; + tail = tail.next; + } + tail.text = buf; + tail.next = NULL; + } + () = fclose (fp); + return root; + } +#v- +\seealso{fopen, fclose, fputs, fread, error} +\done + +\function{fgetslines} +\synopsis{Read all the lines from an open file} +\usage{String_Type[] fgetslines (File_Type fp)} +\description + The \var{fgetslines} function returns all the remaining lines as an + array of strings in the file specified by the open file pointer + \var{fp}. If the file is empty, an empty string array will be + returned. The function returns \var{NULL} upon error. +\example + The following function returns the number of lines in a file: +#v+ + define count_lines_in_file (file) + { + variable fp, lines; + + fp = fopen (file, "r"); + if (fp == NULL) + return -1; + + lines = fgetslines (fp); + if (lines == NULL) + return -1; + + return length (lines); + } +#v- + Note that the file was implicitly closed by the function. +\notes + This function should not be used if the file contains many lines + since that would require that all the lines be read into memory. +\seealso{fgets, fread, fopen} +\done + +\function{fopen} +\synopsis{Open a file} +\usage{File_Type fopen (String_Type f, String_Type m)} +\description + The \var{fopen} function opens a file \var{f} according to the mode + string \var{m}. Allowed values for \var{m} are: +#v+ + "r" Read only + "w" Write only + "a" Append + "r+" Reading and writing at the beginning of the file. + "w+" Reading and writing. The file is created if it does not + exist; otherwise, it is truncated. + "a+" Reading and writing at the end of the file. The file is created + if it does not already exist. +#v- + In addition, the mode string can also include the letter \var{'b'} + as the last character to indicate that the file is to be opened in + binary mode. + + Upon success, \var{fopen} a \var{File_Type} object which is meant to + be used in other operations that require an open file. Upon + failure, the function returns \var{NULL}. +\example + The following function opens a file in append mode and writes a + string to it: +#v+ + define append_string_to_file (file, str) + { + variable fp = fopen (file, "a"); + if (fp == NULL) verror ("%s could not be opened", file); + () = fputs (string, fp); + () = fclose (fp); + } +#v- + Note that the return values from \var{fputs} and \var{fclose} are + ignored. +\notes + There is no need to explicitly close a file opened with \var{fopen}. + If the returned \var{File_Type} object goes out of scope, \slang + will automatically close the file. However, explicitly closing a + file after use is recommended. +\seealso{fclose, fgets, fputs, popen} +\done + +\function{fprintf} +\synopsis{Create and write a formatted string to a file} +\usage{Int_Type fprintf (File_Type fp, String_Type fmt, ...)} +\description + \var{fprintf} formats the objects specified by the variable argument + list according to the format \var{fmt} and write the result to the + open file pointer \var{fp}. + + The format string obeys the same syntax and semantics as the + \var{sprintf} format string. See the description of the + \var{sprintf} function for more information. + + \var{fprintf} returns the number of characters written to the file, + or \-1 upon error. +\seealso{fputs, printf, fwrite, message} +\done + +\function{fputs} +\synopsis{Write a string to an open stream} +\usage{Integer_Type fputs (String_Type s, File_Type fp);} +\description + The \var{fputs} function writes the string \var{s} to the open file + pointer \var{fp}. It returns -1 upon failure and sets \var{errno}, + otherwise it returns the length of the string. +\example + The following function opens a file in append mode and uses the + \var{fputs} function to write to it. +#v+ + define append_string_to_file (str, file) + { + variable fp; + fp = fopen (file, "a"); + if (fp == NULL) verror ("Unable to open %s", file); + if ((-1 == fputs (s, fp)) + or (-1 == fclose (fp))) + verror ("Error writing to %s", file); + } +#v- +\notes + One must not disregard the return value from the \var{fputs} + function, as many C programmers do. Doing so may lead to a stack + overflow error. + + To write an object that contains embedded null characters, use the + \var{fwrite} function. +\seealso{fclose, fopen, fgets, fwrite} +\done + +\function{fread} +\synopsis{Read binary data from a file} +\usage{UInt_Type fread (Ref_Type b, DataType_Type t, UInt_Type n, File_Type fp)} +\description + The \var{fread} function may be used to read \var{n} objects of type + \var{t} from an open file pointer \var{fp}. Upon success, it + returns the number of objects read from the file and places the + objects in the variable specified by \var{b}. Upon error or end of + file, it returns \var{-1}. If more than one object is read from the + file, those objects will be placed in an array of the appropriate + size. The exception to this is when reading \var{Char_Type} or + \var{UChar_Type} objects from a file, in which case the data will be + returned as an \var{n} character BString_Type binary string, but + only if \var{n}>1. +\example + The following example illustrates how to read 50 bytes from a file: +#v+ + define read_50_bytes_from_file (file) + { + variable fp, n, buf; + + fp = fopen (file, "rb"); + if (fp == NULL) error ("Open failed"); + n = fread (&buf, Char_Type, 50, fp); + if (n == -1) + error ("fread failed"); + () = fclose (fp); + return buf; + } +#v- +\notes + Use the \var{pack} and \var{unpack} functions to read data with a + specific byte-ordering. +\seealso{fwrite, fgets, fopen, pack, unpack} +\done + +\function{fseek} +\synopsis{Reposition a stream} +\usage{Integer_Type fseek (File_Type fp, Integer_Type ofs, Integer_Type whence} +\description + The \var{fseek} function may be used to reposition the file position + pointer associated with the open file stream \var{fp}. Specifically, + it moves the pointer \var{ofs} bytes relative to the position + indicated by \var{whence}. If whence is set to one of the symbolic + constants \exmp{SEEK_SET}, \exmp{SEEK_CUR}, or \exmp{SEEK_END}, the + offset is relative to the start of the file, the current position + indicator, or end-of-file, respectively. + + The function return zero upon success, or \-1 upon failure and sets + \var{errno} accordingly. +\example + define rewind (fp) + { + if (0 == fseek (fp, 0, SEEK_SET)) return; + vmessage ("rewind failed, reason: %s", errno_string (errno)); + } +\notes + The current implementation uses an integer to specify the offset. + One some systems, a long integer may be required making this + function fail for very large files, i.e., files that are longer than + the maximum value of an integer. +\seealso{ftell, fopen} +\done + +\function{ftell} +\synopsis{Obtain the current position in an open stream} +\usage{Integer_Type ftell (File_Type fp)} +\description + The ftell function may be used to obtain the current position in the + stream associated with the open file pointer \var{fp}. It returns + the position of the pointer measured in bytes from the beginning of + the file. Upon error, it returns \exmp{-1} and sets \var{errno}. +\seealso{fseek, fopen} +\done + +\function{fwrite} +\synopsis{Write binary data to a file} +\usage{UInt_Type fwrite (b, File_Type fp)} +\description + The \var{fwrite} may be used to write the object represented by + \var{b} to an open file. If \var{b} is a string or an array, the + function will attempt to write all elements of the object to the + file. It returns the number of objects successfully written, + otherwise it returns \-1 upon error and sets \var{errno} + accordingly. +\example + The following example illustrates how to write an integer array to a + file. In this example, \var{fp} is an open file descriptor: +#v+ + variable a = [1:50]; % 50 element integer array + if (50 != fwrite (a, fp)) + error ("fwrite failed"); +#v- + Here is how to write the array one element at a time: +#v+ + variable a = [1:50]; + foreach (a) + { + variable ai = (); + if (1 != fwrite(ai, fp)) + error ("fwrite failed"); + } +#v- +\notes + Not all data types may support the \var{fwrite} operation. However, + it is supported by all vector, scalar, and string objects. +\seealso{fread, fputs, fopen, pack, unpack} +\done + +\function{pclose} +\synopsis{Close an object opened with popen} +\usage{Integer_Type pclose (File_Type fp)} +\description + The \var{pclose} function waits for the process associated with + \var{fp} to exit and the returns the exit status of the command. +\seealso{pclose, fclose} +\done + +\function{popen} +\synopsis{Open a process} +\usage{File_Type popen (String_Type cmd, String_Type mode)} +\description + The \var{popen} function executes a process specified by \var{cmd} + and opens a unidirectional pipe to the newly created process. The + \var{mode} indicates whether or not the pipe is open for reading + or writing. Specifically, if \var{mode} is \exmp{"r"}, then the + pipe is opened for reading, or if \var{mode} is \exmp{"w"}, then the + pipe will be open for writing. + + Upon success, a \var{File_Type} pointer will be returned, otherwise + the function failed and \var{NULL} will be returned. +\notes + This function is not available on all systems. +\seealso{pclose, fopen} +\done + +\function{printf} +\synopsis{Create and write a formatted string to stdout} +\usage{Int_Type printf (String_Type fmt, ...)} +\description + \var{fprintf} formats the objects specified by the variable argument + list according to the format \var{fmt} and write the result to + \var{stdout}. This function is equivalent to \var{fprintf} used + with the \var{stdout} file pointer. See \var{fprintf} for more + information. + + \var{printf} returns the number of characters written to the file, + or \-1 upon error. +\notes + Many C programmers do not check the return status of the + \var{printf} C library function. Make sure that if you do not care + about whether or not the function succeeds, then code it as in the + following example: +#v+ + () = printf ("%s laid %d eggs\n", chicken_name, num_egg); +#v- +\seealso{fputs, printf, fwrite, message} +\done + diff --git a/libslang/doc/tm/rtl/strops.tm b/libslang/doc/tm/rtl/strops.tm new file mode 100644 index 0000000..5b1d8b4 --- /dev/null +++ b/libslang/doc/tm/rtl/strops.tm @@ -0,0 +1,736 @@ +\function{Sprintf} +\synopsis{Format objects into a string} +\usage{String_Type Sprintf (String_Type format, ..., Integer_Type n)} +\description + \var{Sprintf} formats a string from \var{n} objects according to + \var{format}. Unlike \var{sprintf}, the \var{Sprintf} function + requires the number of items to format. + + The format string is a C library \var{sprintf} style format + descriptor. Briefly, the format string may consist of ordinary + characters (not including the \exmp{%} character), which are copied + into the output string as-is, and a conversion specification + introduced by the \exmp{%} character. The \var{%} character must be + followed by at least one other character to specify the conversion: +#v+ + s value is a string + f value is a floating point number + e print float in exponential form, e.g., 2.345e08 + g print float as e or g, depending upon its value + c value is an ascii character + % print the percent character + d print a signed decimal integer + u print an unsigned decimal integer + o print an integer as octal + X print an integer as hexadecimal + S convert value to a string and format as string +#v- + Note that \var{%S} is a \slang extension which will cause the value + to be formatted as string. In fact, \exmp{sprintf("%S",x)} is + equivalent to \exmp{sprintf("%s",string(x))}. +#v+ + s = Sprintf("%f is greater than %f but %s is better than %s\n", + PI, E, "Cake" "Pie", 4); +#v- + The final argument to \var{Sprintf} is the number of items to format; in + this case, there are 4 items. +\seealso{sprintf, string, sscanf} +\done + +\function{create_delimited_string} +\synopsis{Concatenate strings using a delimiter} +\usage{String_Type create_delimited_string (delim, s_1, s_2, ..., s_n, n)} +#v+ + String_Type delim, s_1, ..., s_n + Integer_Type n +#v- +\description + \var{create_delimited_string} performs a concatenation operation on + the \var{n} strings \var{s_1}, ...,\var{s_n}, using the string + \var{delim} as a delimiter. The resulting string is equivalent to + one obtained via +#v+ + s_1 + delim + s_2 + delim + ... + s_n +#v- +\example + One use for this function is to construct path names, e.g., +#v+ + create_delimited_string ("/", "user", "local", "bin", 3); +#v- + will produce \exmp{"usr/local/bin"}. +\notes + The expression \exmp{strcat(a,b)} is equivalent to + \exmp{create_delimited_string("", a, b, 2)}. +\seealso{strjoin, is_list_element, extract_element, strchop, strcat} +\done + +\function{extract_element} +\synopsis{Extract the nth element of a string with delimiters} +\usage{String_Type extract_element (String_Type list, Integer_Type nth, Integer_Type delim);} +\description + The \var{extract_element} function may be used to extract the + \var{nth} element of the \var{delim} delimited list of strings + \var{list}. The function will return the \var{nth} element of the + list, unless \var{nth} specifies more elements than the list + contains, in which case \var{NULL} will be returned. + Elements in the list are numbered from \var{0}. +\example + The expression +#v+ + extract_element ("element 0, element 1, element 2", 1, ',') +#v- + returns the string \exmp{" element 1"}, whereas +#v+ + extract_element ("element 0, element 1, element 2", 1, ' ') +#v- + returns \exmp{"0,"}. + + The following function may be used to compute the number of elements + in the list: +#v+ + define num_elements (list, delim) + { + variable nth = 0; + while (NULL != extract_element (list, nth, delim)) + nth++; + return nth; + } +#v- + + Alternatively, the \var{strchop} function may be more useful. In + fact, \var{extract_element} may be expressed in terms of the + function \var{strchop} as +#v+ + define extract_element (list, nth, delim) + { + list = strchop(list, delim, 0); + if (nth >= length (list)) + return NULL; + else + return list[nth]; + } +#v- + and the \var{num_elements} function used above may be recoded more + simply as: +#v+ + define num_elements (list, delim) + { + return length (strchop (length, delim, 0)); + } +#v- +\seealso{is_list_element, is_substr, strtok, strchop, create_delimited_string} +\done + +\function{is_list_element} +\synopsis{Test whether a delimited string contains a specific element} +\usage{Integer_Type is_list_element (String_Type list, String_Type elem, Integer_Type delim)} +\description + The \var{is_list_element} function may be used to determine whether + or not a delimited list of strings, \var{list}, contains the element + \var{elem}. If \var{elem} is not an element of \var{list}, the function + will return zero, otherwise, it returns 1 plus the matching element + number. +\example + The expression +#v+ + is_list_element ("element 0, element 1, element 2", "0,", ' '); +#v- + returns \exmp{2} since \exmp{"0,"} is element number one of the list + (numbered from zero). +\seealso{extract_element, is_substr, create_delimited_string} +\done + +\function{is_substr} +\synopsis{Test for a specified substring within a string.} +\usage{Integer_Type is_substr (String_Type a, String_Type b)} +\description + This function may be used to determine if \var{a} contains the + string \var{b}. If it does not, the function returns 0; otherwise it + returns the position of the first occurance of \var{b} in \var{a}. +\notes + It is important to remember that the first character of a string + corresponds to a position value of \exmp{1}. +\seealso{substr, string_match, strreplace} +\done + +\function{make_printable_string} +\synopsis{Format a string suitable for parsing} +\usage{String_Type make_printable_string(String_Type str)} +\description + This function formats a string in such a way that it may be used as + an argument to the \var{eval} function. The resulting string is + identical to \var{str} except that it is enclosed in double quotes and the + backslash, newline, and double quote characters are expanded. +\seealso{eval, str_quote_string} +\done + +\function{sprintf} +\synopsis{Format objects into a string} +\usage{String sprintf (String format, ...);} +\description + This function performs a similar task as the C function with the same + name. It differs from the \slang function \var{Sprintf} in that it + does not require the number of items to format. + See the documentation for \var{Sprintf} for more information. +\seealso{Sprintf, string, sscanf, vmessage} +\done + +\function{sscanf} +\synopsis{Parse a formatted string} +\usage{Int_Type sscanf (s, fmt, r1, ... rN)} +#v+ + String_Type s, fmt; + Ref_Type r1, ..., rN +#v- +\description + The \var{sscanf} function parses the string \var{s} according to the + format \var{fmt} and sets the variables whose references are given by + \var{r1}, ..., \var{rN}. The function returns the number of + references assigned, or \var{-1} upon error. + + The format string \var{fmt} consists of ordinary characters and + conversion specifiers. A conversion specifier begins with the + special character \var{%} and is described more fully below. A white + space character in the format string matches any amount of whitespace + in the input string. Parsing of the format string stops whenever a + match fails. + + The \var{%} is used to denote a conversion specifier whose general + form is given by \exmp{%[*][width][type]format} where the brackets + indicate optional items. If \var{*} is present, then the conversion + will be performed by no assignment to a reference will be made. The + \var{width} specifier specifies the maximum field width to use for + the conversion. The \var{type} modifier is used to indicate size of + the object, e.g., a short integer, as follows. + + If \em{type} is given as the character \var{h}, then if the format + conversion is for an integer (\var{dioux}), the object assigned will + be a short integer. If \em{type} is \var{l}, then the conversion + will be to a long integer for integer conversions, or to a double + precession floating point number for floating point conversions. + + The format specifier is a character that specifies the conversion: +#v+ + % Matches a literal percent character. No assigment is + performed. + d Matches a signed decimal integer. + D Matches a long decimal integer (equiv to `ld') + u Matches an unsigned decimal integer + U Matches an unsigned long decimal integer (equiv to `lu') + i Matches either a hexidecimal integer, decimal integer, or + octal integer. + I Equivalent to `li'. + x Matches a hexidecimal integer. + X Matches a long hexidecimal integer (same as `lx'). + e,f,g Matches a decimal floating point number (Float_Type). + E,F,G Matches a double precision floating point number, same as `lf'. + s Matches a string of non-whitespace characters (String_Type). + c Matches one character. If width is given, width + characters are matched. + n Assigns the number of characters scanned so far. + [...] Matches zero or more characters from the set of characters + enclosed by the square brackets. If '^' is given as the + first character, then the complement set is matched. +#v- +\example + Suppose that \var{s} is \exmp{"Coffee: (3,4,12.4)"}. Then +#v+ + n = sscanf (s, "%[a-zA-Z]: (%d,%d,%lf)", &item, &x, &y, &z); +#v- + will set \var{n} to \4, \var{item} to \exmp{"Coffee"}, \var{x} to \3, + \var{y} to \4, and \var{z} to the double precision number + \exmp{12.4}. However, +#v+ + n = sscanf (s, "%s: (%d,%d,%lf)", &item, &x, &y, &z); +#v- + will set \var{n} to \1, \var{item} to \exmp{"Coffee:"} and the + remaining variables will not be assigned. +\seealso{sprintf, unpack, string, atof, int, integer, string_match} +\done + +\function{str_delete_chars} +\synopsis{Delete characters from a string} +\usage{String_Type str_delete_chars (String_Type str, String_Type del_set} +\description + This function may be used to delete the set of characters specified + by \var{del_set} from the string \var{str}. The result is returned. +\example +#v+ + str = str_delete_chars (str, "^A-Za-z"); +#v- + will remove all characters except \exmp{A-Z} and \exmp{a-z} from + \var{str}. +\done + +\function{str_quote_string} +\synopsis{Escape characters in a string.} +\usage{String_Type str_quote_string(String_Type str, String_Type qlis, Integer_Type quote)} +\description + The \var{str_quote_string} returns a string identical to \var{str} + except that all characters in the set specified by the string + \var{qlis} are escaped with the \var{quote} character, including the + quote character itself. This function is useful for making a + string that can be used in a regular expression. +\example + Execution of the statements +#v+ + node = "Is it [the coat] really worth $100?"; + tag = str_quote_string (node, "\\^$[]*.+?", '\\'); +#v- + will result in \var{tag} having the value: +#v+ + Is it \[the coat\] really worth \$100\? +#v- +\seealso{str_uncomment_string, make_printable_string} +\done + +\function{str_replace} +\synopsis{Replace a substring of a string} +\usage{Integer_Type str_replace (String_Type a, String_Type b, String_Type c)} +\description + The \var{str_replace} function replaces the first occurance of \var{b} in + \var{a} with \var{c} and returns an integer that indicates whether a + replacement was made or not. If \var{b} does not occur in \var{a}, zero is + returned. However, if \var{b} occurs in \var{a}, a non-zero integer is + returned as well as the new string resulting from the replacement. +\notes + This function has been superceded by \var{strreplace}. +\seealso{strreplace} +\done + +\function{str_uncomment_string} +\synopsis{Remove comments from a string} +\usage{String_Type str_uncomment_string(String_Type s, String_Type beg, String_Type end)} +\description + This function may be used to remove comments from a string \var{s}. + The parameters, \var{beg} and \var{end}, are strings of equal length + whose corresponding characters specify the begin and end comment + characters, respectively. It returns the uncommented string. +\example + The expression +#v+ + str_uncomment_string ("Hello (testing) 'example' World", "'(", "')") +#v- + returns the string \exmp{"Hello World"}. +\notes + This routine does not handle multicharacter comment delimiters and it + assumes that comments are not nested. +\seealso{str_quote_string} +\done + +\function{strcat} +\synopsis{Concatenate strings} +\usage{String_Type strcat (String_Type a_1, ..., String_Type a_N)} +\description + The \var{strcat} function concatenates its N \var{String_Type} + arguments \var{a_1}, ... \var{a_N} together and returns the result. +\example +#v+ + strcat ("Hello", " ", "World"); +#v- + produces the string \exmp{"Hello World"}. +\notes + This function is equivalent to the binary operation \exmp{a_1+...+a_N}. + However, \var{strcat} is much faster making it the preferred method + to concatenate string. +\seealso{sprintf, create_delimited_string} +\done + +\function{strchop} +\synopsis{Chop or split a string into substrings.} +\usage{String_Type[] strchop (String_Type str, Integer_Type delim, Integer_Type quote)} +\description + The \var{strchop} function may be used to split-up a string + \var{str} that consists of substrings delimited by the character + specified by \var{delim}. If the integer \var{quote} is non-zero, + it will be taken as a quote character for the delimiter. The + function returns the substrings as an array. +\example + The following function illustrates how to sort a comma separated + list of strings: +#v+ + define sort_string_list (a) + { + variable i, b, c; + b = strchop (a, ',', 0); + + i = array_sort (b, &strcmp); + b = b[i]; % rearrange + + % Convert array back into comma separated form + return strjoin (b, ","); + } +#v- +\notes + The semantics of this \var{strchop} and \var{strchopr} have been + changed since version 1.2.x of the interpreter. Old versions of + these functions returned the values on the stack, which meant that + one could not chop up arbitrarily long strings that consist of + many substrings. + + The function \var{strchopr} should be used if it is desired to have + the string chopped-up in the reverse order. +\seealso{strchopr, extract_element, strjoin, strtok} +\done + +\function{strchopr} +\synopsis{Chop or split a string into substrings.} +\usage{String_Type[] strchopr (String_Type str, String_Type delim, String_Type quote)} +\description + This routine performs exactly the same function as \var{strchop} except + that it returns the substrings in the reverse order. See the + documentation for \var{strchop} for more information. +\seealso{strchop, extract_element, strtok, strjoin} +\done + +\function{strcmp} +\synopsis{Compare two strings} +\usage{Interpret strcmp (String_Type a, String_Type b)} +\description + The \var{strcmp} function may be used to perform a case-sensitive + string comparison, in the lexicongraphic sense, on strings \var{a} and + \var{b}. It returns 0 if the strings are identical, a negative integer + if \var{a} is less than \var{b}, or a positive integer if \var{a} is greater + than \var{b}. +\example + The \var{strup} function may be used to perform a case-insensitive + string comparison: +#v+ + define case_insensitive_strcmp (a, b) + { + return strcmp (strup(a), strup(b)); + } +#v- +\notes + One may also use one of the binary comparison operators, e.g., + \exmp{a > b}. +\seealso{strup, strncmp} +\done + +\function{strcompress} +\synopsis{Remove excess whitespace characters from a string} +\usage{String_Type strcompress (String_Type s, String_Type white)} +\description + The \var{strcompress} function compresses the string \var{s} by + replacing a sequence of one or more characters from the set + \var{white} by the first character of \var{white}. In addition, it + also removes all leading and trailing characters from \var{s} that + are part of \var{white}. +\example + The expression +#v+ + strcompress (",;apple,,cherry;,banana", ",;"); +#v- + returns the string \exmp{"apple,cherry,banana"}. +\seealso{strtrim, strtrans} +\done + +\function{string_match} +\synopsis{Match a string against a regular expression} +\usage{Integer_Type string_match(String_Type str, String_Type pat, Integer_Type pos)} +\description + The \var{string_match} function returns zero if \var{str} does not + match regular expression specified by \var{pat}. This function + performs the match starting at position \var{pos} (numbered from 1) in + \var{str}. This function returns the position of the start of the + match. To find the exact substring actually matched, use + \var{string_match_nth}. +\seealso{string_match_nth, strcmp, strncmp} +\done + +\function{string_match_nth} +\synopsis{Get the result of the last call to string_match} +\usage{(Integer_Type, Integer_Type) = string_match_nth(Integer_Type nth)} +\description + The \var{string_match_nth} function returns two integers describing + the result of the last call to \var{string_match}. It returns both + the offset into the string and the length of characters matches by + the \var{nth} submatch. + + By convention, \var{nth} equal to zero means the entire match. + Otherwise, \var{nth} must be an integer with a value 1 through 9, + and refers to the set of characters matched by the \var{nth} regular + expression enclosed by the pairs \exmp{\\(, \\)}. +\example + Consider: +#v+ + variable matched, pos, len; + matched = string_match("hello world", "\\([a-z]+\\) \\([a-z]+\\)", 1); + if (matched) (pos, len) = string_match_nth(2); +#v- + This will set \var{matched} to 1 since a match will be found at the + first position, \var{pos} to 6 since \var{w} is offset 6 characters + from the beginning of the string, and \var{len} to 5 since + \exmp{"world"} is 5 characters long. +\notes + The position offset is \em{not} affected by the value of the offset + parameter to the \var{string_match} function. For example, if the + value of the last parameter to the \var{string_match} function had + been 3, \var{pos} would still have been set to 6. + + Note also that \var{string_match_nth} returns the \em{offset} from + the beginning of the string and not the position of the match. +\seealso{string_match} +\done + +\function{strjoin} +\synopsis{Concatenate elements of a string array} +\usage{String_Type strjoin (Array_Type a, String_Type delim)} +\description + The \var{strjoin} function operates on an array of strings by joining + successive elements together separated with a delimiter \var{delim}. + If \var{delim} is the empty string \exmp{""}, then the result will + simply be the concatenation of the elements. +\example + Suppose that +#v+ + days = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat","Sun"]; +#v- + Then \exmp{strjoin (days,"+")} will produce + \exmp{"Sun+Mon+Tue+Wed+Thu+Fri+Sat+Sun"}. Similarly, + \exmp{strjoin (["","",""], "X")} will produce \exmp{"XX"}. +\seealso{create_delimited_string, strchop, strcat} +\done + +\function{strlen} +\synopsis{Compute the length of a string} +\usage{Integer_Type strlen (String_Type a)} +\description + The \var{strlen} function may be used to compute the length of a string. +\example + After execution of +#v+ + variable len = strlen ("hello"); +#v- + \var{len} will have a value of \exmp{5}. +\seealso{bstrlen, length, substr} +\done + +\function{strlow} +\synopsis{Convert a string to lowercase} +\usage{String_Type strlow (String_Type s)} +\description + The \var{strlow} function takes a string \var{s} and returns another + string identical to \var{s} except that all upper case characters + that comprise \var{s} will be converted to lower case. +\example + The function +#v+ + define Strcmp (a, b) + { + return strcmp (strlow (a), strlow (b)); + } +#v- + performs a case-insensitive comparison operation of two strings by + converting them to lower case first. +\seealso{strup, tolower, strcmp, strtrim, define_case} +\done + +\function{strncmp} +\synopsis{Compare the first few characters of two strings} +\usage{Integer_Type strncmp (String_Type a, String_Type b, Integer_Type n)} +\description + This function behaves like \var{strcmp} except that it compares only the + first \var{n} characters in the strings \var{a} and \var{b}. See + the documentation for \var{strcmp} for information about the return + value. +\example + The expression +#v+ + strcmp ("apple", "appliance", 3); +#v- + will return zero since the first three characters match. +\seealso{strcmp, strlen} +\done + +\function{strreplace} +\synopsis{Replace one or more substrings} +\usage{(new, n) = strreplace (a, b, c, max_n)} +#v+ + String_Type a, b, c, rep; + Int_Type n, max_n; +#v- +\description + The \var{strreplace} function may be used to replace one or more + occurances of \var{b} in \var{a} with \var{c}. If the integer + \var{max_n} is positive, then the first \var{max_n} occurances of + \var{b} in \var{a} will be replaced. Otherwise, if \var{max_n} is + negative, then the last \exmp{abs(max_n)} occurances will be replaced. + + The function returns the resulting string and an integer indicating + how many replacements were made. +\example + The following function illustrates how \var{strreplace} may be used + to remove all occurances of a specified substring +#v+ + define delete_substrings (a, b) + { + (a, ) = strreplace (a, b, "", strlen (a)); + return a; + } +#v- +\seealso{is_substr, strsub, strtrim, strtrans, str_delete_chars} +\done + +\function{strsub} +\synopsis{Replace a character with another in a string.} +\usage{String_Type strsub (String_Type s, Integer_Type pos, Integer_Type ch)} +\description + The \var{strsub} character may be used to substitute the character + \var{ch} for the character at position \var{pos} of the string + \var{s}. The resulting string is returned. +\example +#v+ + define replace_spaces_with_comma (s) + { + variable n; + while (n = is_substr (s, " "), n) s = strsub (s, n, ','); + return s; + } +#v- + For uses such as this, the \var{strtrans} function is a better choice. +\notes + The first character in the string \var{s} is specified by \var{pos} + equal to 1. +\seealso{is_substr, strreplace, strlen} +\done + +\function{strtok} +\synopsis{Extract tokens from a string} +\usage{String_Type[] strtok (String_Type str [,String_Type white])} +\description + \var{strtok} breaks the string \var{str} into a series of tokens and + returns them as an array of strings. If the second parameter + \var{white} is present, then it specifies the set of characters that + are to be regarded as whitespace when extracting the tokens, and may + consist of the whitespace characters or a range of such characters. + If the first character of \var{white} is \exmp{'^'}, then the + whitespace characters consist of all characters except those in + \var{white}. For example, if \var{white} is \exmp{" \\t\\n,;."}, + then those characters specifiy the whitespace characters. However, + if \var{white} is given by \exmp{"^a-zA-Z0-9_"}, then any character + is a whitespace character except those in the ranges \exmp{a-z}, + \exmp{A-Z}, \exmp{0-9}, and the underscore character. + + If the second parameter is not present, then it defaults to + \exmp{" \\t\\r\\n\\f"}. +\example + The following example may be used to count the words in a text file: +#v+ + define count_words (file) + { + variable fp, line, count; + + fp = fopen (file, "r"); + if (fp == NULL) return -1; + + count = 0; + while (-1 != fgets (&line, fp)) + { + line = strtok (line, "^a-zA-Z"); + count += length (line); + } + () = fclose (fp); + return count; + } +#v- +\seealso{strchop, strcompress, extract_element, strjoin} +\done + +\function{strtrans} +\synopsis{Replace characters in a string} +\usage{String_Type strtrans (str, old_set, new_set)} +#v+ + String_Type str, old_set, new_set; +#v- +\description + The \var{strtrans} function may be used to replace all the characters + from the set \var{old_set} with the corresponding characters from + \var{new_set} in the string \var{str}. If \var{new_set} is empty, + then the characters in \var{old_set} will be removed from \var{str}. + This function returns the result. +\example +#v+ + str = strtrans (str, "A-Z", "a-z"); % lower-case str + str = strtrans (str, "^0-9", " "); % Replace anything but 0-9 by space +#v- +\seealso{strreplace, strtrim, strup, strlow} +\done + +\function{strtrim} +\synopsis{Remove whitespace from the ends of a string} +\usage{String_Type strtrim (String_Type s [,String_Type w])} +\description + The \var{strtrim} function removes all leading and trailing whitespace + characters from the string \var{s} and returns the result. The + optional second parameter specifies the set of whitespace + characters. If the argument is not present, then the set defaults + to \exmp{" \\t\\r\\n"}. +\seealso{strtrim_beg, strtrim_end, strcompress} +\done + +\function{strtrim_beg} +\synopsis{Remove leading whitespace from a string} +\usage{String_Type strtrim_beg (String_Type s [,String_Type w])} +\description + The \var{strtrim_beg} function removes all leading whitespace + characters from the string \var{s} and returns the result. The + optional second parameter specifies the set of whitespace + characters. If the argument is not present, then the set defaults + to \exmp{" \\t\\r\\n"}. +\seealso{strtrim, strtrim_end, strcompress} +\done + +\function{strtrim_end} +\synopsis{Remove trailing whitespace from a string} +\usage{String_Type strtrim_end (String_Type s [,String_Type w])} +\description + The \var{strtrim_end} function removes all trailing whitespace + characters from the string \var{s} and returns the result. The + optional second parameter specifies the set of whitespace + characters. If the argument is not present, then the set defaults + to \exmp{" \\t\\r\\n"}. +\seealso{strtrim, strtrim_beg, strcompress} +\done + +\function{strup} +\synopsis{Convert a string to uppercase} +\usage{String_Type strup (String_Type s)} +\description + The \var{strup} function takes a string \var{s} and returns another + string identical to \var{s} except that all lower case characters + that comprise \var{s} will be converted to upper case. +\example + The function +#v+ + define Strcmp (a, b) + { + return strcmp (strup (a), strup (b)); + } +#v- + performs a case-insensitive comparison operation of two strings by + converting them to upper case first. +\seealso{strlow, toupper, strcmp, strtrim, define_case, strtrans} +\done + +\function{substr} +\synopsis{Extract a substring from a string} +\usage{String_Type substr (String_Type s, Integer_Type n, Integer_Type len)} +\description + The \var{substr} function returns a substring with length \var{len} + of the string \var{s} beginning at position \var{n}. If \var{len} is + \exmp{-1}, the entire length of the string \var{s} will be used for + \var{len}. The first character of \var{s} is given by \var{n} equal + to 1. +\example +#v+ + substr ("To be or not to be", 7, 5); +#v- + returns \exmp{"or no"} +\notes + In many cases it is more convenient to use array indexing rather + than the \var{substr} function. In fact, \exmp{substr(s,i+1,strlen(s))} is + equivalent to \exmp{s[[i:]]}. +\seealso{is_substr, strlen} +\done + diff --git a/libslang/doc/tm/rtl/struct.tm b/libslang/doc/tm/rtl/struct.tm new file mode 100644 index 0000000..9d23263 --- /dev/null +++ b/libslang/doc/tm/rtl/struct.tm @@ -0,0 +1,104 @@ +\function{_push_struct_field_values} +\synopsis{Push the values of a structure's fields onto the stack} +\usage{Integer_Type num = _push_struct_field_values (Struct_Type s)} +\description + The \var{_push_struct_field_values} function pushes the values of + all the fields of a structure onto the stack, returning the + number of items pushed. The fields are pushed such that the last + field of the structure is pushed first. +\seealso{get_struct_field_names, get_struct_field} +\done + +\function{get_struct_field} +\synopsis{Get the value associated with a structure field} +\usage{x = get_struct_field (Struct_Type s, String field_name)} +\description + The \var{get_struct_field} function gets the value of the field + whose name is specified by \var{field_name} of the structure \var{s}. +\example + The following example illustrates how this function may be used to + to print the value of a structure. +#v+ + define print_struct (s) + { + variable name; + + foreach (get_struct_field_names (s)) + { + name = (); + value = get_struct_field (s, name); + vmessage ("s.%s = %s\n", name, string(value)); + } + } +#v- +\seealso{set_struct_field, get_struct_field_names, array_info} + +\done + +\function{get_struct_field_names} +\synopsis{Retrieve the field names associated with a structure} +\usage{String_Type[] = get_struct_field_names (Struct_Type s)} +\description + The \var{get_struct_field_names} function returns an array of + strings whose elements specify the names of the fields of the + struct \var{s}. +\example + The following example illustrates how the + \var{get_struct_field_names} function may be used to print the + value of a structure. +#v+ + define print_struct (s) + { + variable name, value; + + foreach (get_struct_field_names (s)) + { + name = (); + value = get_struct_field (s, name); + vmessage ("s.%s = %s\n", name, string (value)); + } + } +#v- +\seealso{_push_struct_field_values, get_struct_field} +\done + +\function{is_struct_type} +\synopsis{Determine whether or not an object is a structure} +\usage{Integer_Type is_struct_type (X)} +\description + The \var{is_struct_type} function returns \1 if the parameter + refers to a structure or a user-defined type. If the object is + neither, \0 will be returned. +\seealso{typeof, _typeof} +\done + +\function{set_struct_field} +\synopsis{Set the value associated with a structure field} +\usage{set_struct_field (s, field_name, field_value)} +#v+ + Struct_Type s; + String_Type field_name; + Generic_Type field_value; +#v- +\description + The \var{set_struct_field} function sets the value of the field + whose name is specified by \var{field_name} of the structure + \var{s} to \var{field_value}. +\seealso{get_struct_field, get_struct_field_names, set_struct_fields, array_info} +\done + +\function{set_struct_fields} +\synopsis{Set the fields of a structure} +\usage{set_struct_fields (Struct_Type s, ...)} +\description + The \var{set_struct_fields} function may be used to set zero or more + fields of a structure. The fields are set in the order in which + they were created when the structure was defined. +\example +#v+ + variable s = struct { name, age, height }; + set_struct_fields (s, "Bill", 13, 64); +#v- +\seealso{set_struct_field, get_struct_field_names} +\done + diff --git a/libslang/doc/tm/rtl/time.tm b/libslang/doc/tm/rtl/time.tm new file mode 100644 index 0000000..bc11de4 --- /dev/null +++ b/libslang/doc/tm/rtl/time.tm @@ -0,0 +1,137 @@ +\function{_time} +\synopsis{Get the current time in seconds} +\usage{ULong_Type _time ()} +\description + The \var{_time} function returns the number of elapsed seconds since + 00:00:00 GMT, January 1, 1970. The \var{ctime} function may be used + to convert this into a string representation. +\seealso{ctime, time, localtime, gmtime} +\done + +\function{ctime} +\synopsis{Convert a calendar time to a string} +\usage{String_Type ctime(ULong_Type secs)} +\description + This function returns a string representation of the time as given + by \var{secs} seconds since 1970. +\seealso{time, _time, localtime, gmtime} +\done + +\function{gmtime} +\synopsis{Break down a time in seconds to GMT timezone} +\usage{Struct_Type gmtime (Long_Type secs)} +\description + The \var{gmtime} function is exactly like \var{localtime} except + that the values in the structure it returns are with respect to GMT + instead of the local timezone. See the documentation for + \var{localtime} for more information. +\notes + On systems that do not support the \var{gmtime} C library function, + this function is the same as \var{localtime}. +\seealso{localtime, _time} +\done + +\function{localtime} +\synopsis{Break down a time in seconds to local timezone} +\usage{Struct_Type localtime (Long_Type secs)} +\description + The \var{localtime} function takes a parameter \var{secs} + representing the number of seconds since 00:00:00, January 1 1970 + UTC and returns a structure containing information about \var{secs} + in the local timezone. The structure contains the following + \var{Int_Type} fields: + + \var{tm_sec} The number of seconds after the minute, normally + in the range 0 to 59, but can be up to 61 to allow for + leap seconds. + + \var{tm_min} The number of minutes after the hour, in the + range 0 to 59. + + \var{tm_hour} The number of hours past midnight, in the range + 0 to 23. + + \var{tm_mday} The day of the month, in the range 1 to 31. + + \var{tm_mon} The number of months since January, in the range + 0 to 11. + + \var{tm_year} The number of years since 1900. + + \var{tm_wday} The number of days since Sunday, in the range 0 + to 6. + + \var{tm_yday} The number of days since January 1, in the + range 0 to 365. + + \var{tm_isdst} A flag that indicates whether daylight saving + time is in effect at the time described. The value is + positive if daylight saving time is in effect, zero if it + is not, and negative if the information is not available. +\seealso{gmtime, _time, ctime} +\done + +\function{tic} +\synopsis{Start timing} +\usage{void tic ()} +\description + The \var{tic} function restarts the internal clock used for timing + the execution of commands. To get the elapsed time of the clock, + use the \var{toc} function. +\seealso{toc, times} +\done + +\function{time} +\synopsis{Return the current data and time as a string} +\usage{String_Type time ()} +\description + This function returns the current time as a string of the form: +#v+ + Sun Apr 21 13:34:17 1996 +#v- +\seealso{ctime, message, substr} +\done + +\function{times} +\synopsis{Get process times} +\usage{Struct_Type times ()} +\description + The \var{times} function returns a structure containing the + following fields: +#v+ + tms_utime (user time) + tms_stime (system time) + tms_cutime (user time of child processes) + tms_cstime (system time of child processes) +#v- +\notes + Not all systems support this function. +\seealso{tic, toc, _times} +\done + +\function{toc} +\synopsis{Get elapsed CPU time} +\usage{Double_Type toc ()} +\description + The \var{toc} function returns the elapsed CPU time in seconds since + the last call to \var{tic}. The CPU time is the amount of time the + CPU spent running the code of the current process. +\example + The \var{tic} and \var{toc} functions are ideal for timing the + execution of the interpreter: +#v+ + variable a = "hello", b = "world", c, n = 100000, t; + + tic (); loop (n) c = a + b; t = toc (); + vmessage ("a+b took %f seconds\n", t); + tic (); loop (n) c = strcat(a,b); t = toc (); + vmessage ("strcat took %f seconds\n", t); +#v- +\notes + This function may not be available on all systems. + + The implementation of this function is based upon the \var{times} + system call. The precision of the clock is system dependent. +\seealso{tic, times, _time} +\done + diff --git a/libslang/doc/tm/rtl/tm-sort.sl b/libslang/doc/tm/rtl/tm-sort.sl new file mode 100755 index 0000000..ca73827 --- /dev/null +++ b/libslang/doc/tm/rtl/tm-sort.sl @@ -0,0 +1,153 @@ +#! /usr/bin/env slsh +_debug_info = 1; + +if (__argc < 2) +{ + () = fprintf (stderr, "Usage: %s files....\n", __argv[0]); + exit (1); +} + +static variable Data; + +static define init () +{ + Data = Assoc_Type[String_Type]; +} + +static define warning () +{ + variable args = __pop_args (_NARGS); + () = fprintf (stderr, "***WARNING: %s\n", sprintf (__push_args ())); +} + + +static define process_function (line, fp) +{ + variable fname; + variable lines; + + fname = strtrim (strtok (line, "{}")[1]); + + lines = line; +#iftrue + foreach (fp) + { + line = (); + lines = strcat (lines, line); + if (0 == strncmp ("\\done", line, 5)) + break; + } +#else + while (-1 != fgets (&line, fp)) + { + lines += line; + if (0 == strncmp ("\\done", line, 5)) + break; + } +#endif + if (assoc_key_exists (Data, fname)) + { + warning ("Key %s already exists", fname); + return -1; + } + + Data[fname] = lines; + return 0; +} + +static define process_variable (line, fp) +{ + % warning ("process_variable not implemented"); + process_function (line, fp); +} + +static define read_file_contents (file) +{ + variable fp = fopen (file, "r"); + variable n = 0; + variable line; + + if (fp == NULL) + { + () = fprintf (stderr, "Unable to open %s\n", file); + return -1; + } + + + %while (-1 != fgets (&line, fp)) + foreach (fp) + { + line = (); + if (0 == strncmp (line, "\\function{", 10)) + { + if (-1 == process_function (line, fp)) + return -1; + + continue; + } + + if (0 == strncmp (line, "\\variable{", 10)) + { + if (-1 == process_variable (line, fp)) + return -1; + + continue; + } + } + + () = fclose (fp); + return 0; +} + +static define sort_and_write_file_elements (file) +{ + variable fp; + variable i, keys; + variable backup_file; + + backup_file = file + ".BAK"; + () = remove (backup_file); + () = rename (file, backup_file); + + fp = fopen (file, "w"); + if (fp == NULL) + return -1; + + keys = assoc_get_keys (Data); + i = array_sort (keys, &strcmp); + + foreach (keys[i]) + { + variable k = (); + + () = fputs (Data[k], fp); + () = fputs ("\n", fp); + } + + () = fclose (fp); + + return 0; +} + + +static define process_file (file) +{ + init (); + + () = fprintf (stdout, "Processing %s ...", file); + () = fflush (stdout); + + if (-1 == read_file_contents (file)) + return -1; + + if (-1 == sort_and_write_file_elements (file)) + return -1; + + () = fputs ("done.\n", stdout); + return 0; +} + +foreach (__argv[[1:]]) + process_file (); + +exit (0); diff --git a/libslang/doc/tm/rtl/type.tm b/libslang/doc/tm/rtl/type.tm new file mode 100644 index 0000000..342f012 --- /dev/null +++ b/libslang/doc/tm/rtl/type.tm @@ -0,0 +1,245 @@ +\function{_slang_guess_type} +\synopsis{Guess the data type that a string represents.} +\usage{DataType_Type _slang_guess_type (String_Type s)} +\description + This function tries to determine whether its argument \var{s} + represents an integer (short, int, long), floating point (float, + double), or a complex number. If it appears to be none of these, + then a string is assumed. It returns one of the following values + depending on the format of the string \var{s}: +#v+ + Short_Type : short integer (e.g., "2h") + UShort_Type : unsigned short integer (e.g., "2hu") + Integer_Type : integer (e.g., "2") + UInteger_Type : unsigned integer (e.g., "2") + Long_Type : long integer (e.g., "2l") + ULong_Type : unsigned long integer (e.g., "2l") + Float_Type : float (e.g., "2.0f") + Double_Type : double (e.g., "2.0") + Complex_Type : imaginary (e.g., "2i") + String_Type : Anything else. (e.g., "2foo") +#v- + For example, \exmp{_slang_guess_type("1e2")} returns + \var{Double_Type} but \exmp{_slang_guess_type("e12")} returns + \var{String_Type}. +\seealso{integer, string, double, atof} +\done + +\function{_typeof} +\synopsis{Get the data type of an object} +\usage{DataType_Type _typeof (x)} +\description + This function is similar to the \var{typeof} function except in the + case of arrays. If the object \exmp{x} is an array, then the data + type of the array will be returned. otherwise \var{_typeof} returns + the data type of \var{x}. +\example +#v+ + if (Integer_Type == _typeof (x)) + message ("x is an integer or an integer array"); +#v- +\seealso{typeof, array_info, _slang_guess_type, typecast} +\done + +\function{atof} +\synopsis{Convert a string to a double precision number} +\usage{Double_Type atof (String_Type s)} +\description + This function converts a string \var{s} to a double precision value + and returns the result. It performs no error checking on the format + of the string. The function \var{_slang_guess_type} may be used to + check the syntax of the string. +\example +#v+ + define error_checked_atof (s) + { + switch (_slang_guess_type (s)) + { + case Double_Type: + return atof (s); + } + { + case Integer_Type: + return double (integer (s)); + } + + verror ("%s is not a double", s); + } +#v- +\seealso{typecast, double, _slang_guess_type} +\done + +\function{char} +\synopsis{Convert an ascii value into a string} +\usage{String_Type char (Integer_Type c)} +\description + The \var{char} function converts an integer ascii value \var{c} to a string + of unit length such that the first character of the string is \var{c}. + For example, \exmp{char('a')} returns the string \exmp{"a"}. +\seealso{integer, string, typedef} +\done + +\function{define_case} +\synopsis{Define upper-lower case conversion.} +\usage{define_case (Integer_Type ch_up, Integer_Type ch_low);} +\description + This function defines an upper and lowercase relationship between two + characters specified by the arguments. This relationship is used by + routines which perform uppercase and lowercase conversions. + The first integer \var{ch_up} is the ascii value of the uppercase character + and the second parameter \var{ch_low} is the ascii value of its + lowercase counterpart. +\seealso{strlow, strup} +\done + +\function{double} +\synopsis{Convert an object to double precision} +\usage{result = double (x)} +\description + The \var{double} function typecasts an object \var{x} to double + precision. For example, if \var{x} is an array of integers, an + array of double types will be returned. If an object cannot be + converted to \var{Double_Type}, a type-mismatch error will result. +\notes + The \var{double} function is equivalent to the typecast operation +#v+ + typecast (x, Double_Type) +#v- + To convert a string to a double precision number, use the \var{atof} + function. +\seealso{typecast, atof, int} +\done + +\function{int} +\synopsis{Typecast an object to an integer} +\usage{int (s)} +\description + This function performs a typecast of \var{s} from its data type to + an object of \var{Integer_Type}. If \var{s} is a string, it returns + returns the ascii value of the first character of the string + \var{s}. If \var{s} is \var{Double_Type}, \var{int} truncates the + number to an integer and returns it. +\example + \var{int} can be used to convert single character strings to + integers. As an example, the intrinsic function \var{isdigit} may + be defined as +#v+ + define isdigit (s) + { + if ((int (s) >= '0') and (int (s) <= '9')) return 1; + return 0; + } +#v- +\notes + This function is equalent to \exmp{typecast (s, Integer_Type)}; +\seealso{typecast, double, integer, char, isdigit} +\done + +\function{integer} +\synopsis{Convert a string to an integer} +\usage{Integer_Type integer (String_Type s)} +\description + The \var{integer} function converts a string representation of an + integer back to an integer. If the string does not form a valid + integer, a type-mismatch error will be generated. +\example + \exmp{integer ("1234")} returns the integer value \exmp{1234}. +\notes + This function operates only on strings and is not the same as the + more general \var{typecast} operator. +\seealso{typecast, _slang_guess_type, string, sprintf, char} +\done + +\function{isdigit} +\synopsis{Tests for a decimal digit character} +\usage{Integer_Type isdigit (String_Type s)} +\description + This function returns a non-zero value if the first character in the + string \var{s} is a digit; otherwise, it returns zero. +\example + A simple, user defined implementation of \var{isdigit} is +#v+ + define isdigit (s) + { + return ((s[0] <= '9') and (s[0] >= '0')); + } +#v- + However, the intrinsic function \var{isdigit} executes many times faster + than the equivalent representation defined above. +\notes + Unlike the C function with the same name, the \slang function takes + a string argument. +\seealso{int, integer} +\done + +\function{string} +\synopsis{Convert an object to a string representation.} +\usage{Integer_Type string (obj)} +\description + The \var{string} function may be used to convert an object + \var{obj} of any type to a string representation. + For example, \exmp{string(12.34)} returns \exmp{"12.34"}. +\example +#v+ + define print_anything (anything) + { + message (string (anything)); + } +#v- +\notes + This function is \em{not} the same as typecasting to a \var{String_Type} + using the \var{typecast} function. +\seealso{typecast, sprintf, integer, char} +\done + +\function{tolower} +\synopsis{Convert a character to lowercase.} +\usage{Integer_Type lower (Integer_Type ch)} +\description + This function takes an integer \var{ch} and returns its lowercase + equivalent. +\seealso{toupper, strup, strlow, int, char, define_case} +\done + +\function{toupper} +\synopsis{Convert a character to uppercase.} +\usage{Integer_Type toupper (Integer_Type ch)} +\description + This function takes an integer \var{ch} and returns its uppercase + equivalent. +\seealso{tolower, strup, strlow, int, char, define_case} +\done + +\function{typecast} +\synopsis{Convert an object from one data type to another.} +\usage{typecast (x, new_type)} +\description + The \var{typecast} function performs a generic typecast operation on + \var{x} to convert it to \var{new_type}. If \var{x} represents an + array, the function will attempt to convert all elements of \var{x} + to \var{new_type}. Not all objects can be converted and a + type-mismatch error will result upon failure. +\example +#v+ + define to_complex (x) + { + return typecast (x, Complex_Type); + } +#v- + defines a function that converts its argument, \var{x} to a complex + number. +\seealso{int, double, typeof} +\done + +\function{typeof} +\synopsis{Get the data type of an object.} +\usage{DataType_Type typeof (x)} +\description + This function returns the data type of \var{x}. +\example +#v+ + if (Integer_Type == typeof (x)) message ("x is an integer"); +#v- +\seealso{_typeof, is_struct_type, array_info, _slang_guess_type, typecast} +\done + diff --git a/libslang/doc/tm/rtl/whatelse.sl b/libslang/doc/tm/rtl/whatelse.sl new file mode 100755 index 0000000..fec4f0d --- /dev/null +++ b/libslang/doc/tm/rtl/whatelse.sl @@ -0,0 +1,116 @@ +#! /usr/bin/env slsh +% -*- slang -*- + +% This file is used to determine what functions still need documenting. +% I think that it provides a good example of the use of associative arrays. + +_debug_info = 1; + +variable Src_Files = "../../../src/*.c"; +variable TM_Files = "*.tm"; +variable Unwanted_Files = "../../../src/calc.c"; + +define grep (pat, files) +{ + if (strlen (files) == 0) + return String_Type[0]; + + variable fp = popen (sprintf ("rgrep '%s' %s", pat, files), "r"); + variable matches; + + matches = fgetslines (fp); + () = pclose (fp); + + return matches; +} + + +static define prune_array (a, b) +{ + foreach (b) using ("keys") + { + variable k = (); + assoc_delete_key (a, k); + } +} + +define get_with_pattern (a, pat, white) +{ + variable f; + + foreach (grep (pat, Src_Files)) + { + f = (); + + f = strtok (f, white)[1]; + a [f] = 1; + } + + if (Unwanted_Files != NULL) foreach (grep (pat, Unwanted_Files)) + { + f = (); + f = strtok (f, white)[1]; + assoc_delete_key (a, f); + } +} + +define get_src_intrinsics () +{ + variable f; + variable src = Assoc_Type[Int_Type]; + + get_with_pattern (src, "^[ \t]+MAKE_INTRINSIC.*(\".*\"", "\""); + get_with_pattern (src, "^[ \t]+MAKE_MATH_UNARY.*(\".*\"", "\""); + get_with_pattern (src, "^[ \t]+MAKE_VARIABLE.*(\".*\"", "\""); + get_with_pattern (src, "^[ \t]+MAKE_DCONSTANT.*(\".*\"", "\""); + get_with_pattern (src, "^[ \t]+MAKE_ICONSTANT.*(\".*\"", "\""); + + return src; +} + +define get_doc_intrinsics () +{ + variable funs; + variable doc = Assoc_Type[Int_Type]; + + funs = grep ("^\\\\function{", TM_Files); + foreach (funs) + { + variable f; + f = (); + f = strtok (f, "{}")[1]; + doc [f] = 1; + } + funs = grep ("^\\\\variable{", TM_Files); + foreach (funs) + { + f = (); + f = strtok (f, "{}")[1]; + doc [f] = 1; + } + return doc; +} + + +define main () +{ + variable k; + variable src, doc; + + doc = get_doc_intrinsics (); + src = get_src_intrinsics (); + + prune_array (src, doc); + + k = assoc_get_keys (src); + k = k[array_sort(k)]; + + foreach (k) + { + message (); + } +} + +main (); + + diff --git a/libslang/doc/tm/slang.tm b/libslang/doc/tm/slang.tm new file mode 100644 index 0000000..3e02e3d --- /dev/null +++ b/libslang/doc/tm/slang.tm @@ -0,0 +1,4077 @@ +#% -*- mode: tm; mode: fold -*- + +#% text-macro definitions #%{{{ +#i linuxdoc.tm + +#d slang \bf{S-Lang} +#d slrn \bf{slrn} +#d jed \bf{jed} +#d kw#1 \tt{$1} +#d exmp#1 \tt{$1} +#d var#1 \tt{$1} +#d ldots ... +#d times * +#d math#1 $1 +#d sc#1 \tt{$1} +#d verb#1 \tt{$1} +#d sldxe \bf{sldxe} +#d url#1 +#d slang-library-reference \bf{The \slang Library Reference} +#d chapter#1 $1

+#d preface +#d tag#1 $1 +#d appendix + +#d NULL NULL +#d kbd#1 $1 + +#d documentstyle book + +#%}}} + +\linuxdoc + +\begin{\documentstyle} + +\title A Guide to the S-Lang Language +\author John E. Davis, \tt{davis@space.mit.edu} +\date \__today__ + +\toc + +#i preface.tm + +\chapter{Introduction} #%{{{ + + \slang is a powerful interpreted language that may be embedded into + an application to make the application extensible. This enables + the application to be used in ways not envisioned by the programmer, + thus providing the application with much more flexibility and + power. Examples of applications that take advantage of the + interpreter in this way include the \jed editor and the \slrn + newsreader. + +\sect{Language Features} + + The language features both global and local variables, branching + and looping constructs, user-defined functions, structures, + datatypes, and arrays. In addition, there is limited support for + pointer types. The concise array syntax rivals that of commercial + array-based numerical computing environments. + +\sect{Data Types and Operators} #%{{{ + + The language provides built-in support for string, integer (signed + and unsigned long and short), double precision floating point, and + double precision complex numbers. In addition, it supports user + defined structure types, multi-dimensional array types, and + associative arrays. To facilitate the construction of + sophisticated data structures such as linked lists and trees, a + `reference' type was added to the language. The reference type + provides much of the same flexibility as pointers in other + languages. Finally, applications embedding the interpreter may + also provide special application specific types, such as the + \var{Mark_Type} that the \jed editor provides. + + The language provides standard arithmetic operations such as + addition, subtraction, multiplication, and division. It also + provides support for modulo arithmetic as well as operations at + the bit level, e.g., exclusive-or. Any binary or unary operator + may be extended to work with any data type. For example, the + addition operator (\var{+}) has been extended to work between + string types to permit string concatenation. + + The binary and unary operators work transparently with array types. + For example, if \var{a} and \var{b} are arrays, then \exmp{a + b} + produces an array whose elements are the result of element by + element addition of \var{a} and \var{b}. This permits one to do + vector operations without explicitly looping over the array + indices. + +#%}}} + +\sect{Statements and Functions} #%{{{ + + The \slang language supports several types of looping constructs and + conditional statements. The looping constructs include \kw{while}, + \kw{do...while}, \kw{for}, \kw{forever}, \kw{loop}, \kw{foreach}, + and \kw{_for}. The conditional statements include \kw{if}, + \kw{if-then-else}, and \kw{!if}. + + User defined functions may be defined to return zero, one, or more + values. Functions that return zero values are similar to + `procedures' in languages such as PASCAL. The local variables of a + function are always created on a stack allowing one to create + recursive functions. Parameters to a function are always passed by + value and never by reference. However, the language supports a + \em{reference} data type that allows one to simulate pass by + reference. + + Unlike many interpreted languages, \slang allows functions to be + dynamically loaded (function autoloading). It also provides + constructs specifically designed for error handling and recovery as + well as debugging aids (e.g., function tracebacks). + + Functions and variables may be declared as private belonging to a + namespace associated with the compilation unit that defines the + function or variable. The ideas behind the namespace implementation + stems from the C language and should be quite familiar to any one + familiar with C. + +#%}}} + +\sect{Error Handling} #%{{{ + + The \slang language defines a construct called an \em{error-block} + that may be used for error handling and recovery. When a non-fatal + run-time error is encountered, any error blocks that have been + defined are executed as the run-time stack unwinds. An error block + can optionally clear the error and the program will continue + running after the statement that triggered the error. This + mechanism is somewhat similar to try-catch in C++. + +#%}}} + +\sect{Run-Time Library} #%{{{ + + Functions that compose the \slang run-time library are called + \em{intrinsics}. Examples of \slang intrinsic functions available + to every \slang application include string manipulation functions + such as \var{strcat}, \var{strchop}, and \var{strcmp}. The \slang + library also provides mathematical functions such as \var{sin}, + \var{cos}, and \var{tan}; however, not all applications enable the + use of these intrinsics. For example, to conserve memory, the 16 + bit version of the \jed editor does not provide support for any + mathematics other than simple integer arithmetic, whereas other + versions of the editor do support these functions. + + Most applications embedding the languages will also provide a set of + application specific intrinsic functions. For example, the \jed + editor adds over 100 application specific intrinsic functions to + the language. Consult your application specific documentation to + see what additional intrinsics are supported. + +#%}}} + +\sect{Input/Output} + + The language supports C-like stdio input/output functions such as + \var{fopen}, \var{fgets}, \var{fputs}, and \var{fclose}. In + addition it provides two functions, \var{message} and \var{error}, + for writing to the standard output device and standard error. + Specific applications may provide other I/O mechanisms, e.g., + the \jed editor supports I/O to files via the editor's + buffers. + +\sect{Obtaining \slang} #%{{{ + + Comprehensive information about the library may be obtained via the + World Wide Web from \tt{http://www.s-lang.org}. + + \slang as well as some programs that embed it are freely available + via anonymous ftp in the United States from +\begin{itemize} + \item \url{ftp://space.mit.edu/pub/davis}. +\end{itemize} + It is also available outside the United States from the following + mirror sites: +\begin{itemize} + \item \url{ftp://ftp.uni-stuttgart.de/pub/unix/misc/slang/} + \item \url{ftp://ftp.fu-berlin.de/pub/unix/news/slrn/} + \item \url{ftp://ftp.ntua.gr/pub/lang/slang/} +\end{itemize} + + The Usenet newsgroup \var{alt.lang.s-lang} was created for \slang + programmers to exchange information and share macros for the various + programs the embed the language. The newsgroup \var{comp.editors} + can be a useful resource for \slang macros for the \jed editor. + Similarly, \slrn users will find \var{news.software.readers} to be a + valuable source of information. + + Finally, two mailing lists dealing with the \slang library have been + created: +\begin{itemize} + \item \tt{slang-announce@babayaga.math.fu-berlin.de} + \item \tt{slang-workers@babayaga.math.fu-berlin.de} +\end{itemize} + The first list is for announcements of new releases of the library, while the + second list is intended for those who use the library for their own code + development. To subscribe to the announcement list, send an email to + \tt{slang-announce-subscribe@babayaga.math.fu-berlin.de} and include + the word \tt{subscribe} in the body of the message. To subscribe to + the developers list, use the address + \tt{slang-workers-subscribe@babayaga.math.fu-berlin.de}. + +#%}}} + +#%}}} + +\chapter{Overview of the Language} #%{{{ + + This purpose of this section is to give the reader a feel for the + \slang language, its syntax, and its capabilities. The information + and examples presented in this section should be sufficient to + provide the reader with the necessary background to understand the + rest of the document. + +\sect{Variables and Functions} #%{{{ + + \slang is different from many other interpreted languages in the + sense that all variables and functions must be declared before they + can be used. + + Variables are declared using the \kw{variable} keyword, e.g., +#v+ + variable x, y, z; +#v- + declares three variables, \var{x}, \var{y}, and \var{z}. Note the + semicolon at the end of the statement. \em{All \slang statements must + end in a semi-colon.} + + Unlike compiled languages such as C, it is not necessary to specify + the data type of a \slang variable. The data type of a \slang + variable is determined upon assignment. For example, after + execution of the statements +#v+ + x = 3; + y = sin (5.6); + z = "I think, therefore I am."; +#v- + \var{x} will be an integer, \var{y} will be a + double, and \var{z} will be a string. In fact, it is even possible + to re-assign \var{x} to a string: +#v+ + x = "x was an integer, but now is a string"; +#v- + Finally, one can combine variable declarations and assignments in + the same statement: +#v+ + variable x = 3, y = sin(5.6), z = "I think, therefore I am."; +#v- + + Most functions are declared using the \kw{define} keyword. A + simple example is +#v+ + define compute_average (x, y) + { + variable s = x + y; + return s / 2.0; + } +#v- + which defines a function that simply computes the average of two + numbers and returns the result. This example shows that a function + consists of three parts: the function name, a parameter list, and + the function body. + + The parameter list consists of a comma separated list of variable + names. It is not necessary to declare variables within a parameter + list; they are implicitly declared. However, all other \em{local} + variables used in the function must be declared. If the function + takes no parameters, then the parameter list must still be present, + but empty: +#v+ + define go_left_5 () + { + go_left (5); + } +#v- + The last example is a function that takes no arguments and returns + no value. Some languages such as PASCAL distinguish such objects + from functions that return values by calling these objects + \em{procedures}. However, \slang, like C, does not make such a + distinction. + + The language permits \em{recursive} functions, i.e., functions that + call themselves. The way to do this in \slang is to first declare + the function using the form: +\begin{tscreen} + define \em{function-name} (); +\end{tscreen} + It is not necessary to declare a parameter list when declaring a + function in this way. + + The most famous example of a recursive function is the factorial + function. Here is how to implement it using \slang: +#v+ + define factorial (); % declare it for recursion + + define factorial (n) + { + if (n < 2) return 1; + return n * factorial (n - 1); + } +#v- + This example also shows how to mix comments with code. \slang uses + the `\var{%}' character to start a comment and all characters from + the comment character to the end of the line are ignored. + +#%}}} + +\sect{Strings} #%{{{ + + Perhaps the most appealing feature of any interpreted language is + that it frees the user from the responsibility of memory management. + This is particularly evident when contrasting how + \slang handles string variables with a lower level language such as + C. Consider a function that concatenates three strings. An + example in \slang is: +#v+ + define concat_3_strings (a, b, c) + { + return strcat (a, strcat (b, c)); + } +#v- + This function uses the built-in + \var{strcat} function for concatenating two strings. In C, the + simplest such function would look like: +#v+ + char *concat_3_strings (char *a, char *b, char *c) + { + unsigned int len; + char *result; + len = strlen (a) + strlen (b) + strlen (c); + if (NULL == (result = (char *) malloc (len + 1))) + exit (1); + strcpy (result, a); + strcat (result, b); + strcat (result, c); + return result; + } +#v- + Even this C example is misleading since none of the issues of memory + management of the strings has been dealt with. The \slang language + hides all these issues from the user. + + Binary operators have been defined to work with the string data + type. In particular the \var{+} operator may be used to perform + string concatenation. That is, one can use the + \var{+} operator as an alternative to \var{strcat}: +#v+ + define concat_3_strings (a, b, c) + { + return a + b + c; + } +#v- + See section ??? for more information about string variables. + +#%}}} + +\sect{Referencing and Dereferencing} #%{{{ + The unary prefix operator, \var{&}, may be used to create a + \em{reference} to an object, which is similar to a pointer + in other languages. References are commonly used as a mechanism to + pass a function as an argument to another function as the following + example illustrates: +#v+ + define compute_functional_sum (funct) + { + variable i, s; + + s = 0; + for (i = 0; i < 10; i++) + { + s += (@funct)(i); + } + return s; + } + + variable sin_sum = compute_functional_sum (&sin); + variable cos_sum = compute_functional_sum (&cos); +#v- + Here, the function \var{compute_functional_sum} applies the + function specified by the parameter \var{funct} to the first + \exmp{10} integers and returns the sum. The two statements + following the function definition show how the \var{sin} and + \var{cos} functions may be used. + + Note the \var{@} operator in the definition of + \var{compute_functional_sum}. It is known as the \em{dereference} + operator and is the inverse of the reference operator. + + Another use of the reference operator is in the context of the + \var{fgets} function. For example, +#v+ + define read_nth_line (file, n) + { + variable fp, line; + fp = fopen (file, "r"); + + while (n > 0) + { + if (-1 == fgets (&line, fp)) + return NULL; + n--; + } + return line; + } +#v- + uses the \var{fgets} function to read the nth line of a file. + In particular, a reference to the local variable \var{line} is + passed to \var{fgets}, and upon return \var{line} will be set to + the character string read by \var{fgets}. + + Finally, references may be used as an alternative to multiple + return values by passing information back via the parameter list. + The example involving \var{fgets} presented above provided an + illustration of this. Another example is +#v+ + define set_xyz (x, y, z) + { + @x = 1; + @y = 2; + @z = 3; + } + variable X, Y, Z; + set_xyz (&X, &Y, &Z); +#v- + which, after execution, results in \var{X} set to \exmp{1}, \var{Y} + set to \exmp{2}, and \var{Z} set to \exmp{3}. A C programmer will + note the similarity of \var{set_xyz} to the following C + implementation: +#v+ + void set_xyz (int *x, int *y, int *z) + { + *x = 1; + *y = 2; + *z = 3; + } +#v- +#%}}} + +\sect{Arrays} #%{{{ + The \slang language supports multi-dimensional arrays of all + datatypes. For example, one can define arrays of references to + functions as well as arrays of arrays. Here are a few examples of + creating arrays: +#v+ + variable A = Integer_Type [10]; + variable B = Integer_Type [10, 3]; + variable C = [1, 3, 5, 7, 9]; +#v- + The first example creates an array of \var{10} integers and assigns + it to the variable \var{A}. The second example creates a 2-d array + of \var{30} integers arranged in \var{10} rows and \var{3} columns + and assigns the result to \var{B}. In the last example, an array + of \var{5} integers is assigned to the variable \var{C}. However, + in this case the elements of the array are initialized to the + values specified. This is known as an \em{inline-array}. + + \slang also supports something called an + \em{range-array}. An example of such an array is +#v+ + variable C = [1:9:2]; +#v- + This will produce an array of 5 integers running from \exmp{1} + through \exmp{9} in increments of \exmp{2}. + + Arrays are passed by reference to functions and never by value. + This permits one to write functions which can initialize arrays. + For example, +#v+ + define init_array (a) + { + variable i, imax; + + imax = length (a); + for (i = 0; i < imax; i++) + { + a[i] = 7; + } + } + + variable A = Integer_Type [10]; + init_array (A); +#v- + creates an array of \var{10} integers and initializes all its + elements to \var{7}. + + There are more concise ways of accomplishing the result of the + previous example. These include: +#v+ + variable A = [7, 7, 7, 7, 7, 7, 7, 7, 7, 7]; + variable A = Integer_Type [10]; A[[0:9]] = 7; + variable A = Integer_Type [10]; A[*] = 7; +#v- + The second and third methods use an array of indices to index the array + \var{A}. In the second, the range of indices has been explicitly + specified, whereas the third example uses a wildcard form. See + section ??? for more information about array indexing. + + Although the examples have pertained to integer arrays, the fact is + that \slang arrays can be of any type, e.g., +#v+ + variable A = Double_Type [10]; + variable B = Complex_Type [10]; + variable C = String_Type [10]; + variable D = Ref_Type [10]; +#v- + create \var{10} element arrays of double, complex, string, and + reference types, respectively. The last example may be used to + create an array of functions, e.g., +#v+ + D[0] = &sin; + D[1] = &cos; +#v- + + The language also defines unary, binary, and mathematical + operations on arrays. For example, if \var{A} and \var{B} are + integer arrays, then \exmp{A + B} is an array whose elements are + the sum of the elements of \var{A} and \var{B}. A trivial example + that illustrates the power of this capability is +#v+ + variable X, Y; + X = [0:2*PI:0.01]; + Y = 20 * sin (X); +#v- + which is equivalent to the highly simplified C code: +#v+ + double *X, *Y; + unsigned int i, n; + + n = (2 * PI) / 0.01 + 1; + X = (double *) malloc (n * sizeof (double)); + Y = (double *) malloc (n * sizeof (double)); + for (i = 0; i < n; i++) + { + X[i] = i * 0.01; + Y[i] = 20 * sin (X[i]); + } +#v- + + +#%}}} + +\sect{Structures and User-Defined Types} #%{{{ + + A \em{structure} is similar to an array in the sense that it is a + container object. However, the elements of an array must all be of + the same type (or of \var{Any_Type}), whereas a structure is + heterogeneous. As an example, consider +#v+ + variable person = struct + { + first_name, last_name, age + }; + variable bill = @person; + bill.first_name = "Bill"; + bill.last_name = "Clinton"; + bill.age = 51; +#v- + In this example a structure consisting of the three fields has been + created and assigned to the variable \var{person}. Then an + \em{instance} of this structure has been created using the + dereference operator and assigned to \var{bill}. Finally, the + individual fields of \var{bill} were initialized. This is an + example of an \em{anonymous} structure. + + A \em{named} structure is really a new data type and may be created + using the \kw{typedef} keyword: +#v+ + typedef struct + { + first_name, last_name, age + } + Person_Type; + + variable bill = @Person_Type; + bill.first_name = "Bill"; + bill.last_name = "Clinton"; + bill.age = 51; +#v- + The big advantage of creating a new type is that one can go on to + create arrays of the data type +#v+ + variable People = Person_Type [100]; + People[0].first_name = "Bill"; + People[1].first_name = "Hillary"; +#v- + + The creation and initialization of a structure may be facilitated + by a function such as +#v+ + define create_person (first, last, age) + { + variable person = @Person_Type; + person.first_name = first; + person.last_name = last; + person.age = age; + return person; + } + variable Bill = create_person ("Bill", "Clinton", 51); +#v- + + Other common uses of structures is the creation of linked lists, + binary trees, etc. For more information about these and other + features of structures, see section ???. + + +#%}}} + +\sect{Namespaces} + + In addition to the global namespace, each compilation unit (e.g., a + file) is given a private namespace. A variable or function name + that is declared using the \var{static} keyword will be placed in + the private namespace associated with compilation unit. For + example, +#v+ + variable i; + static variable i; +#v- + defines two variables called \var{i}. The first declaration + defines \var{i} in the global namespace, but the second declaration + defines \var{i} in the private namespace. + + The \exmp{->} operator may be used in conjunction with the name of + the namespace to access objects in the name space. In the above + example, to access the variable \var{i} in the global namespace, + one would use \exmp{Global->i}. Unless otherwise specified, a + private namespace has no name and its objects may not be accessed + from outside the compilation unit. However, the \var{implements} + function may be used give the private namespace a name, allowing + access to its objects. For example, if the file \exmp{t.sl} contains +#v+ + implements ("A"); + static variable i; +#v- + then another file may access the variable \var{i} via \exmp{A->i}. + +#%}}} + +\chapter{Data Types and Literal Constants} #%{{{ + + The current implementation of the \slang language permits up to 256 + distinct data types, including predefined data types such as integer and + floating point, as well as specialized applications specific data + types. It is also possible to create new data types in the + language using the \kw{typedef} mechanism. + + Literal constants are objects such as the integer \exmp{3} or the + string \exmp{"hello"}. The actual data type given to a literal + constant depends upon the syntax of the constant. The following + sections describe the syntax of literals of specific data types. + +\sect{Predefined Data Types} #%{{{ + + The current version of \slang defines integer, floating point, + complex, and string types. It also defines special purpose data + types such as \var{Null_Type}, \var{DataType_Type}, and + \var{Ref_Type}. These types are discussed below. + +\sect1{Integers} #%{{{ + + The \slang language supports both signed and unsigned characters, + short integer, long integer, and plain integer types. On most 32 + bit systems, there is no difference between an integer and a long + integer; however, they may differ on 16 and 64 bit systems. + Generally speaking, on a 16 bit system, plain integers are 16 bit + quantities with a range of -32767 to 32767. On a 32 bit system, + plain integers range from -2147483648 to 2147483647. + + An plain integer \em{literal} can be specified in one of several ways: +\begin{itemize} +\item As a decimal (base 10) integer consisting of the characters + \var{0} through \var{9}, e.g., \var{127}. An integer specified + this way cannot begin with a leading \var{0}. That is, + \var{0127} is \em{not} the same as \var{127}. + +\item Using hexadecimal (base 16) notation consisting of the characters + \var{0} to \var{9} and \var{A} through \var{F}. The hexadecimal + number must be preceded by the characters \var{0x}. For example, + \var{0x7F} specifies an integer using hexadecimal notation and has + the same value as decimal \var{127}. + +\item In Octal notation using characters \var{0} through \var{7}. The Octal + number must begin with a leading \var{0}. For example, + \var{0177} and \var{127} represent the same integer. + + Short, long, and unsigned types may be specified by using the + proper suffixes: \var{L} indicates that the integer is a long + integer, \var{h} indicates that the integer is a short integer, and + \var{U} indicates that it is unsigned. For example, \exmp{1UL} + specifies an unsigned long integer. + + Finally, a character literal may be specified using a notation + containing a character enclosed in single quotes as \exmp{'a'}. + The value of the character specified this way will lie in the + range 0 to 256 and will be determined by the ASCII value of the + character in quotes. For example, +#v+ + i = '0'; +#v- + assigns to \var{i} the character 48 since the \exmp{'0'} character + has an ASCII value of 48. +\end{itemize} + + Any integer may be preceded by a minus sign to indicate that it is a + negative integer. + +#%}}} + +\sect1{Floating Point Numbers} #%{{{ + + Single and double precision floating point literals must contain either a + decimal point or an exponent (or both). Here are examples of + specifying the same double precision point number: +#v+ + 12. 12.0 12e0 1.2e1 120e-1 .12e2 0.12e2 +#v- + Note that \var{12} is \em{not} a floating point number since it + contains neither a decimal point nor an exponent. In fact, + \var{12} is an integer. + + One may append the \var{f} character to the end of the number to + indicate that the number is a single precision literal. + +#%}}} + +\sect1{Complex Numbers} #%{{{ + + The language implements complex numbers as a pair of double + precision floating point numbers. The first number in the pair + forms the \em{real} part, while the second number forms the + \em{imaginary} part. That is, a complex number may be regarded as the + sum of a real number and an imaginary number. + + Strictly speaking, the current implementation of the \slang does + not support generic complex literals. However, it does support + imaginary literals and a more generic complex number with a non-zero + real part may be constructed from the imaginary literal via + addition of a real number. + + An imaginary literal is specified in the same way as a floating + point literal except that \var{i} or \var{j} is appended. For + example, +#v+ + 12i 12.0i 12e0j +#v- + all represent the same imaginary number. Actually, \var{12i} is + really an imaginary integer except that \slang automatically + promotes it to a double precision imaginary number. + + A more generic complex number may be constructed from an imaginary + literal via addition, e.g., +#v+ + 3.0 + 4.0i +#v- + produces a complex number whose real part is \exmp{3.0} and whose + imaginary part is \exmp{4.0}. + + The intrinsic functions \var{Real} and \var{Imag} may be used to + retrieve the real and imaginary parts of a complex number, + respectively. + +#%}}} + +\sect1{Strings} #%{{{ + + A string literal must be enclosed in double quotes as in: +#v+ + "This is a string". +#v- + Although there is no imposed limit on the length of a string, + string literals must be less than 256 characters in length. It is + possible to go beyond this limit by string concatenation, e.g., +#v+ + "This is the first part of a long string" + + "and this is the second half" +#v- + Any character except a newline (ASCII 10) or the null character + (ASCII 0) may appear explicitly in a string literal. However, + these characters may be used implicitly using the mechanism + described below. + + The backslash character is a special character and is used to + include other special characters (such as a newline character) in + the string. The special characters recognized are: +#v+ + \" -- double quote + \' -- single quote + \\ -- backslash + \a -- bell character (ASCII 7) + \t -- tab character (ASCII 9) + \n -- newline character (ASCII 10) + \e -- escape character (ASCII 27) + \xhhh -- character expressed in HEXADECIMAL notation + \ooo -- character expressed in OCTAL notation + \dnnn -- character expressed in DECIMAL +#v- + For example, to include the double quote character as part of the + string, it must be preceded by a backslash character, e.g., +#v+ + "This is a \"quote\"" +#v- + Similarly, the next illustrates how a newline character may be + included: +#v+ + "This is the first line\nand this is the second" +#v- +#%}}} + + +\sect1{Null_Type} + + Objects of type \var{Null_Type} can have only one value: + \var{NULL}. About the only thing that you can do with this data + type is to assign it to variables and test for equality with + other objects. Nevertheless, \var{Null_Type} is an important and + extremely useful data type. Its main use stems from the fact that + since it can be compared for equality with any other data type, it + is ideal to represent the value of an object which does not yet + have a value, or has an illegal value. + + As a trivial example of its use, consider +#v+ + define add_numbers (a, b) + { + if (a == NULL) a = 0; + if (b == NULL) b = 0; + return a + b; + } + variable c = add_numbers (1, 2); + variable d = add_numbers (1, NULL); + variable e = add_numbers (1,); + variable f = add_numbers (,); +#v- + It should be clear that after these statements have been executed, + \var{c} will have a value of \exmp{3}. It should also be clear + that \var{d} will have a value of \exmp{1} because \var{NULL} has + been passed as the second parameter. One feature of the language + is that if a parameter has been omitted from a function call, the + variable associated with that parameter will be set to \var{NULL}. + Hence, \var{e} and \var{f} will be set to \exmp{1} and \exmp{0}, + respectively. + + The \var{Null_Type} data type also plays an important role in the + context of \em{structures}. + +\sect1{Ref_Type} + Objects of \var{Ref_Type} are created using the unary + \em{reference} operator \var{&}. Such objects may be + \em{dereferenced} using the dereference operator \var{@}. For + example, +#v+ + variable sin_ref = &sin; + variable y = (@sin_ref) (1.0); +#v- + creates a reference to the \var{sin} function and assigns it to + \var{sin_ref}. The second statement uses the dereference operator + to call the function that \var{sin_ref} references. + + The \var{Ref_Type} is useful for passing functions as arguments to + other functions, or for returning information from a function via + its parameter list. The dereference operator is also used to create + an instance of a structure. For these reasons, further discussion + of this important type can be found in section ??? and section ???. + +\sect1{Array_Type and Struct_Type} + + Variables of type \var{Array_Type} and \var{Struct_Type} are known + as \em{container objects}. They are much more complicated than the + simple data types discussed so far and each obeys a special syntax. + For these reasons they are discussed in a separate chapters. + See ???. + +\sect1{DataType_Type Type} #%{{{ + + \slang defines a type called \var{DataType_Type}. Objects of + this type have values that are type names. For example, an integer + is an object of type \var{Integer_Type}. The literals of + \var{DataType_Type} include: +#v+ + Char_Type (signed character) + UChar_Type (unsigned character) + Short_Type (short integer) + UShort_Type (unsigned short integer) + Integer_Type (plain integer) + UInteger_Type (plain unsigned integer) + Long_Type (long integer) + ULong_Type (unsigned long integer) + Float_Type (single precision real) + Double_Type (double precision real) + Complex_Type (complex numbers) + String_Type (strings, C strings) + BString_Type (binary strings) + Struct_Type (structures) + Ref_Type (references) + Null_Type (NULL) + Array_Type (arrays) + DataType_Type (data types) +#v- + as well as the names of any other types that an application + defines. + + The built-in function \var{typeof} returns the data type of + its argument, i.e., a \var{DataType_Type}. For instance + \exmp{typeof(7)} returns \var{Integer_Type} and + \var{typeof(Integer_Type)} returns \var{DataType_Type}. One can use this + function as in the following example: +#v+ + if (Integer_Type == typeof (x)) message ("x is an integer"); +#v- + The literals of \var{DataType_Type} have other uses as well. One + of the most common uses of these literals is to create arrays, e.g., +#v+ + x = Complex_Type [100]; +#v- + creates an array of \exmp{100} complex numbers and assigns it to + \var{x}. +#%}}} + +#%}}} + +\sect{Typecasting: Converting from one Type to Another} + + Occasionally, it is necessary to convert from one data type to + another. For example, if you need to print an object as a string, + it may be necessary to convert it to a \var{String_Type}. The + \var{typecast} function may be used to perform such conversions. + For example, consider +#v+ + variable x = 10, y; + y = typecast (x, Double_Type); +#v- + After execution of these statements, \var{x} will have the integer + value \exmp{10} and \var{y} will have the double precision floating + point value \exmp{10.0}. If the object to be converted is an + array, the \var{typecast} function will act upon all elements of + the array. For example, +#v+ + variable x = [1:10]; % Array of integers + variable y = typecast (x, Double_Type); +#v- + will create an array of \exmp{10} double precision values and + assign it to \var{y}. One should also realize that it is not + always possible to perform a typecast. For example, any attempt to + convert an \var{Integer_Type} to a \var{Null_Type} will result in a + run-time error. + + Often the interpreter will perform implicit type conversions as necessary + to complete calculations. For example, when multiplying an + \var{Integer_Type} with a \var{Double_Type}, it will convert the + \var{Integer_Type} to a \var{Double_Type} for the purpose of the + calculation. Thus, the example involving the conversion of an + array of integers to an array of doubles could have been performed + by multiplication by \exmp{1.0}, i.e., +#v+ + variable x = [1:10]; % Array of integers + variable y = 1.0 * x; +#v- + + The \var{string} intrinsic function is similar to the typecast + function except that it converts an object to a string + representation. It is important to understand that a typecast from + some type to \var{String_Type} is \em{not} the same as converting + an object to its string operation. That is, + \exmp{typecast(x,String_Type)} is not equivalent to + \exmp{string(x)}. The reason for this is that when given an array, + the \var{typecast} function acts on each element of the array to + produce another array, whereas the \var{string} function produces a + a string. + + The \var{string} function is useful for printing the value of an + object. This use is illustrated in the following simple example: +#v+ + define print_object (x) + { + message (string (x)); + } +#v- + Here, the \var{message} function has been used because it writes a + string to the display. If the \var{string} function was not used + and the \var{message} function was passed an integer, a + type-mismatch error would have resulted. + +#%}}} + +\chapter{Identifiers} #%{{{ + + The names given to variables, functions, and data types are called + \em{identifiers}. There are some restrictions upon the actual + characters that make up an identifier. An identifier name must + start with a letter (\var{[A-Za-z]}), an underscore character, or a + dollar sign. The rest of the characters in the name can be any + combination of letters, digits, dollar signs, or underscore + characters. However, all identifiers whose name begins with two + underscore characters are reserved for internal use by the + interpreter and declarations of objects with such names should be + avoided. + + Examples of valid identifiers include: +#v+ + mary _3 _this_is_ok + a7e1 $44 _44$_Three +#v- + However, the following are not legal: +#v+ + 7abc 2e0 #xx +#v- + In fact, \exmp{2e0} actually specifies the real number + \exmp{2.0}. + + Although the maximum length of identifiers is unspecified by the + language, the length should be kept below \exmp{64} characters. + + The following identifiers are reserved by the language for use as + keywords: +#v+ + !if _for do mod sign xor + ERROR_BLOCK abs do_while mul2 sqr public + EXIT_BLOCK and else not static private + USER_BLOCK0 andelse exch or struct + USER_BLOCK1 break for orelse switch + USER_BLOCK2 case foreach pop typedef + USER_BLOCK3 chs forever return using + USER_BLOCK4 continue if shl variable + __tmp define loop shr while +#v- + In addition, the next major \slang release (v2.0) will reserve + \exmp{try} and \exmp{catch}, so it is probably a good idea to avoid + those words until then. + +#%}}} + +\chapter{Variables} #%{{{ + + A variable must be declared before it can be used, otherwise an + undefined name error will be generated. A variable is declared + using the \kw{variable} keyword, e.g, +#v+ + variable x, y, z; +#v- + declares three variables, \exmp{x}, \exmp{y}, and \exmp{z}. This + is an example of a variable declaration statement, and like all + statements, it must end in a semi-colon. + + Variables declared this way are untyped and inherit a type upon + assignment. The actual type checking is performed at run-time. For + example, +#v+ + x = "This is a string"; + x = 1.2; + x = 3; + x = 2i; +#v- + results in x being set successively to a string, a float, an + integer, and to a complex number (\exmp{0+2i}). Any attempt to use + a variable before it has acquired a type will result in an + uninitialized variable error. + + It is legal to put executable code in a variable declaration list. + That is, +#v+ + variable x = 1, y = sin (x); +#v- + are legal variable declarations. This also provides a convenient way + of initializing a variable. + + Variables are classified as either \em{global} or \em{local}. A + variable declared inside a function is said to be local and has no + meaning outside the function. A variable is said to be global if + it was declared outside a function. Global variables are further + classified as being \var{public}, \var{static}, or \var{private}, + according to the name space where they were defined. + See chapter ??? for more information about name spaces. + + The following global variables are predefined by the language and + are mainly used as convenience variables: +#v+ + $0 $1 $2 $3 $4 $5 $6 $7 $8 $9 +#v- + + An \em{intrinsic} variable is another type of global variable. + Such variables have a definite type which cannot be altered. + Variables of this type may also be defined to be read-only, or + constant variables. An example of an intrinsic variable is + \var{PI} which is a read-only double precision variable with a value + of approximately \exmp{3.14159265358979323846}. + +#%}}} + +\chapter{Operators} #%{{{ + + \slang supports a variety of operators that are grouped into three + classes: assignment operators, binary operators, and unary operators. + + An assignment operator is used to assign a value to a variable. + They will be discussed more fully in the context of the assignment + statement in section ???. + + An unary operator acts only upon a single quantity while a binary + operation is an operation between two quantities. The boolean + operator \var{not} is an example of an unary operator. Examples of + binary operators include the usual arithmetic operators + \var{+}, \var{-}, \var{*}, and \var{/}. The operator given by + \var{-} can be either an unary operator (negation) or a binary operator + (subtraction); the actual operation is determined from the context + in which it is used. + + Binary operators are used in algebraic forms, e.g., \exmp{a + b}. + Unary operators fall in one of two classes: postfix-unary or + prefix-unary. For example, in the expression \exmp{-x}, the minus + sign is a prefix-unary operator. + + Not all data types have binary or unary operations defined. For + example, while \var{String_Type} objects support the \var{+} + operator, they do not admit the \var{*} operator. + +\sect{Unary Operators} + + The \bf{unary} operators operate only upon a single operand. They + include: \var{not}, \var{~}, \var{-}, \var{@}, \var{&}, as well as the + increment and decrement operators \var{++} and \var{--}, + respectively. + + The boolean operator \var{not} acts only upon integers and produces + \var{0} if its operand is non-zero, otherwise it produces \var{1}. + + The bit-level not operator \var{~} performs a similar function, + except that it operates on the individual bits of its integer + operand. + + The arithmetic negation operator \var{-} is the most well-known + unary operator. It simply reverses the sign of its operand. + + The reference (\var{&}) and dereference (\var{@}) operators will be + discussed in greater detail in section ???. Similarly, the + increment (\var{++}) and decrement (\var{--}) operators will be + discussed in the context of the assignment operator. + +\sect{Binary Operators} #%{{{ + + The binary operators may be grouped according to several classes: + arithmetic operators, relational operators, boolean operators, and + bitwise operators. + + All binary and unary operators may be overloaded. For example, the + arithmetic plus operator has been overloaded by the + \var{String_Type} data type to permit concatenation between strings. + +\sect1{Arithmetic Operators} #%{{{ + + The arithmetic operators include \var{+}, \var{-}, \var{*}, \var{/}, + which perform addition, subtraction, multiplication, and division, + respectively. In addition to these, \slang supports the \var{mod} + operator as well as the power operator \var{^}. + + The data type of the result produced by the use of one of these + operators depends upon the data types of the binary participants. + If they are both integers, the result will be an integer. However, + if the operands are not of the same type, they will be converted to + a common type before the operation is performed. For example, if + one is a floating point value and the other is an integer, the + integer will be converted to a float. In general, the promotion + from one type to another is such that no information is lost, if + possible. As an example, consider the expression \exmp{8/5} which + indicates division of the integer \var{8} by the integer \var{5}. + The result will be the integer \var{1} and \em{not} the floating + point value \var{1.6}. However, \exmp{8/5.0} will produce + \var{1.6} because \exmp{5.0} is a floating point number. + +#%}}} + +\sect1{Relational Operators} #%{{{ + + The relational operators are \var{>}, \var{>=}, \var{<}, \var{<=}, + \var{==}, and \var{!=}. These perform the comparisons greater + than, greater than or equal, less than, less than or equal, equal, + and not equal, respectively. The result of one of these + comparisons is the integer \var{1} if the comparison is true, or + \var{0} if the comparison is false. For example, \exmp{6 >= 5} + returns \var{1}, but \var{6 == 5} produces + \var{0}. + +#%}}} + +\sect1{Boolean Operators} #%{{{ + There are only two boolean binary operators: \var{or} and + \var{and}. These operators are defined only for integers and + produce an integer result. The \var{or} operator returns \var{1} + if either of its operands are non-zero, otherwise it produces + \var{0}. The \var{and} operator produces \var{1} if and only if + both its operands are non-zero, otherwise it produces \var{0}. + + Neither of these operators perform the so-called boolean + short-circuit evaluation. For example, consider the expression: +#v+ + (x != 0) and (1/x > 10) +#v- + Here, if \var{x} were to have a value of zero, a division by zero error + would occur because even though \var{x!=0} evaluates to zero, the + \var{and} operator is not short-circuited and the \var{1/x} expression + would still be evaluated. Although these operators are not + short-circuited, \slang does have another mechanism of performing + short-circuit boolean evaluation via the \kw{orelse} and + \kw{andelse} expressions. See below for information about these + constructs. + +#%}}} + +\sect1{Bitwise Operators} #%{{{ + + The bitwise binary operators are defined only with integer operands + and are used for bit-level operations. Operators that fall in this + class include \var{&}, \var{|}, \var{shl}, \var{shr}, and + \var{xor}. The \var{&} operator performs a boolean AND operation + between the corresponding bits of the operands. Similarly, the + \var{|} operator performs the boolean OR operation on the bits. + The bit-shifting operators \var{shl} and \var{shr} shift the bits + of the first operand by the number given by the second operand to + the left or right, respectively. Finally, the \var{xor} performs + an EXCLUSIVE-OR operation. + + These operators are commonly used to manipulate variables whose + individual bits have distinct meanings. In particular, \var{&} is + usually used to test bits, \var{|} can be used to set bits, and + \var{xor} may be used to flip a bit. + + As an example of using \var{&} to perform tests on bits, consider + the following: The \jed text editor stores some of the information + about a buffer in a bitmapped integer variable. The value of this + variable may be retrieved using the \jed intrinsic function + \var{getbuf_info}, which actually returns four quantities: the + buffer flags, the name of the buffer, directory name, and file + name. For the purposes of this section, only the buffer flags are + of interest and can be retrieved via a function such as +#v+ + define get_buffer_flags () + { + variable flags; + (,,,flags) = getbuf_info (); + return flags; + } +#v- + The buffer flags is a bitmapped quantity where the 0th bit + indicates whether or not the buffer has been modified, the first + bit indicates whether or not autosave has been enabled for the + buffer, and so on. Consider for the moment the task of determining + if the buffer has been modified. This can be + determined by looking at the zeroth bit, if it is \var{0} the + buffer has not been modified, otherwise it has. Thus we can create + the function, +#v+ + define is_buffer_modified () + { + variable flags = get_buffer_flags (); + return (flags & 1); + } +#v- + where the integer \exmp{1} has been used since it has all of its + bits set to \var{0}, except for the zeroth one, which is set to + \var{1}. (At this point, it should also be apparent that bits are + numbered from zero, thus an \var{8} bit integer consists of bits + \var{0} to \var{7}, where \var{0} is the least significant bit and + \var{7} is the most significant one.) Similarly, we can create another + function +#v+ + define is_autosave_on () + { + variable flags = get_buffer_flags (); + return (flags & 2); + } +#v- + to determine whether or not autosave has been turned on for the + buffer. + + The \var{shl} operator may be used to form the integer with only + the \em{nth} bit set. For example, \exmp{1 shl 6} produces an + integer with all bits set to zero except the sixth bit, which is + set to one. The following example exploits this fact: +#v+ + define test_nth_bit (flags, nth) + { + return flags & (1 shl nth); + } +#v- + +#%}}} + +\sect1{Namespace operator} + The operator \var{->} is used to in conjunction with the name of a + namespace to access an object within the namespace. For example, + if \exmp{A} is the name of a namespace containing the variable + \var{v}, then \exmp{A->v} refers to that variable. + +\sect1{Operator Precedence} + +\sect1{Binary Operators and Functions Returning Multiple Values} #%{{{ + Care must be exercised when using binary operators with an operand + the returns multiple values. In fact, the current implementation + of the \slang language will produce incorrect results if both + operands of a binary expression return multiple values. \em{At + most, only one of operands of a binary expression can return + multiple values, and that operand must be the first one, not the + second.} For example, +#v+ + define read_line (fp) + { + variable line, status; + + status = fgets (&line, fp); + if (status == -1) + return -1; + return (line, status); + } +#v- + defines a function, \var{read_line} that takes a single argument, a + handle to an open file, and returns one or two values, depending + upon the return value of \var{fgets}. Now consider +#v+ + while (read_line (fp) > 0) + { + text = (); + % Do something with text + . + . + } +#v- + Here the relational binary operator \var{>} forms a comparison + between one of the return values (the one at the top of the stack) + and \var{0}. In accordance with the above rule, since \var{read_line} + returns multiple values, it occurs as the left binary operand. + Putting it on the right as in +#v+ + while (0 < read_line (fp)) % Incorrect + { + text = (); + % Do something with text + . + . + } +#v- + violates the rule and will result in the wrong answer. + +#%}}} + +#%}}} + +\sect{Mixing Integer and Floating Point Arithmetic} + + If a binary operation (\var{+}, \var{-}, \var{*} , \var{/}) is + performed on two integers, the result is an integer. If at least + one of the operands is a float, the other is converted to float and + the result is float. For example: +#v+ + 11 / 2 --> 5 (integer) + 11 / 2.0 --> 5.5 (float) + 11.0 / 2 --> 5.5 (float) + 11.0 / 2.0 --> 5.5 (float) +#v- + Finally note that only integers may be used as array indices, + loop control variables, and bit operations. The conversion + functions, \var{int} and \var{float}, may be used convert between + floats and ints where appropriate, e.g., +#v+ + int (1.5) --> 1 (integer) + float(1.5) --> 1.5 (float) + float (1) --> 1.0 (float) +#v- + +\sect{Short Circuit Boolean Evaluation} + + The boolean operators \var{or} and \var{and} \em{are not short + circuited} as they are in some languages. \slang uses + \var{orelse} and \var{andelse} expressions for short circuit boolean + evaluation. However, these are not binary operators. Expressions + of the form: +\begin{tscreen} + \em{expr-1} and \em{expr-2} and ... \em{expr-n} +\end{tscreen} + can be replaced by the short circuited version using \var{andelse}: +\begin{tscreen} + andelse {\em{expr-1}} {\em{expr-2}} ... {\em{expr-n}} +\end{tscreen} + A similar syntax holds for the \var{orelse} operator. For example, consider + the statement: +#v+ + if ((x != 0) and (1/x > 10)) do_something (); +#v- + Here, if \var{x} were to have a value of zero, a division by zero error + would occur because even though \var{x!=0} evaluates to zero, the + \var{and} operator is not short circuited and the \var{1/x} expression + would be evaluated causing division by zero. For this case, the + \var{andelse} expression could be used to avoid the problem: +#v+ + if (andelse + {x != 0} + {1 / x > 10}) do_something (); +#v- + +#%}}} + +\chapter{Statements} #%{{{ + + Loosely speaking, a \em{statement} is composed of \em{expressions} + that are grouped according to the syntax or grammar of the language + to express a complete computation. Statements are analogous to + sentences in a human language and expressions are like phrases. + All statements in the \slang language must end in a semi-colon. + + A statement that occurs within a function is executed only during + execution of the function. However, statements that occur outside + the context of a function are evaluated immediately. + + The language supports several different types of statements such as + assignment statements, conditional statements, and so forth. These + are described in detail in the following sections. + +\sect{Variable Declaration Statements} + Variable declarations were already discussed in chapter ???. For + the sake of completeness, a variable declaration is a statement of + the form +\begin{tscreen} + variable \em{variable-declaration-list} ; +\end{tscreen} + where the \em{variable-declaration-list} is a comma separated list + of one or more variable names with optional initializations, e.g., +#v+ + variable x, y = 2, z; +#v- +\sect{Assignment Statements} #%{{{ + + Perhaps the most well known form of statement is the \em{assignment + statement}. Statements of this type consist of a left-hand side, + an assignment operator, and a right-hand side. The left-hand side + must be something to which an assignment can be performed. Such + an object is called an \em{lvalue}. + + The most common assignment operator is the simple assignment + operator \var{=}. Simple of its use include +#v+ + x = 3; + x = some_function (10); + x = 34 + 27/y + some_function (z); + x = x + 3; +#v- + In addition to the simple assignment operator, \slang + also supports the assignment operators \var{+=} and \var{-=}. + Internally, \slang transforms +#v+ + a += b; +#v- + to +#v+ + a = a + b; +#v- + Similarly, \exmp{a -= b} is transformed to \exmp{a = a - b}. It is + extremely important to realize that, in general, \exmp{a+b} is not + equal to \exmp{b+a}. This means that \exmp{a+=b} is not the same + as \exmp{a=b+a}. As an example consider +#v+ + a = "hello"; a += "world"; +#v- + After execution of these two statements, \var{a} will have the + value \exmp{"helloworld"} and not \exmp{"worldhello"}. + + Since adding or subtracting \exmp{1} from a variable is quite + common, \slang also supports the unary increment and decrement + operators \exmp{++}, and \exmp{--}, respectively. That is, for + numeric data types, +#v+ + x = x + 1; + x += 1; + x++; +#v- + are all equivalent. Similarly, +#v+ + x = x - 1; + x -= 1; + x--; +#v- + are also equivalent. + + Strictly speaking, \var{++} and \var{--} are unary operators. When + used as \var{x++}, the \var{++} operator is said to be a + \em{postfix-unary} operator. However, when used as \var{++x} it is + said to be a \em{prefix-unary} operator. The current + implementation does not distinguish between the two forms, thus + \var{x++} and \var{++x} are equivalent. The reason for this + equivalence is \em{that assignment expressions do not return a value in + the \slang language} as they do in C. Thus one should exercise care + and not try to write C-like code such as +#v+ + x = 10; + while (--x) do_something (x); % Ok in C, but not in S-Lang +#v- + The closest valid \slang form involves a \em{comma-expression}: +#v+ + x = 10; + while (x--, x) do_something (x); % Ok in S-Lang and in C +#v- + + \slang also supports a \em{multiple-assignment} statement. It is + discussed in detail in section ???. + +#%}}} + +\sect{Conditional and Looping Statements} #%{{{ + + \slang supports a wide variety of conditional and looping + statements. These constructs operate on statements grouped together + in \em{blocks}. A block is a sequence of \slang statements enclosed + in braces and may contain other blocks. However, a block cannot + include function declarations. In the following, + \em{statement-or-block} refers to either a single + \slang statement or to a block of statements, and + \em{integer-expression} is an integer-valued expression. + \em{next-statement} represents the statement following the form + under discussion. + +\sect1{Conditional Forms} #%{{{ +\sect2{if} + The simplest condition statement is the \kw{if} statement. It + follows the syntax +\begin{tscreen} + if (\em{integer-expression}) \em{statement-or-block} + \em{next-statement} +\end{tscreen} + If \em{integer-expression} evaluates to a non-zero result, then the + statement or group of statements implied \em{statement-or-block} + will get executed. Otherwise, control will proceed to + \em{next-statement}. + + An example of the use of this type of conditional statement is +#v+ + if (x != 0) + { + y = 1.0 / x; + if (x > 0) z = log (x); + } +#v- + This example illustrates two \var{if} statements where the second + \var{if} statement is part of the block of statements that belong to + the first. + +\sect2{if-else} + Another form of \kw{if} statement is the \em{if-else} statement. + It follows the syntax: +\begin{tscreen} + if (\em{integer-expression}) \em{statement-or-block-1} + else \em{statement-or-block-2} + \em{next-statement} +\end{tscreen} + Here, if \em{expression} returns non-zero, + \em{statement-or-block-1} will get executed and control will pass + on to \em{next-statement}. However, if \em{expression} returns zero, + \em{statement-or-block-2} will get executed before continuing with + \em{next-statement}. A simple example of this form is +#v+ + if (x > 0) z = log (x); else error ("x must be positive"); +#v- + Consider the more complex example: +#v+ + if (city == "Boston") + if (street == "Beacon") found = 1; + else if (city == "Madrid") + if (street == "Calle Mayor") found = 1; + else found = 0; +#v- + This example illustrates a problem that beginners have with + \em{if-else} statements. The grammar presented above shows that + the this example is equivalent to +#v+ + if (city == "Boston") + { + if (street == "Beacon") found = 1; + else if (city == "Madrid") + { + if (street == "Calle Mayor") found = 1; + else found = 0; + } + } +#v- + It is important to understand the grammar and not be seduced by the + indentation! + +\sect2{!if} + + One often encounters \kw{if} statements similar to +\begin{tscreen} + if (\em{integer-expression} == 0) \em{statement-or-block} +\end{tscreen} + or equivalently, +\begin{tscreen} + if (not(\em{integer-expression})) \em{statement-or-block} +\end{tscreen} + The \kw{!if} statement was added to the language to simplify the + handling of such statements. It obeys the syntax +\begin{tscreen} + !if (\em{integer-expression}) \em{statement-or-block} +\end{tscreen} + and is functionally equivalent to +\begin{tscreen} + if (not (\em{expression})) \em{statement-or-block} +\end{tscreen} + +\sect2{orelse, andelse} + + These constructs were discussed earlier. The syntax for the + \var{orelse} statement is: +\begin{tscreen} + orelse {\em{integer-expression-1}} ... {\em{integer-expression-n}} +\end{tscreen} + This causes each of the blocks to be executed in turn until one of + them returns a non-zero integer value. The result of this statement + is the integer value returned by the last block executed. For + example, +#v+ + orelse { 0 } { 6 } { 2 } { 3 } +#v- + returns \var{6} since the second block is the first to return a + non-zero result. The last two block will not get executed. + + The syntax for the \var{andelse} statement is: +\begin{tscreen} + andelse {\em{integer-expression-1}} ... {\em{integer-expression-n}} +\end{tscreen} + Each of the blocks will be executed in turn until one of + them returns a zero value. The result of this statement is the + integer value returned by the last block executed. For example, +#v+ + andelse { 6 } { 2 } { 0 } { 4 } +#v- + returns \var{0} since the third block will be the last to execute. + +\sect2{switch} + The switch statement deviates the most from its C counterpart. The + syntax is: +#v+ + switch (x) + { ... : ...} + . + . + { ... : ...} +#v- + The `\var{:}' operator is a special symbol which means to test + the top item on the stack, and if it is non-zero, the rest of the block + will get executed and control will pass out of the switch statement. + Otherwise, the execution of the block will be terminated and the process + will be repeated for the next block. If a block contains no + \var{:} operator, the entire block is executed and control will + pass onto the next statement following the \kw{switch} statement. + Such a block is known as the \em{default} case. + + As a simple example, consider the following: +#v+ + switch (x) + { x == 1 : message("Number is one.");} + { x == 2 : message("Number is two.");} + { x == 3 : message("Number is three.");} + { x == 4 : message("Number is four.");} + { x == 5 : message("Number is five.");} + { message ("Number is greater than five.");} +#v- + Suppose \var{x} has an integer value of \exmp{3}. The first two + blocks will terminate at the `\var{:}' character because each of the + comparisons with \var{x} will produce zero. However, the third + block will execute to completion. Similarly, if \var{x} is + \exmp{7}, only the last block will execute in full. + + A more familiar way to write the previous example used the + \kw{case} keyword: +#v+ + switch (x) + { case 1 : print("Number is one.");} + { case 2 : print("Number is two.");} + { case 3 : print("Number is three.");} + { case 4 : print("Number is four.");} + { case 5 : print("Number is five.");} + { print ("Number is greater than five.");} +#v- + The \var{case} keyword is a more useful comparison operator because + it can perform a comparison between different data types while + using \var{==} may result in a type-mismatch error. For example, +#v+ + switch (x) + { (x == 1) or (x == "one") : print("Number is one.");} + { (x == 2) or (x == "two") : print("Number is two.");} + { (x == 3) or (x == "three") : print("Number is three.");} + { (x == 4) or (x == "four") : print("Number is four.");} + { (x == 5) or (x == "five") : print("Number is five.");} + { print ("Number is greater than five.");} +#v- + will fail because the \var{==} operation is not defined between + strings and integers. The correct way to write this to use the + \var{case} keyword: +#v+ + switch (x) + { case 1 or case "one" : print("Number is one.");} + { case 2 or case "two" : print("Number is two.");} + { case 3 or case "three" : print("Number is three.");} + { case 4 or case "four" : print("Number is four.");} + { case 5 or case "five" : print("Number is five.");} + { print ("Number is greater than five.");} +#v- + +#%}}} + +\sect1{Looping Forms} #%{{{ + +\sect2{while} + The \kw{while} statement follows the syntax +\begin{tscreen} + while (\em{integer-expression}) \em{statement-or-block} + \em{next-statement} +\end{tscreen} + It simply causes \em{statement-or-block} to get executed as long as + \em{integer-expression} evaluates to a non-zero result. For + example, +#v+ + i = 10; + while (i) + { + i--; + newline (); + } +#v- + will cause the \var{newline} function to get called 10 times. + However, +#v+ + i = -10; + while (i) + { + i--; + newline (); + } +#v- + would loop forever (or until \var{i} wraps from the most negative + integer value to the most positive and then decrements to zero). + + + If you are a C programmer, do not let the syntax of the language + seduce you into writing this example as you would in C: +#v+ + i = 10; + while (i--) newline (); +#v- + The fact is that expressions such as \var{i--} do not return a + value in \slang as they do in C. If you must write this way, use + the comma operator as in +#v+ + i = 10; + while (i, i--) newline (); +#v- + +\sect2{do...while} + The \kw{do...while} statement follows the syntax +\begin{tscreen} + do + \em{statement-or-block} + while (\em{integer-expression}); +\end{tscreen} + The main difference between this statement and the \var{while} + statement is that the \kw{do...while} form performs the test + involving \em{integer-expression} after each execution + of \em{statement-or-block} rather than before. This guarantees that + \em{statement-or-block} will get executed at least once. + + A simple example from the \jed editor follows: +#v+ + bob (); % Move to beginning of buffer + do + { + indent_line (); + } + while (down (1)); +#v- + This will cause all lines in the buffer to get indented via the + \jed intrinsic function \var{indent_line}. + +\sect2{for} + Perhaps the most complex looping statement is the \kw{for} + statement; nevertheless, it is a favorite of many programmers. + This statement obeys the syntax +\begin{tscreen} + for (\em{init-expression}; \em{integer-expression}; \em{end-expression}) + \em{statement-or-block} + \em{next-statement} +\end{tscreen} + In addition to \em{statement-or-block}, its specification requires + three other expressions. When executed, the \kw{for} statement + evaluates \em{init-expression}, then it tests + \em{integer-expression}. If \em{integer-expression} returns zero, + control passes to \em{next-statement}. Otherwise, it executes + \em{statement-or-block} as long as \em{integer-expression} + evaluates to a non-zero result. After every execution of + \em{statement-or-block}, \em{end-expression} will get evaluated. + + This statement is \em{almost} equivalent to +\begin{tscreen} + \em{init-expression}; + while (\em{integer-expression}) + { + \em{statement-or-block} + \em{end-expression}; + } +\end{tscreen} + The reason that they are not fully equivalent involves what happens + when \em{statement-or-block} contains a \kw{continue} statement. + + Despite the apparent complexity of the \kw{for} statement, it is + very easy to use. As an example, consider +#v+ + s = 0; + for (i = 1; i <= 10; i++) s += i; +#v- + which computes the sum of the first 10 integers. + +\sect2{loop} + The \kw{loop} statement simply executes a block of code a fixed + number of times. It follows the syntax +\begin{tscreen} + loop (\em{integer-expression}) \em{statement-or-block} + \em{next-statement} +\end{tscreen} + If the \em{integer-expression} evaluates to a positive integer, + \em{statement-or-block} will get executed that many times. + Otherwise, control will pass to \em{next-statement}. + + For example, +#v+ + loop (10) newline (); +#v- + will cause the function \var{newline} to get called 10 times. + +\sect2{_for} + Like \kw{loop}, the \kw{_for} statement simply executes a block of + code a fixed number times. Unlike the \kw{loop} statement, the + \kw{_for} loop is useful in situations where the loop index is + needed. It obeys the syntax +\begin{tscreen} + _for (\em{first-value}, \em{last-value}, \em{increment}) + \em{block} + \em{next-statement} +\end{tscreen} + Each time through the loop, the current value of the loop index is + pushed onto the stack. The first time through, the loop index + will have the value of \em{first-value}. The second time its value + will be \em{first-value} + \em{increment}, and so on. The loop + will terminate when the value of the loop index exceeds + \em{last-value}. The current implementation requires the control + parameters \em{first-value}, \em{last-value}, and \em{increment} to + be integered valued expressions. + + For example, it may be used to compute the sum of the first ten + integers: +#v+ + s = 0; + _for (1, 10, 1) + { + i = (); + s += i; + } +#v- + + The execution speed of the \kw{_for} loop is more than twice as fast as + the more powerful \kw{for} loop making it a better choice for many + situations. + +\sect2{forever} + The \kw{forever} statement is similar to the \kw{loop} statement + except that it loops forever, or until a \kw{break} or a + \kw{return} statement is executed. It obeys the syntax +\begin{tscreen} + forever \em{statement-or-block} +\end{tscreen} + A trivial example of this statement is +#v+ + n = 10; + forever + { + if (n == 0) break; + newline (); + n--; + } +#v- + +\sect2{foreach} + The \kw{foreach} statement is used to loop over one or more + statements for every element in a container object. A container + object is a data type that consists of other types. Examples + include both ordinary and associative arrays, structures, and + strings. Every time through the loop the current member of the + object is pushed onto the stack. + + The simple type of \kw{foreach} statement obeys the syntax +\begin{tscreen} + foreach (\em{container-object}) \em{statement-or-block} +\end{tscreen} + Here \em{container-object} can be an expression that returns a + container object. A simple example is +#v+ + foreach (["apple", "peach", "pear"]) + { + fruit = (); + process_fruit (fruit); + } +#v- + This example shows that if the container object is an array, then + successive elements of the array are pushed onto the stack prior to + each execution cycle. If the container object is a string, then + successive characters of the string are pushed onto the stack. + + What actually gets pushed onto the stack may be controlled via the + \kw{using} form of the \kw{foreach} statement. This more complex + type of \kw{foreach} statement follows the syntax +\begin{tscreen} + foreach ( \em{container-object} ) using ( \em{control-list} ) + \em{statement-or-block} +\end{tscreen} + The allowed values of \em{control-list} will depend upon the type + of container object. For associative arrays (\var{Assoc_Type}), + \em{control-list} specified whether \em{keys}, \em{values}, or both + are pushed onto the stack. For example, +#v+ + foreach (a) using ("keys") + { + k = (); + . + . + } +#v- + results in the keys of the associative array \var{a} being pushed + on the list. However, +#v+ + foreach (a) using ("values") + { + v = (); + . + . + } +#v- + will cause the values to be used, and +#v+ + foreach (a) using ("keys", "values") + { + (k,v) = (); + . + . + } +#v- + will use both the keys and values of the array. + + Similarly, for linked-lists of structures, one may walk the list via + code like +#v+ + foreach (linked_list) using ("next") + { + s = (); + . + . + } +#v- + This \kw{foreach} statement is equivalent +#v+ + s = linked_list; + while (s != NULL) + { + . + . + s = s.next; + } +#v- + Consult the type-specific documentation for a discussion of the + \kw{using} control words, if any, appropriate for a given type. + +\sect{break, return, continue} + + \slang also includes the non-local transfer functions \var{return}, \var{break}, + and \var{continue}. The \var{return} statement causes control to return to the + calling function while the \var{break} and \var{continue} statements are used in + the context of loop structures. Consider: +#v+ + define fun () + { + forever + { + s1; + s2; + .. + if (condition_1) break; + if (condition_2) return; + if (condition_3) continue; + .. + s3; + } + s4; + .. + } +#v- + Here, a function \var{fun} has been defined that contains a \var{forever} + loop consisting of statements \var{s1}, \var{s2},\ldots,\var{s3}, and + three \var{if} statements. As long as the expressions \var{condition_1}, + \var{condition_2}, and \var{condition_3} evaluate to zero, the statements + \var{s1}, \var{s2},\ldots,\var{s3} will be repeatedly executed. However, + if \var{condition_1} returns a non-zero value, the \var{break} statement + will get executed, and control will pass out of the \var{forever} loop to + the statement immediately following the loop which in this case is + \var{s4}. Similarly, if \var{condition_2} returns a non-zero number, + the \var{return} statement will cause control to pass back to the + caller of \var{fun}. Finally, the \var{continue} statement will + cause control to pass back to the start of the loop, skipping the + statement \var{s3} altogether. + + +#%}}} + +#%}}} + +#%}}} + +\chapter{Functions} #%{{{ + + A function may be thought of as a group of statements that work + together to perform a computation. While there are no imposed + limits upon the number statements that may occur within a function, + it is considered poor programming practice if a function contains + many statements. This notion stems from the belief that a function + should have a simple, well defined purpose. + +\sect{Declaring Functions} #%{{{ + + Like variables, functions must be declared before they can be used. The + \kw{define} keyword is used for this purpose. For example, +#v+ + define factorial (); +#v- + is sufficient to declare a function named \var{factorial}. Unlike + the \var{variable} keyword used for declaring variables, the + \var{define} keyword does not accept a list of names. + + Usually, the above form is used only for recursive functions. In + most cases, the function name is almost always followed by a + parameter list and the body of the function: +\begin{tscreen} + define \em{function-name} (\em{parameter-list}) + { + \em{statement-list} + } +\end{tscreen} + The \em{function-name} is an identifier and must conform to the + naming scheme for identifiers discussed in chapter ???. + The \em{parameter-list} is a comma-separated list of variable names + that represent parameters passed to the function, and + may be empty if no parameters are to be passed. + The body of the function is enclosed in braces and consists of zero + or more statements (\em{statement-list}). + + The variables in the \em{parameter-list} are implicitly declared, + thus, there is no need to declare them via a variable declaration + statement. In fact any attempt to do so will result in a syntax + error. + +#%}}} + +\sect{Parameter Passing Mechanism} #%{{{ + + Parameters to a function are always passed by value and never by + reference. To see what this means, consider +#v+ + define add_10 (a) + { + a = a + 10; + } + variable b = 0; + add_10 (b); +#v- + Here a function \var{add_10} has been defined, which when executed, + adds \exmp{10} to its parameter. A variable \var{b} has also been + declared and initialized to zero before it is passed to + \var{add_10}. What will be the value of \var{b} after the call to + \var{add_10}? If \slang were a language that passed parameters by + reference, the value of \var{b} would be changed to + \var{10}. However, \slang always passes by value, which means that + \var{b} would retain its value of zero after the function call. + + \slang does provide a mechanism for simulating pass by reference + via the reference operator. See the next section for more details. + + If a function is called with a parameter in the parameter list + omitted, the corresponding variable in the function will be set to + \var{NULL}. To make this clear, consider the function +#v+ + define add_two_numbers (a, b) + { + if (a == NULL) a = 0; + if (b == NULL) b = 0; + return a + b; + } +#v- + This function must be called with two parameters. However, we can + omit one or both of the parameters by calling it in one of the + following ways: +#v+ + variable s = add_two_numbers (2,3); + variable s = add_two_numbers (2,); + variable s = add_two_numbers (,3); + variable s = add_two_numbers (,); +#v- + The first example calls the function using both parameters; + however, at least one of the parameters was omitted in the other + examples. The interpreter will implicitly convert the last three + examples to +#v+ + variable s = add_two_numbers (2, NULL); + variable s = add_two_numbers (NULL, 3); + variable s = add_two_numbers (NULL, NULL); +#v- + It is important to note that this mechanism is available only for + function calls that specify more than one parameter. That is, +#v+ + variable s = add_10 (); +#v- + is \em{not} equivalent to \exmp{add_10(NULL)}. The reason for this + is simple: the parser can only tell whether or not \var{NULL} should + be substituted by looking at the position of the comma character in + the parameter list, and only function calls that indicate more than + one parameter will use a comma. A mechanism for handling single + parameter function calls is described in the next section. + +#%}}} + +\sect{Referencing Variables} #%{{{ + + One can achieve the effect of passing by reference by using the + reference (\var{&}) and dereference (\var{@}) operators. Consider + again the \var{add_10} function presented in the previous section. + This time we write it as +#v+ + define add_10 (a) + { + @a = @a + 10; + } + variable b = 0; + add_10 (&b); +#v- + The expression \var{&b} creates a \em{reference} to the variable + \var{b} and it is the reference that gets passed to \var{add_10}. + When the function \var{add_10} is called, the value of \var{a} will + be a reference to \var{b}. It is only by \em{dereferencing} this + value that \var{b} can be accessed and changed. So, the statement + \exmp{@a=@a+10;} should be read `add \exmp{10}' to the value of the + object that \var{a} references and assign the result to the object + that \var{a} references. + + The reader familiar with C will note the similarity between + \em{references} in \slang and \em{pointers} in C. + + One of the main purposes for references is that this mechanism + allows reference to functions to be passed to other functions. As + a simple example from elementary calculus, consider the following + function which returns an approximation to the derivative of another + function at a specified point: +#v+ + define derivative (f, x) + { + variable h = 1e-6; + return ((@f)(x+h) - (@f)(x)) / h; + } +#v- + It can be used to differentiate the function +#v+ + define x_squared (x) + { + return x^2; + } +#v- + at the point \exmp{x = 3} via the expression + \exmp{derivative(&x_squared,3)}. + + +#%}}} + +\sect{Functions with a Variable Number of Arguments} #%{{{ + + \slang functions may be defined to take a variable number of + arguments. The reason for this is that the calling routine pushes + the arguments onto the stack before making a function call, and it + is up to the called function to pop the values off the stack and + make assignments to the variables in the parameter list. These + details are, for the most part, hidden from the programmer. + However, they are important when a variable number of arguments are + passed. + + Consider the \var{add_10} example presented earlier. This time it + is written +#v+ + define add_10 () + { + variable x; + x = (); + return x + 10; + } + variable s = add_10 (12); % ==> s = 22; +#v- + For the uninitiated, this example looks as if it + is destined for disaster. The \var{add_10} function looks like it + accepts zero arguments, yet it was called with a single argument. + On top of that, the assignment to \var{x} looks strange. The truth + is, the code presented in this example makes perfect sense, once you + realize what is happening. + + First, consider what happened when \var{add_10} is called with the + the parameter \exmp{12}. Internally, \exmp{12} is + pushed onto the stack and then the function called. Now, + consider the function itself. \var{x} is a variable local to the + function. The strange looking assignment `\exmp{x=()}' simply + takes whatever is on the stack and assigns it to \var{x}. In + other words, after this statement, the value of \var{x} will be + \exmp{12}, since \exmp{12} will be at the top of the stack. + + A generic function of the form +#v+ + define function_name (x, y, ..., z) + { + . + . + } +#v- + is internally transformed by the interpreter to +#v+ + define function_name () + { + variable x, y, ..., z; + z = (); + . + . + y = (); + x = (); + . + . + } +#v- + before further parsing. (The \var{add_10} function, as defined above, is + already in this form.) With this knowledge in hand, one can write a + function that accepts a variable number of arguments. Consider the + function: +#v+ + define average_n (n) + { + variable x, y; + variable s; + + if (n == 1) + { + x = (); + s = x; + } + else if (n == 2) + { + y = (); + x = (); + s = x + y; + } + else error ("average_n: only one or two values supported"); + + return s / n; + } + variable ave1 = average_n (3.0, 1); % ==> 3.0 + variable ave2 = average_n (3.0, 5.0, 2); % ==> 4.0 +#v- + Here, the last argument passed to \var{average_n} is an integer + reflecting the number of quantities to be averaged. Although this + example works fine, its principal limitation is obvious: it only + supports one or two values. Extending it to three or more values + by adding more \exmp{else if} constructs is rather straightforward but + hardly worth the effort. There must be a better way, and there is: +#v+ + define average_n (n) + { + variable s, x; + s = 0; + loop (n) + { + x = (); % get next value from stack + s += x; + } + return s / n; + } +#v- + The principal limitation of this approach is that one must still + pass an integer that specifies how many values are to be averaged. + + Fortunately, a special variable exists that is local to every function + and contains the number of values that were passed to the function. + That variable has the name \var{_NARGS} and may be used as follows: +#v+ + define average_n () + { + variable x, s = 0; + + if (_NARGS == 0) error ("Usage: ave = average_n (x, ...);"); + + loop (_NARGS) + { + x = (); + s += x; + } + return s / _NARGS; + } +#v- + Here, if no arguments are passed to the function, a simple message + that indicates how it is to be used is printed out. + + +#%}}} + + +\sect{Returning Values} + + As stated earlier, the usual way to return values from a function + is via the \kw{return} statement. This statement has the + simple syntax +\begin{tscreen} + return \em{expression-list} ; +\end{tscreen} + where \em{expression-list} is a comma separated list of expressions. + If the function does not return any values, the expression list + will be empty. As an example of a function that can return + multiple values, consider +#v+ + define sum_and_diff (x, y) + { + variable sum, diff; + + sum = x + y; diff = x - y; + return sum, diff; + } +#v- + which is a function returning two values. + + It is extremely important to note that \em{the calling routine must + explicitly handle all values returned by a function}. Although + some languages such as C do not have this restriction, \slang does + and it is a direct result of a \slang function's ability to return + many values and accept a variable number of parameters. Examples + of properly handling the above function include +#v+ + variable s, d; + (s, d) = sum_and_diff (5, 4); % ignore neither + (s,) = sum_and_diff (5, 4); % ignore diff + (,) = sum_and_diff (5, 4); % ignore both sum and diff +#v- + See the section below on assignment statements for more information + about this important point. + +\sect{Multiple Assignment Statement} #%{{{ + + \slang functions can return more than one value, e.g., +#v+ + define sum_and_diff (x, y) + { + return x + y, x - y; + } +#v- + returns two values. It accomplishes this by placing both values on + the stack before returning. If you understand how \slang functions + handle a variable number of parameters (section ???), then it + should be rather obvious that one assigns such values to variables. + One way is to use, e.g., +#v+ + sum_and_diff (9, 4); + d = (); + s = (); +#v- + + However, the most convenient way to accomplish this is to use a + \em{multiple assignment statement} such as +#v+ + (s, d) = sum_and_diff (9, 4); +#v- + The most general form of the multiple assignment statement is +#v+ + ( var_1, var_2, ..., var_n ) = expression; +#v- + In fact, internally the interpreter transforms this statement into + the form +#v+ + expression; var_n = (); ... var_2 = (); var_1 = (); +#v- + for further processing. + + If you do not care about one of return values, simply omit the + variable name from the list. For example, +#v+ + (s, ) = sum_and_diff (9, 4); +#v- + assigns the sum of \exmp{9} and \exmp{4} to \var{s} and the + difference (\exmp{9-4}) will be removed from the stack. + + As another example, the \jed editor provides a function called + \var{down} that takes an integer argument and returns an integer. + It is used to move the current editing position down the number of + lines specified by the argument passed to it. It returns the number + of lines it successfully moved the editing position. Often one does + not care about the return value from this function. Although it is + always possible to handle the return value via +#v+ + variable dummy = down (10); +#v- + it is more convenient to use a multiple assignment expression and + omit the variable name, e.g., +#v+ + () = down (10); +#v- + + Some functions return a \em{variable number} of values instead of a + \em{fixed number}. Usually, the value at the top of the stack will + indicate the actual number of return values. For such functions, + the multiple assignment statement cannot directly be used. To see + how such functions can be dealt with, consider the following + function: +#v+ + define read_line (fp) + { + variable line; + if (-1 == fgets (&line, fp)) + return -1; + return (line, 0); + } +#v- + This function returns either one or two values, depending upon the + return value of \var{fgets}. Such a function may be handled as in + the following example: +#v+ + status = read_line (fp); + if (status != -1) + { + s = (); + . + . + } +#v- + In this example, the \em{last} value returned by \var{read_line} is + assigned to \var{status} and then tested. If it is non-zero, the + second return value is assigned to \var{s}. In particular note the + empty set of parenthesis in the assignment to \var{s}. This simply + indicates that whatever is on the top of the stack when the + statement is executed will be assigned to \var{s}. + + Before leaving this section it is important to reiterate the fact + that if a function returns a value, the caller must deal with that + return value. Otherwise, the value will continue to live onto the + stack and may eventually lead to a stack overflow error. + Failing to handle the return value of a function is the + most common mistake that inexperienced \slang programmers make. + For example, the \var{fflush} function returns a value that many C + programmer's never check. Instead of writing +#v+ + fflush (fp); +#v- + as one could in C, a \slang programmer should write +#v+ + () = fflush (fp); +#v- + in \slang. (Many good C programmer's write \exmp{(void)fflush(fp)} + to indicate that the return value is being ignored). + +#%}}} + +\sect{Exit-Blocks} + + An \em{exit-block} is a set of statements that get executed when a + functions returns. They are very useful for cleaning up when a + function returns via an explicit call to \var{return} from deep + within a function. + + An exit-block is created by using the \kw{EXIT_BLOCK} keyword + according to the syntax +\begin{tscreen} + EXIT_BLOCK { \em{statement-list} } +\end{tscreen} + where \em{statement-list} represents the list of statements that + comprise the exit-block. The following example illustrates the use + of an exit-block: +#v+ + define simple_demo () + { + variable n = 0; + + EXIT_BLOCK { message ("Exit block called."); } + + forever + { + if (n == 10) return; + n++; + } + } +#v- + Here, the function contains an exit-block and a \var{forever} loop. + The loop will terminate via the \kw{return} statement when \var{n} + is 10. Before it returns, the exit-block will get executed. + + A function can contain multiple exit-blocks, but only the last + one encountered during execution will actually get executed. For + example, +#v+ + define simple_demo (n) + { + EXIT_BLOCK { return 1; } + + if (n != 1) + { + EXIT_BLOCK { return 2; } + } + return; + } +#v- + If \var{1} is passed to this function, the first exit-block will + get executed because the second one would not have been encountered + during the execution. However, if some other value is passed, the + second exit-block would get executed. This example also + illustrates that it is possible to explicitly return from an + exit-block, although nested exit-blocks are illegal. + +#%}}} + +\chapter{Name Spaces} #%{{{ + + By default, all global variables and functions are defined in the + global namespace. In addition to the global namespace, every + compilation unit (e.g., a file containing \slang code) has an + anonymous namespace. Objects may be defined in the anonymous + namespace via the \var{static} declaration keyword. For example, +#v+ + static variable x; + static define hello () { message ("hello"); } +#v- + defines a variable \var{x} and a function \var{hello} in the + anonymous namespace. This is useful when one wants to define + functions and variables that are only to be used within the file, or + more precisely the compilation unit, that defines them. + + The \var{implements} function may be used to give the anonymous + namespace a name to allow access to its objects from outside the + compilation unit that defines them. For example, +#v+ + implements ("foo"); + static variable x; +#v- + allows the variable \var{x} to be accessed via \var{foo->x}, e.g., +#v+ + if (foo->x == 1) foo->x = 2; +#v- + + The \var{implements} function does more than simply giving the + anonymous namespace a name. It also changes the default variable + and function declaration mode from \var{public} to \var{static}. + That is, +#v+ + implements ("foo"); + variable x; +#v- + and +#v+ + implements ("foo"); + static variable x; +#v- + are equivalent. Then to create a public object within the + namespace, one must explicitly use the \var{public} keyword. + + Finally, the \var{private} keyword may be used to create an object + that is truly private within the compilation unit. For example, +#v+ + implements ("foo"); + variable x; + private variable y; +#v- + allows \var{x} to be accessed from outside the namespace via + \var{foo->x}, however \var{y} cannot be accessed. + +#%}}} + +\chapter{Arrays} #%{{{ + + An array is a container object that can contain many values of one + data type. Arrays are very useful objects and are indispensable + for certain types of programming. The purpose of this chapter is + to describe how arrays are defined and used in the \slang language. + +\sect{Creating Arrays} #%{{{ + + The \slang language supports multi-dimensional arrays of all data + types. Since the \var{Array_Type} is a data type, one can even + have arrays of arrays. To create a multi-dimensional array of + \em{SomeType} use the syntax +#v+ + SomeType [dim0, dim1, ..., dimN] +#v- + Here \em{dim0}, \em{dim1}, ... \em{dimN} specify the size of + the individual dimensions of the array. The current implementation + permits arrays consist of up to \var{7} dimensions. When a + numeric array is created, all its elements are initialized to zero. + The initialization of other array types depend upon the data type, + e.g., \var{String_Type} and \var{Struct_Type} arrays are + initialized to \var{NULL}. + + As a concrete example, consider +#v+ + a = Integer_Type [10]; +#v- + which creates a one-dimensional array of \exmp{10} integers and + assigns it to \var{a}. + Similarly, +#v+ + b = Double_Type [10, 3]; +#v- + creates a \var{30} element array of double precision numbers + arranged in \var{10} rows and \var{3} columns, and assigns it to + \var{b}. + +\sect1{Range Arrays} + + There is a more convenient syntax for creating and initializing a + 1-d arrays. For example, to create an array of ten + integers whose elements run from \exmp{1} through \exmp{10}, one + may simply use: +#v+ + a = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]; +#v- + Similarly, +#v+ + b = [1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0, 10.0]; +#v- + specifies an array of ten doubles. + + An even more compact way of specifying a numeric array is to use a + \em{range-array}. For example, +#v+ + a = [0:9]; +#v- + specifies an array of 10 integers whose elements range from \var{0} + through \var{9}. The most general form of a range array is +#v+ + [first-value : last-value : increment] +#v- + where the \em{increment} is optional and defaults to \exmp{1}. This + creates an array whose first element is \em{first-value} and whose + successive values differ by \em{increment}. \em{last-value} sets + an upper limit upon the last value of the array as described below. + + If the range array \var{[a:b:c]} is integer valued, then the + interval specified by \var{a} and \var{b} is closed. That is, the + kth element of the array \math{x_k} is given by \math{x_k=a+ck} and + must satisfy \math{a<=x_k<=b}. Hence, the number of elements in an + integer range array is given by the expression \math{1 + (b-a)/c}. + + The situation is somewhat more complicated for floating point range + arrays. The interval specified by a floating point range array + \var{[a:b:c]} is semi-open such that \var{b} is not contained in + the interval. In particular, the kth element of \var{[a:b:c]} is + given by \math{x_k=a+kc} such that \math{a<=x_k=0}, and \math{b [1,2,3,4,5] + [1.0:5.0:1.0] ==> [1.0, 2.0, 3.0, 4.0] + [5:1:-1] ==> [5,4,3,2,1] + [5.0:1.0:-1.0] ==> [5.0, 4.0, 3.0, 2.0]; + [1:1] ==> [1] + [1.0:1.0] ==> [] + [1:-3] ==> [] +#v- + +\sect1{Creating arrays via the dereference operator} + + Another way to create an array is apply the dereference operator + \var{@} to the \var{DataType_Type} literal \var{Array_Type}. The + actual syntax for this operation resembles a function call +\begin{tscreen} + variable a = @Array_Type (\em{data-type}, \em{integer-array}); +\end{tscreen} + where \em{data-type} is of type \var{DataType_Type} and + \em{integer-array} is a 1-d array of integers that specify the size + of each dimension. For example, +#v+ + variable a = @Array_Type (Double_Type, [10, 20]); +#v- + will create a \exmp{10} by \var{20} array of doubles and assign it + to \var{a}. This method of creating arrays derives its power from + the fact that it is more flexible than the methods discussed in this + section. We shall encounter it again in section ??? in the context + of the \var{array_info} function. + +#%}}} + +\sect{Reshaping Arrays} #%{{{ + It is sometimes possible to change the `shape' of an array using + the \var{reshape} function. For example, a 1-d 10 element array + may be reshaped into a 2-d array consisting of 5 rows and 2 + columns. The only restriction on the operation is that the arrays + must be commensurate. The \var{reshape} function follows the + syntax +\begin{tscreen} + reshape (\em{array-name}, \em{integer-array}); +\end{tscreen} + where \em{array-name} specifies the array to be reshaped to have + the dimensions given by \var{integer-array}, a 1-dimensional array of + integers. It is important to note that this does \em{not} create a + new array, it simply reshapes the existing array. Thus, +#v+ + variable a = Double_Type [100]; + reshape (a, [10, 10]); +#v- + turns \var{a} into a \exmp{10} by \exmp{10} array. + +#%}}} + +\sect{Indexing Arrays} #%{{{ + An individual element of an array may be referred to by its + \em{index}. For example, \exmp{a[0]} specifies the zeroth element + of the one dimensional array \var{a}, and \exmp{b[3,2]} specifies + the element in the third row and second column of the two + dimensional array \var{b}. As in C array indices are numbered from + \var{0}. Thus if \var{a} is a one-dimensional array of ten + integers, the last element of the array is given by \var{a[9]}. + Using \var{a[10]} would result in a range error. + + A negative index may be used to index from the end of the array, + with \exmp{a[-1]} referring to the last element of \var{a}, + \exmp{a[-2]} referring to the next to the last element, and so on. + + One may use the indexed value like any other variable. For + example, to set the third element of an integer array to \var{6}, use +#v+ + a[2] = 6; +#v- + Similarly, that element may be used in an expression, such as +#v+ + y = a[2] + 7; +#v- + Unlike other \slang variables which inherit a type upon assignment, + array elements already have a type. For example, an attempt to + assign a string value to an element of an integer array will result + in a type-mismatch error. + + One may use any integer expression to index an array. A simple + example that computes the sum of the elements of 10 element 1-d + array is +#v+ + variable i, s; + s = 0; + for (i = 0; i < 10; i++) s += a[i]; +#v- + However, if the built-in \var{sum} function is available (not all programs + using \slang support this), then it should be used to compute the + sum of an array, e.g., +#v+ + s = sum(a); +#v- + + Unlike many other languages, \slang permits arrays to be indexed by + other integer arrays. Suppose that \var{a} is a 1-d array of 10 + doubles. Now consider: +#v+ + i = [6:8]; + b = a[i]; +#v- + Here, \var{i} is a 1-dimensional range array of three integers with + \exmp{i[0]} equal to \exmp{6}, \exmp{i[1]} equal to \exmp{7}, + and \exmp{i[2]} equal to \exmp{8}. The statement \var{b = a[i];} + will create a 1-d array of three doubles and assign it to \var{b}. + The zeroth element of \var{b}, \exmp{b[0]} will be set to the sixth + element of \var{a}, or \exmp{a[6]}, and so on. In fact, these two simple + statements are equivalent to +#v+ + b = Double_Type [3]; + b[0] = a[6]; + b[1] = a[7]; + b[2] = a[8]; +#v- + except that using an array of indices is not only much more + convenient, but executes much faster. + + More generally, one may use an index array to specify which + elements are to participate in a calculation. For example, consider +#v+ + a = Double_Type [1000]; + i = [0:499]; + j = [500:999]; + a[i] = -1.0; + a[j] = 1.0; +#v- + This creates an array of \exmp{1000} doubles and sets the first + \exmp{500} elements to \exmp{-1.0} and the last \exmp{500} to + \var{1.0}. Actually, one may do away with the \var{i} and \var{j} + variables altogether and use +#v+ + a = Double_Type [1000]; + a [[0:499]] = -1.0; + a [[500:999]] = 1.0; +#v- + It is important to understand the syntax used and, in particular, + to note that \exmp{a[[0:499]]} is \em{not} the same as + \exmp{a[0:499]}. In fact, the latter will generate a syntax error. + + Often, it is convenient to use a \em{rubber} range to specify + indices. For example, \exmp{a[[500:]]} specifies all elements of + \var{a} whose index is greater than or equal to \var{500}. Similarly, + \exmp{a[[:499]]} specifies the first 500 elements of \var{a}. + Finally, \exmp{a[[:]]} specifies all the elements of \var{a}; + however, using \exmp{a[*]} is more convenient. + + One should be careful when using index arrays with negative + elements. As pointed out above, a negative index is used to index + from the end of the array. That is, \exmp{a[-1]} refers to the + last element of \exmp{a}. How should \exmp{a[[[0:-1]]} be + interpreted? By itself, \var{[0:-1]} is an empty array; hence, one + might expect \exmp{a[[0:-1]]} to refer to no elements. However, + when used in an array indexing context, \exmp{[0:-1]} is + interpreted as an array indexing the first through the last + elements of the array. While this is a very convenient mechanism + to specifiy the last 3 elements of an array using + \exmp{a[[-3:-1]]}, it is very easy to forget these semantics. + + Now consider a multi-dimensional array. For simplicity, suppose + that \var{a} is a \exmp{100} by \exmp{100} array of doubles. Then + the expression \var{a[0, *]} specifies all elements in the zeroth + row. Similarly, \var{a[*, 7]} specifies all elements in the + seventh column. Finally, \var{a[[3:5][6:12]]} specifies the + \exmp{3} by \exmp{7} region consisting of rows \exmp{3}, \exmp{4}, + and \exmp{5}, and columns \exmp{6} through \exmp{12} of \var{a}. + + We conclude this section with a few examples. + + Here is a function that computes the trace (sum of the diagonal + elements) of a square 2 dimensional \var{n} by \var{n} array: +#v+ + define array_trace (a, n) + { + variable s = 0, i; + for (i = 0; i < n; i++) s += a[i, i]; + return s; + } +#v- + This fragment creates a \exmp{10} by \exmp{10} integer array, sets + its diagonal elements to \exmp{5}, and then computes the trace of + the array: +#v+ + a = Integer_Type [10, 10]; + for (j = 0; j < 10; j++) a[j, j] = 5; + the_trace = array_trace(a, 10); +#v- + We can get rid of the \kw{for} loop as follows: +#v+ + j = Integer_Type [10, 2]; + j[*,0] = [0:9]; + j[*,1] = [0:9]; + a[j] = 5; +#v- + Here, the goal was to construct a 2-d array of indices that + correspond to the diagonal elements of \var{a}, and then use that + array to index \var{a}. To understand how + this works, consider the middle statements. They are equivalent + to the following \var{for} loops: +#v+ + variable i; + for (i = 0; i < 10; i++) j[i, 0] = i; + for (i = 0; i < 10; i++) j[i, 1] = i; +#v- + Thus, row \var{n} of \var{j} will have the value \exmp{(n,n)}, + which is precisely what was sought. + + Another example of this technique is the function: +#v+ + define unit_matrix (n) + { + variable a = Integer_Type [n, n]; + variable j = Integer_Type [n, 2]; + j[*,0] = [0:n - 1]; + j[*,1] = [0:n - 1]; + + a[j] = 1; + return a; + } +#v- + This function creates an \var{n} by \var{n} unit matrix, + that is a 2-d \var{n} by \var{n} array whose elements are all zero + except on the diagonal where they have a value of \exmp{1}. + + +#%}}} + +\sect{Arrays and Variables} + + When an array is created and assigned to a variable, the + interpreter allocates the proper amount of space for the array, + initializes it, and then assigns to the variable a \em{reference} + to the array. So, a variable that represents an array has a value + that is really a reference to the array. This has several + consequences, some good and some bad. It is believed that the + advantages of this representation outweigh the disadvantages. + First, we shall look at the positive aspects. + + When a variable is passed to a function, it is always the value of + the variable that gets passed. Since the value of a variable + representing an array is a reference, a reference to the array gets + passed. One major advantage of this is rather obvious: it is a + fast and efficient way to pass the array. This also has another + consequence that is illustrated by the function +#v+ + define init_array (a, n) + { + variable i; + + for (i = 0; i < n; i++) a[i] = some_function (i); + } +#v- + where \var{some_function} is a function that generates a scalar + value to initialize the \em{ith} element. This function can be + used in the following way: +#v+ + variable X = Double_Type [100000]; + init_array (X, 100000); +#v- + Since the array is passed to the function by reference, there is no + need to make a separate copy of the \var{100000} element array. As + pointed out above, this saves both execution time and memory. The + other salient feature to note is that any changes made to the + elements of the array within the function will be manifested in the + array outside the function. Of course, in this case, this is a + desirable side-effect. + + To see the downside of this representation, consider: +#v+ + variable a, b; + a = Double_Type [10]; + b = a; + a[0] = 7; +#v- + What will be the value of \exmp{b[0]}? Since the value of \var{a} + is really a reference to the array of ten doubles, and that + reference was assigned to \var{b}, \var{b} also refers to the same + array. Thus any changes made to the elements of \var{a}, will also + be made implicitly to \var{b}. + + This begs the question: If the assignment of one variable which + represents an array, to another variable results in the assignment + of a reference to the array, then how does one make separate copies + of the array? There are several answers including using an index + array, e.g., \exmp{b = a[*]}; however, the most natural method is + to use the dereference operator: +#v+ + variable a, b; + a = Double_Type [10]; + b = @a; + a[0] = 7; +#v- + In this example, a separate copy of \var{a} will be created and + assigned to \var{b}. It is very important to note that \slang + never implicitly dereferences an object. So, one must explicitly use + the dereference operator. This means that the elements of a + dereferenced array are not themselves dereferenced. For example, + consider dereferencing an array of arrays, e.g., +#v+ + variable a, b; + a = Array_Type [2]; + a[0] = Double_Type [10]; + a[1] = Double_Type [10]; + b = @a; +#v- + In this example, \exmp{b[0]} will be a reference to the array that + \exmp{a[0]} references because \exmp{a[0]} was not explicitly + dereferenced. + +\sect{Using Arrays in Computations} #%{{{ + + Many functions and operations work transparently with arrays. + For example, if \var{a} and \var{b} are arrays, then the sum + \exmp{a + b} is an array whose elements are formed from the sum of + the corresponding elements of \var{a} and \var{b}. A similar + statement holds for all other binary and unary operations. + + Let's consider a simple example. Suppose, that we wish to solve a + set of \var{n} quadratic equations whose coefficients are given by + the 1-d arrays \var{a}, \var{b}, and \var{c}. In general, the + solution of a quadratic equation will be two complex numbers. For + simplicity, suppose that all we really want is to know what subset of + the coefficients, \var{a}, \var{b}, \var{c}, correspond to + real-valued solutions. In terms of \var{for} loops, we can write: +#v+ + variable i, d, index_array; + index_array = Integer_Type [n]; + for (i = 0; i < n; i++) + { + d = b[i]^2 - 4 * a[i] * c[i]; + index_array [i] = (d >= 0.0); + } +#v- + In this example, the array \var{index_array} will contain a + non-zero value if the corresponding set of coefficients has a + real-valued solution. This code may be written much more compactly + and with more clarity as follows: +#v+ + variable index_array = ((b^2 - 4 * a * c) >= 0.0); +#v- + + \slang has a powerful built-in function called \var{where}. This + function takes an array of integers and returns a 2-d array of + indices that correspond to where the elements of the input array + are non-zero. This simple operation is extremely useful. For + example, suppose \var{a} is a 1-d array of \var{n} doubles, and it + is desired to set to zero all elements of the array whose value is + less than zero. One way is to use a \var{for} loop: +#v+ + for (i = 0; i < n; i++) + if (a[i] < 0.0) a[i] = 0.0; +#v- + If \var{n} is a large number, this statement can take some time to + execute. The optimal way to achieve the same result is to use the + \var{where} function: +#v+ + a[where (a < 0.0)] = 0; +#v- + Here, the expression \exmp{(a < 0.0)} returns an array whose + dimensions are the same size as \var{a} but whose elements are + either \exmp{1} or \exmp{0}, according to whether or not the + corresponding element of \var{a} is less than zero. This array of + zeros and ones is then passed to \var{where} which returns a 2-d + integer array of indices that indicate where the elements of + \var{a} are less than zero. Finally, those elements of \var{a} are + set to zero. + + As a final example, consider once more the example involving the set of + \var{n} quadratic equations presented above. Suppose that we wish + to get rid of the coefficients of the previous example that + generated non-real solutions. Using an explicit \var{for} loop requires + code such as: +#v+ + variable i, j, nn, tmp_a, tmp_b, tmp_c; + + nn = 0; + for (i = 0; i < n; i++) + if (index_array [i]) nn++; + + tmp_a = Double_Type [nn]; + tmp_b = Double_Type [nn]; + tmp_c = Double_Type [nn]; + + j = 0; + for (i = 0; i < n; i++) + { + if (index_array [i]) + { + tmp_a [j] = a[i]; + tmp_b [j] = b[i]; + tmp_c [j] = c[i]; + j++; + } + } + a = tmp_a; + b = tmp_b; + c = tmp_c; +#v- + Not only is this a lot of code, it is also clumsy and error-prone. + Using the \var{where} function, this task is trivial: +#v+ + variable i; + i = where (index_array != 0); + a = a[i]; + b = b[i]; + c = c[i]; +#v- + + All the examples up to now assumed that the dimensions of the array + were known. Although the intrinsic function \var{length} may be + used to get the total number of elements of an array, it cannot be + used to get the individual dimensions of a multi-dimensional array. + However, the function \var{array_info} may be used to + get information about an array, such as its data type and size. + The function returns three values: the data type, the number of + dimensions, and an integer array containing the size + of each dimension. It may be used to determine the number of rows + of an array as follows: +#v+ + define num_rows (a) + { + variable dims, type, num_dims; + + (dims, num_dims, type) = array_info (a); + return dims[0]; + } +#v- + The number of columns may be obtained in a similar manner: +#v+ + define num_cols (a) + { + variable dims, type, num_dims; + + (dims, num_dims, type) = array_info (a); + if (num_dims > 1) return dims[1]; + return 1; + } +#v- + + Another use of \var{array_info} is to create an array that has the + same number of dimensions as another array: +#v+ + define make_int_array (a) + { + variable dims, num_dims, type; + + (dims, num_dims, type) = array_info (a); + return @Array_Type (Integer_Type, dims); + } +#v- + +#%}}} + +#%}}} + +\chapter{Associative Arrays} #%{{{ + + An associative array differs from an ordinary array in the sense + that its size is not fixed and that is indexed by a string, called + the \em{key}. For example, consider: +#v+ + variable A = Assoc_Type [Integer_Type]; + A["alpha"] = 1; + A["beta"] = 2; + A["gamma"] = 3; +#v- + Here, \var{A} represents an associative array of integers + (\var{Integer_Type}) and three keys have been added to the array. + + As the example suggests, an associative array may be created using + one of the following forms: +\begin{tscreen} + Assoc_Type [\em{type}] + Assoc_Type [\em{type}, \em{default-value}] + Assoc_Type [] +\end{tscreen} + The last form returns an associative array of \var{Any_Type} + objects allowing any type of object to may be stored in + the array. + + The form involving a \em{default-value} is useful for associating a + default value for non-existent array members. This feature is + explained in more detail below. + + There are several functions that are specially designed to work + with associative arrays. These include: +\begin{itemize} +\item \var{assoc_get_keys}, which returns an ordinary array of strings + containing the keys in the array. + +\item \var{assoc_get_values}, which returns an ordinary array of the + values of the associative array. + +\item \var{assoc_key_exists}, which can be used to determine whether + or not a key exists in the array. + +\item \var{assoc_delete_key}, which may be used to remove a key (and + its value) from the array. +\end{itemize} + + To illustrate the use of an associative array, consider the problem + of counting the number of repeated occurrences of words in a list. + Let the word list be represented as an array of strings given by + \var{word_list}. The number of occurrences of each word may be + stored in an associative array as follows: +#v+ + variable a, word; + a = Assoc_Type [Integer_Type]; + foreach (word_list) + { + word = (); + if (0 == assoc_key_exists (a, word)) + a[word] = 0; + a[word]++; % same as a[word] = a[word] + 1; + } +#v- + Note that \var{assoc_key_exists} was necessary to determine whether + or not a word was already added to the array in order to properly + initialize it. However, by creating the associative array with a + default value of \exmp{0}, the above code may be simplified to +#v+ + variable a, word; + a = Assoc_Type [Integer_Type, 0]; + foreach (word_list) + { + word = (); + a[word]++; + } +#v- + + +#%}}} + +\chapter{Structures and User-Defined Types} #%{{{ + + A \em{structure} is a heterogeneous container object, i.e., it is + an object with elements whose values do not have to be of the same + data type. The elements or fields of a structure are named, and + one accesses a particular field of the structure via the field + name. This should be contrasted with an array whose values are of + the same type, and whose elements are accessed via array indices. + + A \em{user-defined} data type is a structure with a fixed set of + fields defined by the user. + +\sect{Defining a Structure} + + The \kw{struct} keyword is used to define a structure. The syntax + for this operation is: +\begin{tscreen} + struct {\em{field-name-1}, \em{field-name-2}, ... \em{field-name-N}}; +\end{tscreen} + This creates and returns a structure with \em{N} fields whose names + are specified by \em{field-name-1}, \em{field-name-2}, ..., + \em{field-name-N}. When a structure is created, all its fields are + initialized to \var{NULL}. + + For example, +#v+ + variable t = struct { city_name, population, next }; +#v- + creates a structure with three fields and assigns it to the + variable \var{t}. + + Alternatively, a structure may be created by dereferencing + \var{Struct_Type}. For example, the above structure may also be + created using one of the two forms: +#v+ + t = @Struct_Type ("city_name", "population", "next"); + t = @Struct_Type (["city_name", "population", "next"]); +#v- + These are useful when creating structures dynamically where one does + not know the name of the fields until run-time. + + Like arrays, structures are passed around via a references. Thus, + in the above example, the value of \var{t} is a reference to the + structure. This means that after execution of +#v+ + variable u = t; +#v- + \em{both} \var{t} and \var{u} refer to the \em{same} structure, + since only the reference was used in the assignment. To actually + create a new copy of the structure, use the \em{dereference} + operator, e.g., +#v+ + variable u = @t; +#v- + +\sect{Accessing the Fields of a Structure} + + The dot (\var{.}) operator is used to specify the particular + field of structure. If \var{s} is a structure and \var{field_name} + is a field of the structure, then \exmp{s.field_name} specifies + that field of \var{s}. This specification can be used in + expressions just like ordinary variables. Again, consider +#v+ + variable t = struct { city_name, population, next }; +#v- + described in the last section. Then, +#v+ + t.city_name = "New York"; + t.population = 13000000; + if (t.population > 200) t = t.next; +#v- + are all valid statements involving the fields of \var{t}. + +\sect{Linked Lists} + + One of the most important uses of structures is to create a + \em{dynamic} data structure such as a \em{linked-list}. A + linked-list is simply a chain of structures that are linked together + such that one structure in the chain is the value of a field of the + previous structure in the chain. To be concrete, consider the + structure discussed earlier: +#v+ + variable t = struct { city_name, population, next }; +#v- + and suppose that we desire to create a list of such structures. + The purpose of the \var{next} field is to provide the link to the + next structure in the chain. Suppose that there exists a function, + \var{read_next_city}, that reads city names and populations from a + file. Then we can create the list via: +#v+ + define create_population_list () + { + variable city_name, population, list_root, list_tail; + variable next; + + list_root = NULL; + while (read_next_city (&city_name, &population)) + { + next = struct {city_name, population, next }; + + next.city_name = city_name; + next.population = population; + next.next = NULL; + + if (list_root == NULL) + list_root = next; + else + list_tail.next = next; + + list_tail = next; + } + return list_root; + } +#v- + In this function, the variables \var{list_root} and \var{list_tail} + represent the beginning and end of the list, respectively. As long + as \var{read_next_city} returns a non-zero value, a new structure is + created, initialized, and then appended to the list via the + \var{next} field of the \var{list_tail} structure. On the first + time through the loop, the list is created via the assignment to the + \var{list_root} variable. + + This function may be used as follows: +#v+ + variable Population_List = create_population_list (); + if (Population_List == NULL) error ("List is empty"); +#v- + We can create other functions that manipulate the list. An example is + a function that finds the city with the largest population: +#v+ + define get_largest_city (list) + { + variable largest; + + largest = list; + while (list != NULL) + { + if (list.population > largest.population) + largest = list; + list = list.next; + } + return largest.city_name; + } + + vmessage ("%s is the largest city in the list", + get_largest_city (Population_List))); +#v- + The \var{get_largest_city} is a typical example of how one traverses + a linear linked-list by starting at the head of the list and + successively moves to the next element of the list via the + \var{next} field. + + In the previous example, a \kw{while} loop was used to traverse the + linked list. It is faster to use a \kw{foreach} loop for this: +#v+ + define get_largest_city (list) + { + variable largest, elem; + + largest = list; + foreach (list) + { + elem = (); + if (item.population > largest.population) + largest = item; + } + return largest.city_name; + } +#v- + Here a \kw{foreach} loop has been used to walk the list via its + \exmp{next} field. If the field name was not \exmp{next}, then it + would have been necessary to use the \kw{using} form of the + \kw{foreach} statement. For example, if the field name implementing the + linked list was \exmp{next_item}, then +#v+ + foreach (list) using ("next_item") + { + elem = (); + . + . + } +#v- + would have been used. In other words, unless otherwise indicated + via the \kw{using} clause, \kw{foreach} walks the list using a field + named \exmp{next}. + + Now consider a function that sorts the list according to population. + To illustrate the technique, a \em{bubble-sort} will be used, not + because it is efficient, it is not, but because it is simple and + intuitive. +#v+ + define sort_population_list (list) + { + variable changed; + variable node, next_node, last_node; + do + { + changed = 0; + node = list; + next_node = node.next; + last_node = NULL; + while (next_node != NULL) + { + if (node.population < next_node.population) + { + % swap node and next_node + node.next = next_node.next; + next_node.next = node; + if (last_node != NULL) + last_node.next = next_node; + + if (list == node) list = next_node; + node = next_node; + next_node = node.next; + changed++; + } + last_node = node; + node = next_node; + next_node = next_node.next; + } + } + while (changed); + + return list; + } +#v- + Note the test for equality between \var{list} and \var{node}, i.e., +#v+ + if (list == node) list = next_node; +#v- + It is important to appreciate the fact that the values of these + variables are references to structures, and that the + comparison only compares the references and \em{not} the actual + structures they reference. If it were not for this, the algorithm + would fail. + +\sect{Defining New Types} + + A user-defined data type may be defined using the \kw{typedef} + keyword. In the current implementation, a user-defined data type + is essentially a structure with a user-defined set of fields. For + example, in the previous section a structure was used to represent + a city/population pair. We can define a data type called + \var{Population_Type} to represent the same information: +#v+ + typedef struct + { + city_name, + population + } Population_Type; +#v- + This data type can be used like all other data types. For example, + an array of Population_Type types can be created, +#v+ + variable a = Population_Type[10]; +#v- + and `populated' via expressions such as +#v+ + a[0].city_name = "Boston"; + a[0].population = 2500000; +#v- + The new type \var{Population_Type} may also be used with the + \var{typeof} function: +#v+ + if (Population_Type = typeof (a)) city = a.city_name; +#v- + The dereference \var{@} may be used to create an instance of the + new type: +#v+ + a = @Population_Type; + a.city_name = "Calcutta"; + a.population = 13000000; +#v- + + +#%}}} + +\chapter{Error Handling} #%{{{ + + Many intrinsic functions signal errors in the event of failure. + User defined functions may also generate an error condition via the + \var{error} function. Depending upon the severity of the error, it + can be caught and cleared using a construct called an + \em{error-block}. + +\sect{Error-Blocks} + + When the interpreter encounters a recoverable run-time error, it + will return to top-level by \em{unwinding} its function call + stack. Any error-blocks that it encounters as part of this + unwinding process will get executed. Errors such as syntax errors + and memory allocation errors are not recoverable, and error-blocks + will not get executed when such errors are encountered. + + An error-block is defined using the syntax +#v+ + ERROR_BLOCK { statement-list } +#v- + where \em{statement-list} represents a list of statements that + comprise the error-block. A simple example of an error-block is +#v+ + define simple (a) + { + ERROR_BLOCK { message ("error-block executed"); } + if (a) error ("Triggering Error"); + message ("hello"); + } +#v- + Executing this function via \exmp{simple(0)} will result in the + message \exmp{"hello"}. However, calling it using \exmp{simple(1)} + will generate an error that will be caught, but not cleared, by + the error-block and the \exmp{"error-block executed"} message will + result. + + Error-blocks are never executed unless triggered by an error. The + only exception to this is when the user explicitly indicates that + the error-block in scope should execute. This is indicated by the + special keyword \var{EXECUTE_ERROR_BLOCK}. For example, + \var{simple} could be recoded as +#v+ + define simple (a) + { + variable err_string = "error-block executed"; + ERROR_BLOCK { message (err_string); } + if (a) error ("Triggering Error"); + err_string = "hello"; + EXECUTE_ERROR_BLOCK; + } +#v- + Please note that \var{EXECUTE_ERROR_BLOCK} does not initiate an + error condition; it simply causes the error-block to be executed + and control will pass onto the next statement following the + \var{EXECUTE_ERROR_BLOCK} statement. + +\sect{Clearing Errors} + + Once an error has been caught by an error-block, the error can be cleared + by the \var{_clear_error} function. After the error has been cleared, + execution will resume at the next statement at the level of the error block + following the statement that generated the error. For example, consider: +#v+ + define make_error () + { + error ("Error condition created."); + message ("This statement is not executed."); + } + + define test () + { + ERROR_BLOCK + { + _clear_error (); + } + make_error (); + message ("error cleared."); + } +#v- + Calling \var{test} will trigger an error in the \var{make_error} + function, but will get cleared in the \var{test} function. The + call-stack will unwind from \var{make_error} back into \var{test} + where the error-block will get executed. As a result, execution + resumes after the statement that makes the call to \var{make_error} + since this statement is at the same level as the error-block that + cleared the error. + + Here is another example that illustrates how multiple error-blocks + work: +#v+ + define example () + { + variable n = 0, s = ""; + variable str; + + ERROR_BLOCK { + str = sprintf ("s=%s,n=%d", s, n); + _clear_error (); + } + + forever + { + ERROR_BLOCK { + s += "0"; + _clear_error (); + } + + if (n == 0) error (""); + + ERROR_BLOCK { + s += "1"; + } + + if (n == 1) error (""); + n++; + } + return str; + } +#v- + Here, three error-blocks have been declared. One has been declared + outside the \var{forever} loop and the other two have been declared + inside the \var{forever} loop. Each time through the loop, the variable + \var{n} is incremented and a different error-block is triggered. The + error-block that gets triggered is the last one encountered, since + that will be the one in scope. On the first time through the loop, + \var{n} will be zero and the first error-block in the loop will get + executed. This error block clears the error and execution resumes + following the \var{if} statement that triggered the error. The + variable \var{n} will get incremented to \exmp{1} and, on the + second cycle through the loop the second \var{if} statement + will trigger an error causing the second error-block to execute. + This time, the error is not cleared and the call-stack unwinds out + of the \var{forever} loop, at which point the error-block outside + the loop is in scope, causing it to execute. This error-block + prints out the values of the variables \var{s} and \var{n}. It + will clear the error and execution resumes on the statement + \em{following} the \var{forever} loop. The result of this + complicated series of events is that the function will return the + string \exmp{"s=01,n=1"}. + +#%}}} + +\chapter{Loading Files: evalfile and autoload} + +\chapter{File Input/Output} #%{{{ + + \slang provides built-in supports for two different I/O facilities. + The simplest interface is modeled upon the C language \var{stdio} + streams interface and consists of functions such as \var{fopen}, + \var{fgets}, etc. The other interface is modeled on a lower level + POSIX interface consisting of functions such as \var{open}, + \var{read}, etc. In addition to permitting more control, the lower + level interface permits one to access network objects as well as disk + files. + +\sect{Input/Output via stdio} +\sect1{Stdio Overview} + The \var{stdio} interface consists of the following functions: +\begin{itemize} +\item \var{fopen}, which opens a file for read or writing. + +\item \var{fclose}, which closes a file opened by \var{fopen}. + +\item \var{fgets}, used to read a line from the file. + +\item \var{fputs}, which writes text to the file. + +\item \var{fprintf}, used to write formatted text to the file. + +\item \var{fwrite}, which may be used to write objects to the + file. + +\item \var{fread}, which reads a specified number of objects from + the file. + +\item \var{feof}, which is used to test whether the file pointer is at the + end of the file. + +\item \var{ferror}, which is used to see whether or not the stream + associated with the file has an error. + +\item \var{clearerr}, which clears the end-of-file and error + indicators for the stream. + +\item \var{fflush}, used to force all buffered data associated with + the stream to be written out. + +\item \var{ftell}, which is used to query the file position indicator + of the stream. + +\item \var{fseek}, which is used to set the position of the file + position indicator of the stream. + +\item \var{fgetslines}, which reads all the lines in a text file and + returns them as an array of strings. + +\end{itemize} + + In addition, the interface supports the \var{popen} and \var{pclose} + functions on systems where the corresponding C functions are available. + + Before reading or writing to a file, it must first be opened using + the \var{fopen} function. The only exceptions to this rule involves + use of the pre-opened streams: \var{stdin}, \var{stdout}, and + \var{stderr}. \var{fopen} accepts two arguments: a file name and a + string argument that indicates how the file is to be opened, e.g., + for reading, writing, update, etc. It returns a \var{File_Type} + stream object that is used as an argument to all other functions of + the \var{stdio} interface. Upon failure, it returns \NULL. See the + reference manual for more information about \var{fopen}. + +\sect1{Stdio Examples} + + In this section, some simple examples of the use of the \var{stdio} + interface is presented. It is important to realize that all the + functions of the interface return something, and that return value + must be dealt with. + + The first example involves writing a function to count the number of + lines in a text file. To do this, we shall read in the lines, one by + one, and count them: +#v+ + define count_lines_in_file (file) + { + variable fp, line, count; + + fp = fopen (file, "r"); % Open the file for reading + if (fp == NULL) + verror ("%s failed to open", file); + + count = 0; + while (-1 != fgets (&line, fp)) + count++; + + () = fclose (fp); + return count; + } +#v- + Note that \exmp{&line} was passed to the \var{fgets} function. When + \var{fgets} returns, \var{line} will contain the line of text read in + from the file. Also note how the return value from \var{fclose} was + handled. + + Although the preceding example closed the file via \var{fclose}, + there is no need to explicitly close a file because \slang will + automatically close the file when it is no longer referenced. Since + the only variable to reference the file is \var{fp}, it would have + automatically been closed when the function returned. + + Suppose that it is desired to count the number of characters in the + file instead of the number of lines. To do this, the \var{while} + loop could be modified to count the characters as follows: +#v+ + while (-1 != fgets (&line, fp)) + count += strlen (line); +#v- + The main difficulty with this approach is that it will not work for + binary files, i.e., files that contain null characters. For such + files, the file should be opened in \em{binary} mode via +#v+ + fp = fopen (file, "rb"); +#v- + and then the data read in using the \var{fread} function: +#v+ + while (-1 != fread (&line, Char_Type, 1024, fp)) + count += bstrlen (line); +#v- + The \var{fread} function requires two additional arguments: the type + of object to read (\var{Char_Type} in the case), and the number of + such objects to read. The function returns the number of objects + actually read, or -1 upon failure. The \var{bstrlen} function was + used to compute the length of \var{line} because for \var{Char_Type} + or \var{UChar_Type} objects, the \var{fread} function assigns a + \em{binary} string (\var{BString_Type}) to \var{line}. + + The \kw{foreach} construct also works with \var{File_Type} objects. + For example, the number of characters in a file may be counted via +#v+ + foreach (fp) using ("char") + { + ch = (); + count++; + } +#v- + To count the number of lines, one can use: +#v+ + foreach (fp) using ("line") + { + line = (); + num_lines++; + count += strlen (line); + } +#v- + Often one is not interested in trailing whitespace in the lines of a + file. To have trailing whitespace automatically stripped from the + lines as they are read in, use the \exmp{"wsline"} form, e.g., +#v+ + foreach (fp) using ("wsline") + { + line = (); + . + . + } +#v- + + Finally, it should be mentioned that none of these examples should + be used to count the number of bytes in a file when that + information is more readily accessible by another means. For + example, it is preferable to get this information via the + \var{stat_file} function: +#v+ + define count_chars_in_file (file) + { + variable st; + + st = stat_file (file); + if (st == NULL) + error ("stat_file failed."); + return st.st_size; + } +#v- + +\sect{POSIX I/O} + +\sect{Advanced I/O techniques} + + The previous examples illustrate how to read and write objects of a + single data-type from a file, e.g., +#v+ + num = fread (&a, Double_Type, 20, fp); +#v- + would result in a \exmp{Double_Type[num]} array being assigned to + \var{a} if successful. However, suppose that the binary data file + consists of numbers in a specified byte-order. How can one read + such objects with the proper byte swapping? The answer is to use + the \var{fread} function to read the objects as \var{Char_Type} and + then \em{unpack} the resulting string into the specified data type, + or types. This process is facilitated using the \var{pack} and + \var{unpack} functions. + + The \var{pack} function follows the syntax +\begin{tscreen} + BString_Type pack (\em{format-string}, \em{item-list}); +\end{tscreen} + and combines the objects in the \em{item-list} according to + \em{format-string} into a binary string and returns the result. + Likewise, the \var{unpack} function may be used to convert a binary + string into separate data objects: +\begin{tscreen} + (\em{variable-list}) = unpack (\em{format-string}, \em{binary-string}); +\end{tscreen} + + The format string consists of one or more data-type specification + characters, and each may be followed by an optional decimal length + specifier. Specifically, the data-types are specified according to + the following table: +#v+ + c char + C unsigned char + h short + H unsigned short + i int + I unsigned int + l long + L unsigned long + j 16 bit int + J 16 unsigned int + k 32 bit int + K 32 bit unsigned int + f float + d double + F 32 bit float + D 64 bit float + s character string, null padded + S character string, space padded + x a null pad character +#v- + A decimal length specifier may follow the data-type specifier. With + the exception of the \var{s} and \var{S} specifiers, the length + specifier indicates how many objects of that data type are to be + packed or unpacked from the string. When used with the \var{s} or + \var{S} specifiers, it indicates the field width to be used. If the + length specifier is not present, the length defaults to one. + + With the exception of \var{c}, \var{C}, \var{s}, \var{S}, and + \var{x}, each of these may be prefixed by a character that indicates + the byte-order of the object: +#v+ + > big-endian order (network order) + < little-endian order + = native byte-order +#v- + The default is native byte order. + + Here are a few examples that should make this more clear: +#v+ + a = pack ("cc", 'A', 'B'); % ==> a = "AB"; + a = pack ("c2", 'A', 'B'); % ==> a = "AB"; + a = pack ("xxcxxc", 'A', 'B'); % ==> a = "\0\0A\0\0B"; + a = pack ("h2", 'A', 'B'); % ==> a = "\0A\0B" or "\0B\0A" + a = pack (">h2", 'A', 'B'); % ==> a = "\0\xA\0\xB" + a = pack (" a = "\0B\0A" + a = pack ("s4", "AB", "CD"); % ==> a = "AB\0\0" + a = pack ("s4s2", "AB", "CD"); % ==> a = "AB\0\0CD" + a = pack ("S4", "AB", "CD"); % ==> a = "AB " + a = pack ("S4S2", "AB", "CD"); % ==> a = "AB CD" +#v- + + When unpacking, if the length specifier is greater than one, then an + array of that length will be returned. In addition, trailing + whitespace and null character are stripped when unpacking an object + given by the \var{S} specifier. Here are a few examples: +#v+ + (x,y) = unpack ("cc", "AB"); % ==> x = 'A', y = 'B' + x = unpack ("c2", "AB"); % ==> x = ['A', 'B'] + x = unpack ("x x = 0xCDABuh + x = unpack ("xxs4", "a b c\0d e f"); % ==> x = "b c\0" + x = unpack ("xxS4", "a b c\0d e f"); % ==> x = "b c" +#v- + +\sect1{Example: Reading /var/log/wtmp} + + Consider the task of reading the Unix system file + \var{/var/log/utmp}, which contains login records about who logged + onto the system. This file format is documented in section 5 of the + online Unix man pages, and consists of a sequence of entries + formatted according to the C structure \var{utmp} defined in the + \var{utmp.h} C header file. The actual details of the structure + may vary from one version of Unix to the other. For the purposes of + this example, consider its definition under the Linux operating + system running on an Intel processor: +#v+ + struct utmp { + short ut_type; /* type of login */ + pid_t ut_pid; /* pid of process */ + char ut_line[12]; /* device name of tty - "/dev/" */ + char ut_id[2]; /* init id or abbrev. ttyname */ + time_t ut_time; /* login time */ + char ut_user[8]; /* user name */ + char ut_host[16]; /* host name for remote login */ + long ut_addr; /* IP addr of remote host */ + }; +#v- + On this system, \var{pid_t} is defined to be an \var{int} and + \var{time_t} is a \var{long}. Hence, a format specifier for the + \var{pack} and \var{unpack} functions is easily constructed to be: +#v+ + "h i S12 S2 l S8 S16 l" +#v- + However, this particular definition is naive because it does not + allow for structure padding performed by the C compiler in order to + align the data types on suitable word boundaries. Fortunately, the + intrinsic function \var{pad_pack_format} may be used to modify a + format by adding the correct amount of padding in the right places. + In fact, \var{pad_pack_format} applied to the above format on an + Intel-based Linux system produces the result: +#v+ + "h x2 i S12 S2 x2 l S8 S16 l" +#v- + Here we see that 4 bytes of padding were added. + + The other missing piece of information is the size of the structure. + This is useful because we would like to read in one structure at a + time using the \var{fread} function. Knowing the size of the + various data types makes this easy; however it is even easier to use + the \var{sizeof_pack} intrinsic function, which returns the size (in + bytes) of the structure described by the pack format. + + So, with all the pieces in place, it is rather straightforward to + write the code: +#v+ + variable format, size, fp, buf; + + typedef struct + { + ut_type, ut_pid, ut_line, ut_id, + ut_time, ut_user, ut_host, ut_addr + } UTMP_Type; + + format = pad_pack_format ("h i S12 S2 l S8 S16 l"); + size = sizeof_pack (format); + + define print_utmp (u) + { + + () = fprintf (stdout, "%-16s %-12s %-16s %s\n", + u.ut_user, u.ut_line, u.ut_host, ctime (u.ut_time)); + } + + + fp = fopen ("/var/log/utmp", "rb"); + if (fp == NULL) + error ("Unable to open utmp file"); + + () = fprintf (stdout, "%-16s %-12s %-16s %s\n", + "USER", "TTY", "FROM", "LOGIN@"); + + variable U = @UTMP_Type; + + while (-1 != fread (&buf, Char_Type, size, fp)) + { + set_struct_fields (U, unpack (format, buf)); + print_utmp (U); + } + + () = fclose (fp); +#v- + A few comments about this example are in order. First of all, note + that a new data type called \var{UTMP_Type} was created, although + this was not really necessary. We also opened the file in binary + mode, but this too is optional under a Unix system where there is no + distinction between binary and text modes. The \var{print_utmp} + function does not print all of the structure fields. Finally, last + but not least, the return values from \var{fprintf} and \var{fclose} + were dealt with. + +#%}}} + +\chapter{Debugging} #%{{{ + + The current implementation provides no support for an interactive + debugger, although a future version will. Nevertheless, \slang has + several features that aid the programmer in tracking down problems, + including function call tracebacks and the tracing of function calls. + However, the biggest debugging aid stems from the fact that the + language is interpreted permitting one to easily add debugging + statements to the code. + + To enable debugging information, add the lines +#v+ + _debug_info = 1; + _traceback = 1; +#v- + to the top of the source file of the code containing the bug and the + reload the file. Setting the \var{_debug_info} variable to + \exmp{1} causes line number information to be compiled into the + functions when the file is loaded. The \var{_traceback} variable + controls whether or not traceback information should be generated. + If it is set to \exmp{1}, the values of local variables will be + dumped when the traceback is generated. Setting this variable + to \exmp{-1} will cause only function names to be reported in the + traceback. + + Here is an example of a traceback report: +#v+ + S-Lang Traceback: error + S-Lang Traceback: verror + S-Lang Traceback: (Error occurred on line 65) + S-Lang Traceback: search_generic_search + Local Variables: + $0: Type: String_Type, Value: "Search forward:" + $1: Type: Integer_Type, Value: 1 + $2: Type: Ref_Type, Value: _function_return_1 + $3: Type: String_Type, Value: "abcdefg" + $4: Type: Integer_Type, Value: 1 + S-Lang Traceback: (Error occurred on line 72) + S-Lang Traceback: search_forward +#v- + There are several ways to read this report; perhaps the simplest is + to read it from the bottom. This report says that on line \exmp{72}, + the \var{search_forward} function called the + \var{search_generic_search} function. On line \var{65} it called the + \verb{verror} function, which called \var{error}. The + \var{search_generic_search} function contains \var{5} local variables + and are represented symbolically as \exmp{$0} through \exmp{$4}. + + +#%}}} + +#i regexp.tm + +\chapter{Future Directions} #%{{{ + + Several new features or enhancements to the \slang language are + planned for the next major release. In no particular order, these + include: +\begin{itemize} + \item An interactive debugging facility. + \item Function qualifiers. These entities should already be + familiar to VMS users or to those who are familiar with the IDL + language. Basically, a qualifier is an optional argument that is + passed to a function, e.g., \exmp{plot(X,Y,/logx)}. Here + \exmp{/logx} is a qualifier that specifies that the plot function + should use a log scale for \exmp{x}. + \item File local variables and functions. A file local variable or + function is an object that is global to the file that defines it. + \item Multi-threading. Currently the language does not support + multiple threads. +\end{itemize} + + +#%}}} + +\appendix + +#i copyright.tm + +\end{\documentstyle} diff --git a/libslang/doc/tm/slangfun.tm b/libslang/doc/tm/slangfun.tm new file mode 100644 index 0000000..44ee6d9 --- /dev/null +++ b/libslang/doc/tm/slangfun.tm @@ -0,0 +1,121 @@ +#% -*- mode: tm; mode: fold; eval: .0 =TAB -*- +#%{{{Macros + +#i linuxdoc.tm + +#d slang \bf{S-lang} +#d kw#1 \tt{$1} +#d exmp#1 \tt{$1} +#d var#1 \tt{$1} + +#d ivar#1 \tt{$1} +#d ifun#1 \tt{$1} +#d cvar#1 \tt{$1} +#d cfun#1 \tt{$1} +#d svar#1 \tt{$1} +#d sfun#1 \tt{$1} + +#d ldots ... +#d chapter#1 $1

+#d preface +#d tag#1 $1 + +#d function#1 \sect{$1\label{$1}} +#d variable#1 \sect{$1\label{$1}} +#cd function#1

$1\label{$1}

+#d synopsis#1 Synopsis $1 +#d keywords#1 Keywords $1 +#d usage#1 Usage $1 +#d description Description +#d example Example +#d notes Notes +#d seealso#1 See Also $1 +#d r#1 \ref{$1}{$1} +#d done

+#d -1 -1 +#d 0 0 +#d 1 1 +#d 2 2 +#d 3 3 +#d 4 4 +#d 5 5 +#d 6 6 +#d 7 7 +#d 8 8 +#d 9 9 +#d NULL NULL +#d documentstyle book + + +#d user-manual \bf{A Guide to the S-Lang Language} + + +#%}}} + +\linuxdoc +\begin{\documentstyle} + +\title S-Lang Run-Time Library Reference: Version 1.4.0 +\author John E. Davis, \tt{davis@space.mit.edu} +\date \__today__ + +\toc + +\chapter{Array Functions} +#i rtl/array.tm + +\chapter{Associative Array Functions} +#i rtl/assoc.tm + +\chapter{Functions that Operate on Strings} +#i rtl/strops.tm + +\chapter{Functions that Manipulate Structures} +#i rtl/struct.tm + +\chapter{Informational Functions} +#i rtl/info.tm + +\chapter{Mathematical Functions} +#i rtl/math.tm + +\chapter{Message and Error Functions} +#i rtl/message.tm + +\chapter{Time and Date Functions} +#i rtl/time.tm + +\chapter{Data-Type Conversion Functions} +#i rtl/type.tm + +\chapter{Stdio File I/O Functions} +#i rtl/stdio.tm + +\chapter{Low-level POSIX I/O functions} +#i rtl/posio.tm + +\chapter{Directory Functions} +#i rtl/dir.tm + +\chapter{Functions that parse pathnames} +#i rtl/ospath.tm + +\chapter{System Call Functions} +#i rtl/posix.tm + +\chapter{Eval Functions} +#i rtl/eval.tm + +\chapter{Module Functions} +#i rtl/import.tm + +\chapter{Debugging Functions} +#i rtl/debug.tm + +\chapter{Stack Functions} +#i rtl/stack.tm + +\chapter{Miscellaneous Functions} +#i rtl/misc.tm + +\end{\documentstyle} diff --git a/libslang/doc/tm/tools/Makefile b/libslang/doc/tm/tools/Makefile new file mode 100644 index 0000000..94ec197 --- /dev/null +++ b/libslang/doc/tm/tools/Makefile @@ -0,0 +1,46 @@ +# -*- sh -*- +ELF= +EXECS_TO_BUILD = tm2txt sl2tm +EXECS_TO_INSTALL = tm2txt sl2tm +SYMLINK_DIR=$(HOME)/sys/$(ARCH)/objs/slang/doc/tm/tools +SRCDIR=$(HOME)/src/slang/doc/tm/tools +OBJDIR=$(SRCDIR)/$(ARCH)objs# + +SLANGDIR=$(SRCDIR)/../../src +EXECLIBS = -L$(SLANGDIR)/$(ARCH)$(ELF)objs -lslang -lm +EXECINC = -I$(SLANGDIR) + +COMPILE_CMD=$(CC) -c $(CFLAGS) $(EXECINC) +LINK_CMD=$(CC) $(LDFLAGS) + +all: $(OBJDIR) $(EXECS_TO_BUILD) +clean: + $(RM) $(OBJDIR)/* *~ #* + +tm2txt: $(OBJDIR)/tm2txt + @echo tm2txt created in $(OBJDIR) +$(OBJDIR)/tm2txt: $(OBJDIR)/tm2txt.o $(EXEC_EXTRA_OBJS) + cd $(OBJDIR); $(LINK_CMD) tm2txt.o -o tm2txt $(EXECLIBS) +$(OBJDIR)/tm2txt.o: tm2txt.c $(tm2txt_O_DEP) + cd $(OBJDIR); $(COMPILE_CMD) $(SRCDIR)/tm2txt.c -o tm2txt.o +sl2tm: $(OBJDIR)/sl2tm + @echo sl2tm created in $(OBJDIR) +$(OBJDIR)/sl2tm: $(OBJDIR)/sl2tm.o $(EXEC_EXTRA_OBJS) + cd $(OBJDIR); $(LINK_CMD) sl2tm.o -o sl2tm $(EXECLIBS) +$(OBJDIR)/sl2tm.o: sl2tm.c $(sl2tm_O_DEP) + cd $(OBJDIR); $(COMPILE_CMD) $(SRCDIR)/sl2tm.c -o sl2tm.o + +$(OBJDIR): + -mkdir $(OBJDIR) + +install: $(EXECS_TO_INSTALL) + @for x in $(EXECS_TO_INSTALL); do \ + echo Installing $$x in $(BINDIR); \ + $(INSTALL_CMD) $(OBJDIR)/$$x $(BINDIR); \ + done + +symlinks: + -/bin/rm -f $(ARCH)objs + -mkdir -p $(SYMLINK_DIR) + ln -s $(SYMLINK_DIR) $(ARCH)objs + diff --git a/libslang/doc/tm/tools/README b/libslang/doc/tm/tools/README new file mode 100644 index 0000000..627c3a2 --- /dev/null +++ b/libslang/doc/tm/tools/README @@ -0,0 +1,67 @@ +This directory includes two programs: + +tm2txt: + This program processes one or more specially formatted .tm + source files and writes the result on stdout. By specially + formatted, it is meant that the .tm files are formatted + into sections such as: + +\function{my_function} +\synopsis{Short Description} +\usage{int my_function (void);} +\description + \var{my_function} does something special and returns an integer. +\example + Here is an example of its use: +#v+ + if (-1 == my_function ()) + exit (1); +#v- +\seealso{my_other_function, your_function} +\done + + Run this README file through tm2txt and see the result. + + +sl2tm: + This program strips the specially formatted documentation described + above from C files and S-Lang files. Here is an example of how the + documentation would appear in the C source: + +/*%+ + *\function{my_other_function} + *\synopsis{Just another function} + *\usage{int my_other_function(void)} + *\description + * \var{my_other_function} is similar to \var{my_function} except that + * it returns a \em{random} integer. + *\example + * Here is an example: + *#v+ + * (void) my_other_function (); + *#v- + *\notes + * This function is obsolete. Use \var{my_new_function} instead. + *\seealso{my_function, my_new_function} + *%- Note that \done should not be used. `*%-' implies \done + */ + +In S-Lang files, the format is similar: + +%!%+ Lines that start with this denotes the start of documentation +%\function{my_other_function} +%\synopsis{Just another function} +%\usage{int my_other_function(void)} +%\description +% \var{my_other_function} is similar to \var{my_function} except that +% it returns a \em{random} integer. +%\example +% Here is an example: +%#v+ +% (void) my_other_function (); +%#v- +%\notes +% This function is obsolete. Use \var{my_new_function} instead. +%\seealso{my_function, my_new_function} +%!%- Note that \done should not be used. `%!%-' implies \done + diff --git a/libslang/doc/tm/tools/sl2tm.c b/libslang/doc/tm/tools/sl2tm.c new file mode 100644 index 0000000..9d8c3ab --- /dev/null +++ b/libslang/doc/tm/tools/sl2tm.c @@ -0,0 +1,216 @@ +/* This program has a simple purpose: strip the documentation from + * one or more slang .sl files or .c files. + */ + +#include +#include +#include +#include + +typedef struct +{ + char *lang; + char *doc_start_string; + char *doc_end_string; + char *doc_prefix_string; +} +Doc_File_Type; + +Doc_File_Type Doc_Files [] = +{ + { "sl", + "%!%+", + "%!%-", + "%" + }, + { + "c", + "/*%+", + " *%-", + " *" + }, + { + NULL, NULL, NULL, NULL + } +}; + + +static Doc_File_Type *get_doc_type (char *lang) +{ + Doc_File_Type *dt; + + dt = Doc_Files; + + while (dt->lang != NULL) + { + if (0 == strcmp (dt->lang, lang)) + return dt; + + dt++; + } + return NULL; +} + + +static char *Tm_Comment_String = "#c"; + +static int doc_strip (char *file, FILE *in, FILE *out, Doc_File_Type *df) +{ + char line[1024]; + char ch_start, ch_end, ch_prefix; + unsigned int start_len, end_len, prefix_len; + int level; + char *start, *end, *prefix; + unsigned int linenum; + + if (df == NULL) + return -1; + + start = df->doc_start_string; + end = df->doc_end_string; + prefix = df->doc_prefix_string; + + ch_start = *start; + start_len = strlen (start); + ch_end = *end; + end_len = strlen (end); + ch_prefix = *prefix; + prefix_len = strlen (prefix); + + linenum = 0; + level = 0; + while (NULL != fgets (line, sizeof (line), in)) + { + linenum++; + if (level == 0) + { + if ((*line == ch_start) + && (0 == strncmp (line, start, start_len))) + { + level = 1; + fprintf (out, "%s __LINE__: %u\n", Tm_Comment_String, linenum); + } + continue; + } + + if ((*line == ch_end) + && (0 == strncmp (line, end, end_len))) + { + fputs ("\\done\n", out); + level = 0; + continue; + } + + if ((*line == ch_prefix) + && (0 == strncmp (line, prefix, prefix_len))) + fputs (line + prefix_len, out); + else + { + fprintf (stderr, "%s:%u: expecting %s\n", file, linenum, prefix); + fputs ("\\done\n", out); + return -1; + /* fputs (line, out); */ + } + } + return 0; +} + +static char *guess_language (char *file) +{ + unsigned int len; + char *f; + + len = strlen (file); + f = file + len; + + while ((f > file) && (*f != '.')) + f--; + + if (*f == '.') f++; + if (0 == strcmp (f, "c")) return "c"; + if (0 == strcmp (f, "sl")) return "sl"; + + return "sl"; /* default */ +} + +static void usage (char *pgm) +{ + fprintf (stderr, "Usage: %s [-c] [-sl] file.... > docfile\n", pgm); +} + +int main (int argc, char **argv) +{ + FILE *fpin; + FILE *fpout; + char *pgm; + int i; + char *language; + + pgm = "sl2tm"; + + fpout = stdout; + + + language = NULL; + + for (i = 1; i < argc; i++) + { + if (*argv[i] != '-') + break; + + if (0 == strcmp (argv[i], "-c")) + language = "c"; + else if (0 == strcmp (argv[i], "-sl")) + language = "sl"; + else + { + usage (pgm); + return 1; + } + } + + if (i >= argc) + { + if (isatty (0)) + { + usage (pgm); + return 1; + } + + if (language == NULL) language = "sl"; + (void) doc_strip ("", stdin, fpout, get_doc_type (language)); + return 0; + } + + while (i < argc) + { + char *file; + char *lang; + Doc_File_Type *dt; + + file = argv[i]; + i++; + + lang = language; + + if ((lang == NULL) + && (NULL == (lang = guess_language (file)))) + lang = "sl"; + + if (NULL == (dt = get_doc_type (lang))) + continue; + + if (NULL == (fpin = fopen (file, "r"))) + { + fprintf (stderr, "Unable to open %s -- skipping it.\n", file); + continue; + } + + fprintf (stdout, "%s __FILE__: %s\n", Tm_Comment_String, file); + (void) doc_strip (file, fpin, fpout, dt); + fclose (fpin); + } + + if (fpout != stdout) fclose (fpout); + return 0; +} diff --git a/libslang/doc/tm/tools/tm2txt.c b/libslang/doc/tm/tools/tm2txt.c new file mode 100644 index 0000000..b1c4858 --- /dev/null +++ b/libslang/doc/tm/tools/tm2txt.c @@ -0,0 +1,726 @@ +#include +#include +#include +#include +#include + +/* This program is a quick hack to turn the run-time library .tm files into + * a decent looking ascii text file. The currently available SGML-tools are + * not up to my standards for doing that. + */ + +static int Run_Silent; +static int Top_Level; + +typedef struct +{ + char *name; + char *value; +} +Macro_String_Type; + +static Macro_String_Type Macro_Strings [] = +{ + {"slang", "S-Lang"}, + {"jed", "jed"}, + {"NULL", "NULL"}, + {"-1", "-1"}, + {"0", "0"}, + {"1", "1"}, + {"2", "2"}, + {"3", "3"}, + {"4", "4"}, + {"5", "5"}, + {"6", "6"}, + {"7", "7"}, + {"8", "8"}, + {"9", "9"}, + {NULL, NULL} +}; + +typedef struct Section_Type +{ + char *section_name; + int (*format_fun) (struct Section_Type *); + unsigned int flags; +} +Section_Type; + +static int format_function (Section_Type *); +static int format_synopsis (Section_Type *); +static int format_usage (Section_Type *); +static int format_description (Section_Type *); +static int format_example (Section_Type *); +static int format_notes (Section_Type *); +static int format_see_also (Section_Type *); +static int format_done (Section_Type *); + +static Section_Type Sections [] = +{ + { + "function", + format_function, + 0 + }, + { + "synopsis", + format_synopsis, + 0 + }, + { + "usage", + format_usage, + 0 + }, + { + "description", + format_description, + 0 + }, + { + "example", + format_example, + 0 + }, + { + "notes", + format_notes, + 0 + }, + { + "seealso", + format_see_also, + 0 + }, + { + "done", + format_done, + 0 + }, + { + "variable", + format_function, + 0 + }, + { + NULL, NULL, 0 + } +}; + +static FILE *Input_File_Ptr; +static FILE *Output_File_Ptr; + +#define MAX_BUF_LEN 1024 +static char Input_Buffer [MAX_BUF_LEN]; +static unsigned int Line_Number; +static int Input_Buffer_Pushed; +static int Line_Type; +static char *This_Filename; + + +#define END_OF_FILE 1 +#define SECTION_LINE 2 +#define VERBATUM_LINE 3 + +static char Source_File[MAX_BUF_LEN]; + +static int set_source_file (char *s) +{ + strncpy (Source_File, s, MAX_BUF_LEN); + Source_File[MAX_BUF_LEN-1] = 0; + This_Filename = Source_File; + return 0; +} + +static int set_source_linenum (char *s) +{ + unsigned int n; + + if (1 == sscanf (s, "%u", &n)) + Line_Number = n; + + return 0; +} + +static int unget_input (char *buf) +{ + if (buf != NULL) + { + char *inp = Input_Buffer; + while (*buf != 0) + { + *inp++ = *buf++; + } + *inp = 0; + } + Input_Buffer_Pushed++; + return 0; +} + + +static int begin_verbatum (void); +static int end_verbatum (void); +static int indent (unsigned int); + +static int verbatum_mode (void) +{ + begin_verbatum (); + while (NULL != fgets (Input_Buffer, MAX_BUF_LEN, Input_File_Ptr)) + { + Line_Number++; + + if (Input_Buffer[0] == '#') + { + if ((Input_Buffer[1] != 'v') + || (Input_Buffer[2] != '-')) + { + fprintf (stderr, "%s:%u:Expecting verbatum end\n", This_Filename, Line_Number); + return -1; + } + break; + } + + indent (3); + fputs (Input_Buffer, stdout); + } + end_verbatum (); + return 0; +} + + + +static int get_next_line (void) +{ + unsigned int len; + + while (1) + { + if (Input_Buffer_Pushed == 0) + { + if (NULL == fgets (Input_Buffer, MAX_BUF_LEN, Input_File_Ptr)) + { + Line_Type = END_OF_FILE; + return -1; + } + Line_Number++; + } + + Input_Buffer_Pushed = 0; + len = strlen (Input_Buffer); + if (len && (Input_Buffer[len - 1] == '\n')) + Input_Buffer [len - 1] = 0; + + switch (*Input_Buffer) + { + case ';': + case '%': + break; + + case '#': + if (Input_Buffer[1] == 'v') + { + if (Input_Buffer[2] == '+') + { + if (-1 == verbatum_mode ()) + return -1; + } + else + { + fprintf (stderr, "%s:%u:Expecting verbatum start\n", This_Filename, Line_Number); + return -1; + } + break; + } + if (Input_Buffer[1] == 'c') + { + if (0 == strncmp (Input_Buffer, "#c __FILE__: ", 13)) + { + set_source_file (Input_Buffer + 13); + break; + } + if (0 == strncmp (Input_Buffer, "#c __LINE__: ", 13)) + { + set_source_linenum (Input_Buffer + 13); + break; + } + break; + } + + break; + + + case '\\': + Line_Type = SECTION_LINE; + return 1; + + default: + Line_Type = 0; + return 0; + } + } +} + +static Section_Type *get_section (char *buf) +{ + char *name; + Section_Type *sec; + int has_colon; + + if (*buf == '\\') buf++; + + name = buf; + has_colon = 0; + while (*buf != 0) + { + if ((*buf == '\n') + || (*buf == ' ') + || (*buf == '\t')) + { + *buf = 0; + break; + } + if (*buf == '{') + { + has_colon = 1; + *buf = 0; + break; + } + buf++; + } + + sec = Sections; + while (1) + { + if (sec->section_name == NULL) + { + if (Run_Silent == 0) + fprintf (stderr, "%s:%u:Unknown section '%s'\n", This_Filename, Line_Number, name); + return NULL; + } + + if (0 == strcmp (sec->section_name, name)) + break; + + sec++; + } + + if (has_colon) + { + unget_input (buf + 1); + } + + return sec; +} + + +static int process_file (FILE *fp) +{ + Section_Type *sec; + + Input_File_Ptr = fp; + Output_File_Ptr = stdout; + Line_Number = 0; + Top_Level = 1; + Line_Type = 0; + + while (1) + { + while ((Line_Type != SECTION_LINE) + && (Line_Type != END_OF_FILE)) + get_next_line (); + + if (Line_Type == END_OF_FILE) + break; + + if (NULL == (sec = get_section (Input_Buffer))) + { + if (Run_Silent == 0) + fprintf (stderr, "%s:%u:Error ignored.\n", This_Filename, Line_Number); + get_next_line (); + continue; + } + + if (sec->format_fun == NULL) + { + get_next_line (); + continue; + } + + if (-1 == (*sec->format_fun)(sec)) + { + fprintf (stderr, "%s:%u:Fatal error\n", This_Filename, Line_Number); + return -1; + } + } + return 0; +} + + +static void usage (void) +{ + char *pgm = "tm2txt"; + + fprintf (stderr, "%s usage:\n", pgm); + fprintf (stderr, "%s [--help] [--quiet] [files...]\n", pgm); +} + +int main (int argc, char **argv) +{ + if ((argc > 1) + && ((0 == strcmp (argv[1], "--help")) || (0 == strcmp (argv[1], "-h")))) + { + usage (); + return 1; + } + + if ((argc > 1) && (0 == strcmp (argv[1], "--quiet"))) + { + Run_Silent = 1; + argc--; + argv++; + } + + if ((argc == 1) && isatty (fileno(stdin))) + { + usage (); + return 1; + } + + if (argc == 1) + { + This_Filename = ""; + process_file (stdin); + } + else + { + int i; + + for (i = 1; i < argc; i++) + { + char *file = argv[i]; + FILE *fp; + + if (NULL == (fp = fopen (file, "r"))) + { + fprintf (stderr, "Unable to open %s, skipping it.\n", file); + continue; + } + This_Filename = file; + + if (-1 == process_file (fp)) + { + fprintf (stderr, "Fatal error encountered processing %s\n", + file); + fclose (fp); + return 1; + } + + fclose (fp); + } + } + + return 0; +} + +static int write_boldface (char *s) +{ + fprintf (Output_File_Ptr, "%s", s); + return 0; +} + +#if 0 +static int write_tt (char *s) +{ + fprintf (Output_File_Ptr, "`%s'", s); + return 0; +} +#endif +static int newline (void) +{ + fputs ("\n", Output_File_Ptr); + return 0; +} + + +static int write_section_name (char *s) +{ + newline (); + fputs (" ", Output_File_Ptr); + write_boldface (s); + newline (); + return 0; +} + +static char *write_verbatum_output (char *buf) +{ + while (*buf && (*buf != '}')) + { + if (*buf == '\\') + { + buf++; + if (*buf == 0) + break; + } + + putc (*buf, Output_File_Ptr); + buf++; + } + if (*buf == '}') buf++; + return buf; +} + + +static char *write_macro (char *s) +{ + char *s1; + char ch; + Macro_String_Type *m; + + s1 = s; + while ((ch = *s1) != 0) + { + if ((0 == isalnum (ch)) + && (ch != '-') + && (ch != '_')) + break; + + s1++; + } + *s1 = 0; + + m = Macro_Strings; + while (m->name != NULL) + { + if (0 == strcmp (m->name, s)) + { + fputs (m->value, Output_File_Ptr); + *s1 = ch; + return s1; + } + m++; + } + fprintf (Output_File_Ptr, "\\%s", s); + if (Run_Silent == 0) + fprintf (stderr, "%s:%u:%s not defined\n", This_Filename, Line_Number, s); + *s1 = ch; + return s1; +} + + +static int write_with_escape (char *buf) +{ + char ch; + + while (1) + { + ch = *buf++; + switch (ch) + { + case 0: + return 0; + + case '\\': + if (*buf == '\\') + { + putc (*buf, Output_File_Ptr); + buf++; + break; + } + + if ((0 == strncmp ("var{", buf, 4)) + || (0 == strncmp ("par{", buf, 4)) + || (0 == strncmp ("fun{", buf, 4))) + { + putc ('`', Output_File_Ptr); + buf = write_verbatum_output (buf + 4); + putc ('\'', Output_File_Ptr); + break; + } + + if ((0 == strncmp ("exmp{", buf, 5)) + || (0 == strncmp ("ifun{", buf, 5)) + || (0 == strncmp ("cfun{", buf, 5)) + || (0 == strncmp ("sfun{", buf, 5)) + || (0 == strncmp ("ivar{", buf, 5)) + || (0 == strncmp ("cvar{", buf, 5)) + || (0 == strncmp ("svar{", buf, 5))) + { + putc ('`', Output_File_Ptr); + buf = write_verbatum_output (buf + 5); + putc ('\'', Output_File_Ptr); + break; + } + + if (0 == strncmp ("em{", buf, 3)) + { + putc ('_', Output_File_Ptr); + buf = write_verbatum_output (buf + 3); + putc ('_', Output_File_Ptr); + break; + } + + buf = write_macro (buf); + break; + + default: + putc (ch, Output_File_Ptr); + break; + + } + } +} + + + + +static int indent (unsigned int n) +{ + while (n) + { + putc (' ', Output_File_Ptr); + n--; + } + + return 0; +} + +static int write_line (void) +{ + char *s = Input_Buffer; + unsigned int min_indent = 3; + + while ((*s == ' ') && min_indent) + { + s++; + min_indent--; + } + + indent (min_indent); + write_with_escape (Input_Buffer); + newline (); + return 0; +} + + +static int format_function (Section_Type *sec) +{ + (void) sec; + if (Top_Level == 0) + { + fprintf (stderr, "%s:%u:\\function or \\variable not at top-level\n", + This_Filename, Line_Number); + fprintf (stderr, " Input line: %s\n", Input_Buffer); + return -1; + } + Top_Level = 0; + + write_verbatum_output (Input_Buffer); + newline (); + get_next_line (); + return 0; +} + + +static int format_usage (Section_Type *sec) +{ + (void) sec; + write_section_name ("USAGE"); + indent (3); + write_verbatum_output (Input_Buffer); + newline (); + + get_next_line (); + return 0; +} + +static int format_description (Section_Type *sec) +{ + (void) sec; + write_section_name ("DESCRIPTION"); + + while (0 == get_next_line ()) + { + write_line (); + } + return 0; + +} + +static int format_example (Section_Type *sec) +{ + (void) sec; + write_section_name ("EXAMPLE"); + + while (0 == get_next_line ()) + { + write_line (); + } + return 0; +} + +static int format_notes (Section_Type *sec) +{ + (void) sec; + write_section_name ("NOTES"); + + while (0 == get_next_line ()) + { + write_line (); + } + return 0; +} + +static int format_see_also (Section_Type *sec) +{ + (void) sec; + write_section_name ("SEE ALSO"); + indent (3); + write_verbatum_output (Input_Buffer); + newline (); + get_next_line (); + return 0; +} + + +int format_synopsis (Section_Type *sec) +{ + (void) sec; + write_section_name ("SYNOPSIS"); + indent (3); + write_verbatum_output (Input_Buffer); + newline (); + get_next_line (); + return 0; +} + +int format_done (Section_Type *sec) +{ + (void) sec; + if (Top_Level) + { + fprintf (stderr, "%s:%u:\\done seen at top-level\n", + This_Filename, Line_Number); + return -1; + } + + fputs ("--------------------------------------------------------------\n", + Output_File_Ptr); + newline (); + while (0 == get_next_line ()) + ; + Top_Level = 1; + return 0; +} + + +static int begin_verbatum (void) +{ + newline (); + return 0; +} + +static int end_verbatum (void) +{ + newline (); + return 0; +} diff --git a/libslang/examples/assoc.sl b/libslang/examples/assoc.sl new file mode 100644 index 0000000..c4b2b37 --- /dev/null +++ b/libslang/examples/assoc.sl @@ -0,0 +1,46 @@ +% This example illustrates the use of associative arrays. +% The function 'analyse_file' counts the number of occurrences of each word +% in a specified file. Once the file has been read in, it writes out +% the list of words and number of occurrences to the file counts.log + +define analyse_file (file) +{ + variable fp; + variable line; + variable i, a, n, word; + variable keys, values; + + fp = fopen (file, "r"); + if (fp == NULL) + verror ("Unable to open %s", file); + + % Create an Integer_Type assoc array with default value of 0. + a = Assoc_Type[Integer_Type, 0]; + + while (-1 != fgets (&line, fp)) + { + foreach (strtok (strlow(line), "^a-zA-Z\d128-\d255")) + { + word = (); + a[word] = a[word] + 1; % default value of 0 assumed!! + } + } + + () = fclose (fp); + keys = assoc_get_keys (a); + values = assoc_get_values (a); + + i = array_sort (values); + keys = keys[i]; + values = values[i]; + + fp = fopen ("count.log", "w"); + % The default array_sort for Int_Type is an ascending sort. We want the + % opposite. + for (i = n-1; i >= 0; i--) + { + () = fputs (sprintf ("%s:\t%d\n", keys[i], values[i]), fp); + } + () = fclose (fp); +} + diff --git a/libslang/examples/life.sl b/libslang/examples/life.sl new file mode 100644 index 0000000..4d750c0 --- /dev/null +++ b/libslang/examples/life.sl @@ -0,0 +1,131 @@ +% This example provides an implementation of Conway's famous game of life. +% It uses the SMG module from the modules directory. Make sure you +% build it first. + +import ("smg"); + +% This is a simple random number generator +static variable _urand_seed = _time() / (getpid () + 1); +static define _urand (unused) +{ + _urand_seed = _urand_seed * 69069UL + 1013904243UL; + return _urand_seed / 4294967296.0; +} + +static define urand (m, n) +{ + variable a = array_map (Double_Type, &_urand, [1:m*n]); + reshape (a, [m, n]); + return a; +} + +% The algorithm for the game begins here. +static define make_left (n) +{ + variable a; + + a = Int_Type [n]; + a[0] = n-1; + a[[1:]] = [0:n-2]; + + return a; +} + +static define make_right(n) +{ + variable a; + + a = Int_Type [n]; + a[[0:n-2]] = [1:n-1]; + a[-1] = 0; + + return a; +} + + +static define life_init (nr, nc) +{ + variable a; + variable up, down, left, right; + variable i; + variable num_neighbors; + + a = typecast (5.0 * urand (nr, nc), Char_Type); + a[where (a != 1)] = 0; + + up = make_left (nr); + down = make_right (nr); + left = make_left (nc); + right = make_right (nc); + + return (a,up,down,left,right); +} + +static define life_new_generation (a, up, down, left, right) +{ + variable b; + variable middle = [:]; + variable i; + + % Make sure array contains only 0 and 1 + a[where(a)] = 1; + + b = (a[up,left] + a[up, middle] + a[up, right] + + a[middle,left] + a[middle, right] + + a[down, left] + a[down, middle] + a[down, right]); + b = typecast (b, Char_Type); + + i = where ((b < 2) or (b > 3) or ((b == 2) and (a == 0))); + b[i] = 0; + return b; +} + +define life_print (a, old_a) +{ + variable dims, i, j; + (dims,,) = array_info (a); + + a = @a; + a[where (a)] = 1; + a[where (a and (old_a == 0))] = 2; + + smg_set_color (0); + smg_cls (); + + _for (0, dims[0]-1, 1) + { + i = (); + foreach (where (a[i,*])) + { + j = (); + smg_gotorc(i,j); + smg_set_color (a[i,j]); + smg_write_string ("O"); + } + } + smg_set_color (0); + smg_refresh (); + sleep (1); +} + +define life (nr, nc) +{ + variable a, left, right, up, down, new_a; + + (new_a, up, down, left, right) = life_init (nr, nc); + + a = new_a; + do + { + life_print (new_a, a); + a = new_a; + new_a = life_new_generation (a, up, down, left, right); + } + while (length (where (new_a))); +} + +smg_init_smg (); + +life (Smg_Screen_Rows, Smg_Screen_Cols); + + diff --git a/libslang/examples/prime.sl b/libslang/examples/prime.sl new file mode 100644 index 0000000..154f2ee --- /dev/null +++ b/libslang/examples/prime.sl @@ -0,0 +1,46 @@ +#! /usr/bin/env slsh +% This demo counts the number of primes between 2 and some integer + +static define usage () +{ + () = fprintf (stderr, "Usage: %S \n", __argv[0]); + exit (1); +} + +define count_primes (num) +{ + variable size = (num - 1)/2; + variable nonprimes = Char_Type[size + 1]; % last one is sentinel + variable count = 1; + variable prime = 3; + variable i = 0; + + do + { + count++; + %()=printf ("%S\n", prime); + + nonprimes [[i:size-1:prime]] = 1; + variable i_save = i; + while (i++, nonprimes[i]) + ; + prime += 2 * (i - i_save); + } + while (i < size); + + return count; +} + + +static variable Num; + +if (__argc != 2) + usage (); +Num = integer (__argv[1]); +if (Num < 3) + usage (); + +tic (); +()=printf ("\n\n%d primes between 2 and %d in %f seconds.\n", + count_primes (Num), Num, toc ()); +exit(0); diff --git a/libslang/examples/saveobj.sl b/libslang/examples/saveobj.sl new file mode 100644 index 0000000..c7a39a1 --- /dev/null +++ b/libslang/examples/saveobj.sl @@ -0,0 +1,630 @@ +% This example shows how one can save the values of slang variables to a file +% and then load those values back in another instance of the program. +% +% The following code defines two public functions: +% +% save_object (FILE, obj, ...); +% (obj,...) = load_object (FILE); +% +% For example, +% a = [1:20]; +% b = 2.4; +% c = struct { d, e }; c.d = 2.7; c.e = "foobar"; +% save_object ("foo.save", a, b, c); +% +% saves the values of the variables a, b, c to a file called "foo.save". +% These values may be retrieved later, e.g., by another program instance +% via: +% (a,b,c) = load_object ("foo.save"); +% +% Caveats: +% +% 1. Not all object types are supported. The ones supported include: +% +% All integer types (Int_Type, Char_Type, Long_Type, ...) +% Float_Type, Double_Type +% String_Type, BString_Type +% Null_Type +% +% as well as the container classes of the above objects: +% Struct_Type, Array_Type +% +% 2. The algorithm for saving Struct_Type is recursive. This allows one to +% save a linked-list of Struct_Type objects. However, due to the recursive +% nature of the algorithm and the interpreter's finite stack size, such +% linked-lists cannot be arbitrarily long. +% +% 3. Objects are saved in the native representation. As such, the files are +% not portable across machine architectures. +% +% File Format: +% +% Each slang object is written to the file with the following format +% Data_Type (integer) +% Length of Data Bytes (unsigned integer) +% Data Bytes +% +% Here, Data Bytes may specify other objects if the parent is a container +% object. + +%_debug_info = 1; + +static variable Type_Map = Assoc_Type[Integer_Type, -1]; +static variable Write_Object_Funs = Assoc_Type[Ref_Type]; +static variable Read_Object_Funs = Assoc_Type[Ref_Type]; + +!if (is_defined ("_Save_Object_Cache_Type")) +typedef struct +{ + index +} +_Save_Object_Cache_Type; + +static variable Object_Cache; +static variable Num_Cached; + +static define delete_cache () +{ + Object_Cache = NULL; + Num_Cached = 0; +} + +static define create_cache () +{ + delete_cache (); +} + + +% If the object does not need cached, return the object. +% If the object needs cached but does not exist in the cache, cache it and +% return it. +% Otherwise, the object is in the cache, to return a _Save_Object_Cache_Type +% representing the object. +static define cache_object (obj) +{ + variable t = typeof (obj); + + if ((t != Array_Type) + and (0 == is_struct_type (obj))) + return obj; + + variable n = Num_Cached; + variable c = Object_Cache; + while (n) + { + if (__eqs (c.obj, obj)) + { + obj = @_Save_Object_Cache_Type; + obj.index = n; + return obj; + } + + c = c.next; + n--; + } + + c = struct {obj, next}; + c.obj = obj; + c.next = Object_Cache; + Object_Cache = c; + Num_Cached++; + %vmessage ("%S added to cache", c.obj); + + return obj; +} + +static define get_object_from_cache (index) +{ + variable depth = Num_Cached - index; + variable c = Object_Cache; + while (depth) + { + c = c.next; + depth--; + } + return c.obj; +} + +static define get_type_id (type) +{ + variable id; + id = Type_Map[string (type)]; + if (id == -1) + verror ("Object %S is not supported", type); + return id; +} + + + +static define write_not_implemented (fp, object) +{ + () = fprintf (stderr, "write for object %S not implemented\n", typeof (object)); + return 0; +} + +static define do_fwrite (a, fp) +{ + %vmessage ("Writing %S", a); + variable n = fwrite (a, fp); + if (n == -1) + verror ("fwrite failed: %s", errno_string (errno)); + return n; +} + +static define do_fread (t, n, fp) +{ + variable b; + if (n != fread (&b, t, n, fp)) + verror ("fread failed: %s", errno_string (errno)); + %vmessage ("Read %S", b); + return b; +} + +static define do_ftell (fp) +{ + variable pos = ftell (fp); + if (-1 == pos) + verror ("ftell failed: %s", errno_string (errno)); + return pos; +} + +static define do_fseek (fp, ofs, whence) +{ + if (-1 == fseek (fp, ofs, whence)) + verror ("fseek failed: %s", errno_string (errno)); +} + +static define sizeof (t) +{ + variable size; + + switch (t) + { case Char_Type or case UChar_Type: size = 1; } + { case Int16_Type or case UInt16_Type: size = 2; } + { case Int32_Type or case UInt32_Type: size = 4; } + { case Float_Type: size = 4; } + { case Double_Type: size = 8; } + { + verror ("sizeof (%S) not implemented", t); + } + + return size; +} + + +static define write_numbers (fp, a) +{ + variable size = sizeof (_typeof (a)); + variable num = do_fwrite (a, fp); + return num * size; +} + +static define read_numbers (fp, t, nbytes) +{ + variable size = sizeof (t); + nbytes /= size; + return do_fread (t, nbytes, fp); +} + +static define write_string (fp, a) +{ + return do_fwrite (a, fp); +} + +static define read_string (fp, t, nbytes) +{ + t = do_fread (Char_Type, nbytes, fp); + if (nbytes == 1) + t = char (t); + + return t; +} + +static define start_header (fp, id) +{ + variable len = write_numbers (fp, id); + variable pos = do_ftell (fp); + len += write_numbers (fp, 0); % temporary + + variable h = struct + { + pos, len + }; + h.pos = pos; + h.len = len; + + return h; +} + +static define end_header (fp, h, num) +{ + do_fseek (fp, h.pos, SEEK_SET); + () = do_fwrite (num, fp); + do_fseek (fp, 0, SEEK_END); + return h.len + num; +} + +static define id_to_datatype (id) +{ + variable keys, values; + + keys = assoc_get_keys (Type_Map); + values = assoc_get_values (Type_Map); + variable i = where (values == id); + !if (length (i)) + verror ("Corrupt file? Unknown type-id (%d)", id); + return eval (keys[i][0]); +} + +static define write_scalars (fp, a) +{ + variable id = get_type_id (typeof (a)); + variable h = start_header (fp, id); + variable len = write_numbers (fp, a); + return end_header (fp, h, len); +} + +static define read_null (fp, t, nbytes) +{ + return NULL; +} + +static define write_null (fp, a) +{ + return 0; +} + +static define write_object (); +static define read_object (); + +% Array DataBytes: int num_dims, int dims[num_dims], type, Data... +static define write_array (fp, a) +{ + variable dims, num_dims, data_type; + (dims, num_dims, data_type) = array_info (a); + variable len; + variable id = get_type_id (data_type); + + len = write_numbers (fp, num_dims) + write_numbers (fp, dims) + + write_numbers (fp, id); + + % For now allow numbers or strings + if (_typeof(a) == String_Type) + { + foreach (a) + { + variable elem = (); + len += write_object (fp, elem); + } + + return len; + } + + len += write_numbers (fp, a); + + return len; +} + +static define read_array (fp, type, nbytes) +{ + variable num_dims = do_fread (Int_Type, 1, fp); + variable dims = do_fread (Int_Type, num_dims, fp); + type = do_fread (Int_Type, 1, fp); + variable len; + len = 1; + foreach (dims) + len *= (); + + type = id_to_datatype (type); + + variable v; + + if (type == String_Type) + { + v = String_Type [len]; + _for (0,len-1,1) + { + variable i = (); + v[i] = read_object (fp, NULL); + } + } + else v = do_fread (type, len, fp); + + reshape (v, dims); + return v; +} + +% Data Bytes: int num_fields. String-Object [num_fields], Values[num_fields] +static define write_struct (fp, a) +{ + variable fields = get_struct_field_names (a); + variable len = write_numbers (fp, typecast (length (fields), Int_Type)); + foreach (fields) + { + variable f = (); + len += write_object (fp, f); + } + + foreach (fields) + { + f = (); + len += write_object (fp, get_struct_field (a, f)); + } + + return len; +} + +static define read_struct (fp, type, nbytes) +{ + variable num_fields = do_fread (Int_Type, 1, fp); + variable fields = String_Type[num_fields]; + variable i; + _for (0, num_fields-1, 1) + { + i = (); + fields[i] = read_object (fp, NULL); + } + + variable s = @Struct_Type (fields); + + % make sure it is in the cache in case the fields refer to it. + if (type != _Save_Object_Cache_Type) + () = cache_object (s); + + _for (0, num_fields-1, 1) + { + i = (); + set_struct_field (s, fields[i], read_object (fp, NULL)); + } + + return s; +} + +% Data Bytes: int index +static define write_cached_object (fp, a) +{ + return write_numbers (fp, a.index); +} + + +static define read_cached_object (fp, type, nbytes) +{ + variable index = read_numbers (fp, Int_Type, nbytes); + return get_object_from_cache (index); +} + + +static define add_type (t, w, r, id) +{ + t = string (t); + Type_Map[t] = id; + Write_Object_Funs[t] = w; + Read_Object_Funs [t] = r; +} + +add_type (Char_Type, &write_numbers, &read_numbers, 1); +add_type (UChar_Type, &write_numbers, &read_numbers, 2); +add_type (Short_Type, &write_numbers, &read_numbers, 3); +add_type (UShort_Type, &write_numbers, &read_numbers, 4); +add_type (Integer_Type, &write_numbers, &read_numbers, 5); +add_type (UInteger_Type,&write_numbers, &read_numbers, 6); +add_type (Long_Type, &write_numbers, &read_numbers, 7); +add_type (ULong_Type, &write_numbers, &read_numbers, 8); +add_type (Float_Type, &write_numbers, &read_numbers, 9); +add_type (Double_Type, &write_numbers, &read_numbers, 10); +add_type (String_Type, &write_string, &read_string, 11); +add_type (BString_Type, &write_string, &read_string, 12); +add_type (Struct_Type, &write_struct, &read_struct, 13); +add_type (Array_Type, &write_array, &read_array, 14); +add_type (Null_Type, &write_null, &read_null, 15); + +add_type (_Save_Object_Cache_Type, &write_cached_object, &read_cached_object, 1000); + +static define get_write_function (type) +{ + variable key = string (type); + if (assoc_key_exists (Write_Object_Funs, key)) + return Write_Object_Funs[key]; + verror ("No write method defined for %S", key); +} + +static define get_read_function (type) +{ + variable key = string (type); + if (assoc_key_exists (Read_Object_Funs, key)) + return Read_Object_Funs[key]; + verror ("No read method defined for %S", key); +} + +static define write_object (fp, a) +{ + a = cache_object (a); + variable id = get_type_id (typeof (a)); + + variable h = start_header (fp, id); + variable f = get_write_function (typeof (a)); + variable num = (@f)(fp, a); + %vmessage ("Done Writing %S", a); + return end_header (fp, h, num); +} + +static define read_object (fp, statusp) +{ + variable type, nbytes; + variable status = fread (&type, Integer_Type, 1, fp); + if (status == -1) + { + if (statusp == NULL) + verror ("No more objects in file"); + + @statusp = 0; + return 0; + } + + nbytes = do_fread (Integer_Type, 1, fp); + type = id_to_datatype (type); + + variable f = get_read_function (type); + variable v = (@f)(fp, type, nbytes); + + % Necessary because String_Type may get written as BString_Type + if (type != _Save_Object_Cache_Type) + v = typecast (v, type); + + %vmessage ("Read %S", v); + if (statusp != NULL) + @statusp = 1; + + return v; +} + + +public define save_object () +{ + if (_NARGS < 2) + usage ("save_object (file, obj1, ...)"); + + variable objs = __pop_args (_NARGS - 1); + variable file = (); + + variable fp = fopen (file, "w+"); + if (fp == NULL) + verror ("Unable to open %s: %s", file, errno_string (errno)); + + create_cache (); + + foreach (objs) + { + variable obj = ().value; + () = write_object (fp, obj); + } + + delete_cache (); +} + +public define load_object (file) +{ + variable fp = fopen (file, "r"); + if (fp == NULL) + verror ("Unable to open %s: %s", file, errno_string (errno)); + + create_cache (); + forever + { + variable status; + variable obj = read_object (fp, &status); + if (status == 0) + break; + obj; + } + delete_cache (); +} + +#iffalse +% Regression test +static define failed (s, a, b) +{ + vmessage ("Failed: %s: wrote: '%S', read '%S'\n", s, a, b); +} + +static define test_eqs (); +static define test_eqs (a, b) +{ + if ((typeof (a) != typeof (b)) + or (_typeof (a) != _typeof (b))) + { + failed ("typeof", typeof(a), typeof(b)); + return 0; + } + + if (typeof (a) != Struct_Type) + { + if (length (a) != length (b)) + { + failed ("test_eqs length", a, b); + return 0; + } + + if (length (where (a != b))) + { + failed ("test_eqs", a, b); + return 0; + } + return 1; + } + + variable fa, fb; + fa = get_struct_field_names (a); + fb = get_struct_field_names (b); + + !if (test_eqs (fa, fb)) + { + failed ("test_eqs: fa, fb"); + return 0; + } + + if (length (fa) != length (fb)) + return 0; + + foreach (fa) + { + variable name = (); + variable va, vb; + va = get_struct_field (a, name); + vb = get_struct_field (b, name); + if ((typeof (va) == Struct_Type) + and (typeof (vb) == Struct_Type)) + { + % void loop + continue; + } + !if (test_eqs (va, vb)) + return 0; + } + + return 1; +} + +static define test_save_object () +{ + variable x0 = 1278; + variable x1 = 2.3; + variable x2 = "foo"; + variable x3 = struct + { + a, b, c, d + }; + variable x4 = [1:10]; + variable x5 = ["a","b","c","d"]; + + x3.a = "foo"; + x3.b = PI; + x3.c = [1:20]; + x3.d = x3; + + save_object ("foo.sv", x0,x1,x2,x3,x4,x5); + + variable y0,y1,y2,y3,y4,y5; + + (y0,y1,y2,y3,y4,y5) = load_object ("foo.sv"); + + !if (test_eqs (x0, y0)) + failed ("x0", x0, y0); + !if (test_eqs (x1, y1)) + failed ("x1", x1, y1); + !if (test_eqs (x2, y2)) + failed ("x2", x2, y2); + + !if (test_eqs (x3, y3)) + failed ("x3", x3, y3); + + !if (test_eqs (x4, y4)) + failed ("x4", x4, y4); + !if (test_eqs (x5, y5)) + failed ("x5", x5, y5); + + vmessage ("Regression Test Done"); +} + +test_save_object (); +#endif diff --git a/libslang/examples/sort.sl b/libslang/examples/sort.sl new file mode 100644 index 0000000..c2eb7ad --- /dev/null +++ b/libslang/examples/sort.sl @@ -0,0 +1,62 @@ +#! /usr/bin/env slsh + +% This program presents the solution to a problem posed by +% Tom Christiansen . The problem reads: +% +% Sort an input file that consists of lines like this +% +% var1=23 other=14 ditto=23 fred=2 +% +% such that each output line is sorted WRT to the number. Order +% of output lines does not change. Resolve collisions using the +% variable name. e.g. +% +% fred=2 other=14 ditto=23 var1=23 +% +% Lines may be up to several kilobytes in length and contain +% zillions of variables. +%--------------------------------------------------------------------------- +% +% The solution presented below works by breaking up the line into an +% array of alternating keywords and values with the keywords as the even +% elements and the values as the odd. It is about 30% faster than the +% python solution. + +static variable Keys, Values; +static define sort_fun (i, j) +{ + variable s, a, b; + + s = Values[i] - Values[j]; + !if (s) + return strcmp (Keys[i], Keys[j]); + return s; +} + + +define main () +{ + variable line, len, i, vals; + foreach (stdin) + { + line = (); + line = strtok (line, " \t\n="); + len = length(line)/2; + if (len == 0) + continue; + + % Even elements are keys, odd are values + Keys = line[[0::2]]; + vals = line[[1::2]]; + + Values = array_map(Int_Type, &integer, vals); + + i = array_sort ([0:len-1], &sort_fun); + + % There are different ways of writing the result. Here is a + % fast way that avoids a loop. + () = printf ("%s\n", strjoin (Keys[i] + "=" + vals[i], " ")); + } +} + +main (); diff --git a/libslang/examples/utmp.sl b/libslang/examples/utmp.sl new file mode 100644 index 0000000..b7a69af --- /dev/null +++ b/libslang/examples/utmp.sl @@ -0,0 +1,67 @@ +% This file illustrates how to read a binary file into a structure. In this +% case, the file is the Unix utmp file. +% +% Note that the format of the utmp file will vary with the OS. The format +% encoded here is for glibc Linux, but even that may be version-dependent. + +variable format, size, fp, buf; + +variable is_glibc = 1; + +#ifeval is_glibc +typedef struct +{ + ut_type, ut_pid, ut_line, ut_id, + ut_user, ut_host, ut_exit, ut_session, ut_tv, ut_addr +} UTMP_Type; +% The ut_tv is a timeval structure which has the format: l2 +% Also the ut_exit field is a struct of h2 +format = pad_pack_format ("h i S32 S4 S32 S256 h2 l l2 k4 x20"); +#else +typedef struct +{ + ut_type, ut_pid, ut_line, ut_id, + ut_time, ut_user, ut_host, ut_addr +} UTMP_Type; +format = pad_pack_format ("h i S12 S2 l S8 S16 l"); +#endif + +size = sizeof_pack (format); +vmessage ("Sizeof of utmp line: %d bytes", size); + +define print_utmp (u) +{ + () = fprintf (stdout, "%-16s %-12s %-16s %s\n", + u.ut_user, u.ut_line, u.ut_host, +#ifeval is_glibc + ctime (u.ut_tv[0]) +#else + ctime (u.ut_time) +#endif + ); +} + +variable Utmp_File; +foreach (["/var/run/utmp", "/var/log/utmp"]) +{ + Utmp_File = (); + fp = fopen (Utmp_File, "rb"); + if (fp != NULL) + break; +} + +if (fp == NULL) error ("Unable to open utmp file"); + +() = fprintf (stdout, "%-16s %-12s %-16s %s\n", + "USER", "TTY", "FROM", "LOGIN@"); + +variable U = @UTMP_Type; + +while (size == fread (&buf, Char_Type, size, fp)) +{ + set_struct_fields (U, unpack (format, buf)); + print_utmp (U); +} + +() = fclose (fp); + diff --git a/libslang/modules/Makefile.in b/libslang/modules/Makefile.in new file mode 100644 index 0000000..3d8a480 --- /dev/null +++ b/libslang/modules/Makefile.in @@ -0,0 +1,56 @@ +# -*- sh -*- +MODULES = smg-module.so termios-module.so select-module.so fcntl-module.so \ + varray-module.so pcre-module.so +#--------------------------------------------------------------------------- +CC_SHARED = @CC_SHARED@ +#--------------------------------------------------------------------------- +# Installation location of the slang library +#--------------------------------------------------------------------------- +prefix = @prefix@ +exec_prefix = @exec_prefix@ +SLANG_INC = -I@includedir@ +SLANG_LIB = -L@libdir@ -lslang +#--------------------------------------------------------------------------- +# Installation location of the modules +#--------------------------------------------------------------------------- +MODULE_INSTALL_DIR = @libdir@/slang/modules +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +MKINSDIR = ../autoconf/mkinsdir.sh +#--------------------------------------------------------------------------- +# DESTDIR is designed to facilitate making packages. Normally it is empty +#--------------------------------------------------------------------------- +DESTDIR = +DEST_MODULEDIR = $(DESTDIR)$(MODULE_INSTALL_DIR) +#--------------------------------------------------------------------------- +RPATH = @RPATH@ + +LIBS = $(RPATH) $(SLANG_LIB) $(DL_LIB) -lm +INCS = $(SLANG_INC) + +all: $(MODULES) + +smg-module.so: smg-module.c + $(CC_SHARED) $(INCS) smg-module.c -o smg-module.so $(LIBS) +newt-module.so: newt-module.c + $(CC_SHARED) $(INCS) newt-module.c -o newt-module.so -lnewt $(LIBS) +termios-module.so: termios-module.c + $(CC_SHARED) $(INCS) termios-module.c -o termios-module.so $(LIBS) +select-module.so: select-module.c + $(CC_SHARED) $(INCS) select-module.c -o select-module.so $(LIBS) +fcntl-module.so: fcntl-module.c + $(CC_SHARED) $(INCS) fcntl-module.c -o fcntl-module.so $(LIBS) +varray-module.so: varray-module.c + $(CC_SHARED) $(INCS) varray-module.c -o varray-module.so $(LIBS) +pcre-module.so: pcre-module.c + $(CC_SHARED) $(INCS) pcre-module.c -o pcre-module.so -lpcre $(LIBS) + +install: all + -$(MKINSDIR) $(DEST_MODULEDIR) + @for i in $(MODULES); \ + do \ + echo $(INSTALL_DATA) $$i $(DEST_MODULEDIR); \ + $(INSTALL_DATA) $$i $(DEST_MODULEDIR); \ + done +clean: + -/bin/rm -f $(MODULES) *~ diff --git a/libslang/modules/README b/libslang/modules/README new file mode 100644 index 0000000..f6b1292 --- /dev/null +++ b/libslang/modules/README @@ -0,0 +1,66 @@ +This directory contains some examples of dynamically loaded modules +that may be loaded via the `import' intrinsic function. If you choose +to build these modules, do so only AFTER installing the slang library +because the Makefile references the installed slang library location. + +The default installation location for the modules is in +$(prefix)/lib/slang/modules. + +-------------------------------------------------------------------- + +This directory contains some examples of dynamically loaded modules +that may be loaded via the `import' intrinsic function: + + import ("NAME"); + +This intrinsic function is available to applications that enable it +via a call to the `SLang_init_import' function. Of course, the OS +must provide support for dynamic linking. + +When a slang script contains a line such as + + import ("NAME"); + +or + + import ("NAME", "NAMESPACE"); + + +slang requests that the operating system dynamically link to a shared +object called NAME-module.so. Then the slang library will call the +function `init_NAME_ns' that NAME-module.so must define. This function +must have the prototype: + + int init_NAME_ns (char *namespace); + +and shall return 0 upon success, or -1 if an error occurred. The +namespace argument corresponds to the second (option) parameter of the +import intrinsic. This means that the user wishes to import the +module into the specified namespace. To this end, the module must +call one of the SLns_* functions to load intrinsics into a namespace. + +Optionally, the module may define a function called `deinit_NAME' that +will be called by the interpreter to deinitialize the module. This +function must have the prototype: + + void deinit_NAME (void); + +To ensure the correct prototypes for these functions, the module +should include the line: + + SLANG_MODULE(name); + +SLANG_MODULE is a macro that expands into function prototypes. + +See the examples in this directory for more information. + +To run these modules, use the slsh program in ../slsh/. +slsh.c is a program that embeds the interpreter and may be used to +test slang scripts. In fact, it may be used to create unix executable +scripts via, e.g., + +#! /usr/bin/env slsh + +as the first line of the script. See ../slsh/scripts subdirectory for +examples of this approach. + diff --git a/libslang/modules/fcntl-module.c b/libslang/modules/fcntl-module.c new file mode 100644 index 0000000..7b329ab --- /dev/null +++ b/libslang/modules/fcntl-module.c @@ -0,0 +1,117 @@ +/* Copyright (c) 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include +#include + +#include +#include +#include +#include + +SLANG_MODULE(fcntl); + +static int check_and_set_errno (int e) +{ +#ifdef EINTR + if (e == EINTR) + return 0; +#endif + (void) SLerrno_set_errno (e); + return -1; +} + +static int do_fcntl_2 (SLFile_FD_Type *f, int cmd) +{ + int ret; + int fd; + + if (-1 == SLfile_get_fd (f, &fd)) + return -1; + + while ((-1 == (ret = fcntl (fd, cmd))) + && (0 == check_and_set_errno (errno))) + ; + + return ret; +} + +static int do_fcntl_3_int (SLFile_FD_Type *f, int cmd, int flags) +{ + int ret; + int fd; + + + if (-1 == SLfile_get_fd (f, &fd)) + return -1; + + while ((-1 == (ret = fcntl (fd, cmd, flags))) + && (0 == check_and_set_errno (errno))) + ; + + return ret; +} + +static int fcntl_getfd (SLFile_FD_Type *f) +{ + return do_fcntl_2 (f, F_GETFD); +} + +static int fcntl_setfd (SLFile_FD_Type *f, int *flags) +{ + return do_fcntl_3_int (f, F_SETFD, *flags); +} + +static int fcntl_getfl (SLFile_FD_Type *f) +{ + return do_fcntl_2 (f, F_GETFL); +} + +static int fcntl_setfl (SLFile_FD_Type *f, int *flags) +{ + return do_fcntl_3_int (f, F_SETFL, *flags); +} + +#define F SLANG_FILE_FD_TYPE +#define I SLANG_INT_TYPE +static SLang_Intrin_Fun_Type Fcntl_Intrinsics [] = +{ + MAKE_INTRINSIC_1("fcntl_getfd", fcntl_getfd, I, F), + MAKE_INTRINSIC_2("fcntl_setfd", fcntl_setfd, I, F, I), + MAKE_INTRINSIC_1("fcntl_getfl", fcntl_getfl, I, F), + MAKE_INTRINSIC_2("fcntl_setfl", fcntl_setfl, I, F, I), + + SLANG_END_INTRIN_FUN_TABLE +}; +#undef I +#undef F + +static SLang_IConstant_Type Fcntl_Consts [] = +{ + MAKE_ICONSTANT("FD_CLOEXEC", FD_CLOEXEC), + SLANG_END_ICONST_TABLE +}; + +int init_fcntl_module_ns (char *ns_name) +{ + SLang_NameSpace_Type *ns; + + ns = SLns_create_namespace (ns_name); + if (ns == NULL) + return -1; + + if ((-1 == SLns_add_intrin_fun_table (ns, Fcntl_Intrinsics, "__FCNTL__")) + || (-1 == SLns_add_iconstant_table (ns, Fcntl_Consts, NULL))) + return -1; + + return 0; +} + +/* This function is optional */ +void deinit_fcntl_module (void) +{ +} diff --git a/libslang/modules/grep b/libslang/modules/grep new file mode 100755 index 0000000..a8f97d6 --- /dev/null +++ b/libslang/modules/grep @@ -0,0 +1,171 @@ +#!/usr/bin/env slsh + +% This is a simple-minded implementation of a highlighting grep program +% designed to test the pcre module. +import ("pcre"); + +static define usage () +{ + ()=fprintf(stderr, "Usage: %s [-inl] pattern [files...]\n", __argv[0]); + exit (1); +} + +static variable MATCH = 1; +static variable LINENUM = 2; +static variable FILENAME = 4; +static variable Output_Format = 0; + +static define grep (file, p) +{ + variable fp; + + if (file == NULL) + fp = stdin; + else + fp = fopen (file, "r"); + + if (fp == NULL) + { + fprintf (stderr, "*** Unable to open %s\n", file); + return; + } + + variable linenum = 0; + foreach (fp) using ("line") + { + variable str = (); + linenum++; + + if (pcre_exec (p, str, 0)) + { + variable i0, i1, i; + + switch (Output_Format) + { + case FILENAME: + () = fprintf (stdout, "%s\n", file); + return; + } + { + case LINENUM: + () = fprintf (stdout, "%d\n", linenum); + continue; + } + { + case (MATCH|LINENUM): + + () = fprintf (stdout, "%d:", linenum); + } + { + case (LINENUM|FILENAME): + () = fprintf (stdout, "%s:%d\n", file, linenum); + continue; + } + { + case (LINENUM|FILENAME|MATCH): + () = fprintf (stdout, "%s:%d:", file, linenum); + } + { + case (FILENAME|MATCH): + () = fprintf (stdout, "%s:", file); + } + + do + { + i = pcre_nth_match (p, 0); + i0 = i[0]; + i1 = i[1]; + if (i1 <= i0) + break; + if (i0 > 0) + () = fprintf (stdout, "%s", str[[0:i0-1]]); + () = fprintf (stdout, "\e[7m%s\e[m", str[[i0:i1-1]]); + str = str[[i1:]]; + } + while (pcre_exec (p, str, 0)); + () = fprintf (stdout, "%s", str); + } + } +} + +static define main (argc, argv) +{ + variable i; + variable files, pattern; + variable options; + + i = 1; + files = NULL; + pattern = NULL; + options = 0; + Output_Format = MATCH; + + while (i < argc) + { + variable arg = __argv[i]; + i++; + + if (arg[0] == '-') + { + foreach (arg[[1:]]) + { + variable ch = (); + switch (ch) + { + case 'i': + options |= PCRE_CASELESS; + } + { + case 'l': + Output_Format &= ~MATCH; + Output_Format |= FILENAME; + } + { + case 'n': + Output_Format |= LINENUM; + } + { + () = fprintf (stderr, "Unsupported option: '%c'\n", ch); + exit (1); + } + } + continue; + } + + pattern = arg; + break; + } + + if (pattern == NULL) + usage (); + + variable p = pcre_compile (pattern, options); + + if (i == __argc) + { + if (isatty (stdin)) + usage (); + + Output_Format &= ~FILENAME; + grep (NULL, p); + return; + } + + files = argv[[i:]]; + + if (length(files) > 1) + Output_Format |= FILENAME; + + foreach (files) + { + variable f = (); + grep (f, p); + } +} + +public define slsh_main () +{ + main (__argc, __argv); + exit (0); +} + diff --git a/libslang/modules/newt-module.c b/libslang/modules/newt-module.c new file mode 100644 index 0000000..9788ed1 --- /dev/null +++ b/libslang/modules/newt-module.c @@ -0,0 +1,91 @@ +/* This module implements and interface to the Newt library */ +#include +#include +#include + +SLANG_MODULE(newt); + +static int Ok_To_Draw; + +static void init (void) +{ + newtInit (); + Ok_To_Draw = 1; +} + +static void cls (void) +{ + if (Ok_To_Draw) + newtCls (); +} + +static void draw_root_text (int *c, int *r, char *s) +{ + if (Ok_To_Draw) + newtDrawRootText (*c, *r, s); +} + +static void open_window (int *c, int *r, int *dc, int *dr, char *title) +{ + if (Ok_To_Draw) + newtOpenWindow (*c, *r, *dc, *dr, title); +} + +static void refresh (void) +{ + if (Ok_To_Draw) + newtRefresh (); +} + +static void finished (void) +{ + if (Ok_To_Draw) + newtFinished (); + Ok_To_Draw = 0; +} + +#define I SLANG_INT_TYPE +#define S SLANG_STRING_TYPE + +static SLang_Intrin_Fun_Type Module_Funs [] = +{ + MAKE_INTRINSIC_0("newtInit", init, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("newtCls", cls, SLANG_VOID_TYPE), + MAKE_INTRINSIC_IIS("newtDrawRootText", draw_root_text, SLANG_VOID_TYPE), + MAKE_INTRINSIC_5("newtOpenWindow", open_window, SLANG_VOID_TYPE, I,I,I,I,S), + MAKE_INTRINSIC_0("newtRefresh", refresh, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("NewtFinished", finished, SLANG_VOID_TYPE), + + SLANG_END_TABLE +}; + +static SLang_Intrin_Var_Type Module_Variables [] = +{ + SLANG_END_TABLE +}; + +static SLang_IConstant_Type Module_Constants [] = +{ + SLANG_END_TABLE +}; + + +int init_newt_module_ns (char *ns) +{ + if ((-1 == SLns_add_intrin_fun_table (ns, Module_Funs, "__NEWT__")) + || (-1 == SLns_add_intrin_var_table (ns, Module_Variables, NULL)) + || (-1 == SLns_add_iconstant_table (ns, Module_Constants, NULL))) + return -1; + + Ok_To_Draw = 0; + + (void) SLang_add_cleanup_function (finished); + + return 0; +} + +/* This function is optional */ +void deinit_newt_module (void) +{ + finished (); +} diff --git a/libslang/modules/newt.sl b/libslang/modules/newt.sl new file mode 100644 index 0000000..0864d5e --- /dev/null +++ b/libslang/modules/newt.sl @@ -0,0 +1,14 @@ +import ("newt"); + +newtInit (); +%newtCls (); +newtDrawRootText (0, 0, "Root Text"); +newtOpenWindow (3,4,20, 20, "First Window"); +newtOpenWindow (8, 10,20, 20, "Second Window"); + +newtRefresh (); +sleep (5); +NewtFinished (); + +exit (0); + diff --git a/libslang/modules/pcre-module.c b/libslang/modules/pcre-module.c new file mode 100644 index 0000000..926e477 --- /dev/null +++ b/libslang/modules/pcre-module.c @@ -0,0 +1,618 @@ +#include +#include +#include + +SLANG_MODULE(pcre); + +static int PCRE_Type_Id; + +typedef struct +{ + pcre *p; + pcre_extra *extra; + int *ovector; + unsigned int ovector_len; /* must be a multiple of 3 */ + unsigned int num_matches; /* return value of pcre_exec (>= 1)*/ +} +PCRE_Type; + +static void free_pcre_type (PCRE_Type *pt) +{ + if (pt->ovector != NULL) + SLfree ((char *) pt->ovector); + + SLfree ((char *) pt); +} + +static SLang_MMT_Type *allocate_pcre_type (pcre *p, pcre_extra *extra) +{ + PCRE_Type *pt; + SLang_MMT_Type *mmt; + int ovector_len; + + pt = (PCRE_Type *) SLmalloc (sizeof (PCRE_Type)); + if (pt == NULL) + return NULL; + memset ((char *) pt, 0, sizeof (PCRE_Type)); + + pt->p = p; + pt->extra = extra; + + if (0 != pcre_fullinfo (p, extra, PCRE_INFO_CAPTURECOUNT, &ovector_len)) + { + free_pcre_type (pt); + SLang_verror (SL_INTRINSIC_ERROR, "pcre_fullinfo failed"); + return NULL; + } + + ovector_len += 1; /* allow for pattern matched */ + ovector_len *= 3; /* required to be multiple of 3 */ + if (NULL == (pt->ovector = (int *)SLmalloc (ovector_len * sizeof (int)))) + { + free_pcre_type (pt); + return NULL; + } + pt->ovector_len = ovector_len; + + if (NULL == (mmt = SLang_create_mmt (PCRE_Type_Id, (VOID_STAR) pt))) + { + free_pcre_type (pt); + return NULL; + } + return mmt; +} + +static int _pcre_compile_1 (char *pattern, int options) +{ + pcre *p; + pcre_extra *extra; + SLCONST char *err; + int erroffset; + unsigned char *table; + SLang_MMT_Type *mmt; + + table = NULL; + p = pcre_compile (pattern, options, &err, &erroffset, table); + if (NULL == p) + { + SLang_verror (SL_INTRINSIC_ERROR, "Error compiling pattern '%s' at offset %d: %s", + pattern, erroffset, err); + return -1; + } + + extra = pcre_study (p, 0, &err); + /* apparantly, a NULL return is ok */ + if (err != NULL) + { + SLang_verror (SL_INTRINSIC_ERROR, "pcre_study failed: %s", err); + pcre_free (p); + return -1; + } + + if (NULL == (mmt = allocate_pcre_type (p, extra))) + { + pcre_free ((char *) p); + pcre_free ((char *) extra); + return -1; + } + + if (-1 == SLang_push_mmt (mmt)) + { + SLang_free_mmt (mmt); + return -1; + } + return 0; +} + +static void _pcre_compile (void) +{ + char *pattern; + int options = 0; + + switch (SLang_Num_Function_Args) + { + case 2: + if (-1 == SLang_pop_integer (&options)) + return; + /* drop */ + case 1: + default: + if (-1 == SLang_pop_slstring (&pattern)) + return; + } + (void) _pcre_compile_1 (pattern, options); + SLang_free_slstring (pattern); +} + + + +/* returns number of matches */ +static int _pcre_exec_1 (PCRE_Type *pt, char *str, int pos, int options) +{ + int rc; + unsigned int len; + + pt->num_matches = 0; + len = strlen (str); + if ((unsigned int) pos > len) + return 0; + + rc = pcre_exec (pt->p, pt->extra, str, len, pos, + options, pt->ovector, pt->ovector_len); + + if (rc == PCRE_ERROR_NOMATCH) + return 0; + + if (rc <= 0) + { + SLang_verror (SL_INTRINSIC_ERROR, "pcre_exec returned %d", rc); + return -1; + } + pt->num_matches = (unsigned int) rc; + return rc; +} + +static int _pcre_exec (void) +{ + PCRE_Type *p; + SLang_MMT_Type *mmt; + char *str; + int pos = 0; + int options = 0; + int ret = -1; + + switch (SLang_Num_Function_Args) + { + case 4: + if (-1 == SLang_pop_integer (&options)) + return -1; + case 3: + if (-1 == SLang_pop_integer (&pos)) + return -1; + default: + if (-1 == SLang_pop_slstring (&str)) + return -1; + + if (NULL == (mmt = SLang_pop_mmt (PCRE_Type_Id))) + goto free_and_return; + p = SLang_object_from_mmt (mmt); + } + ret = _pcre_exec_1 (p, str, pos, options); + + free_and_return: + SLang_free_slstring (str); + SLang_free_mmt (mmt); + return ret; +} + + +static int get_nth_start_stop (PCRE_Type *pt, unsigned int n, + unsigned int *a, unsigned int *b) +{ + int start, stop; + + if (n >= pt->num_matches) + return -1; + + start = pt->ovector[2*n]; + stop = pt->ovector[2*n+1]; + if ((start < 0) || (stop < start)) + return -1; + + *a = (unsigned int) start; + *b = (unsigned int) stop; + return 0; +} + +static void _pcre_nth_match (PCRE_Type *pt, int *np) +{ + unsigned int start, stop; + SLang_Array_Type *at; + int two = 2; + int *data; + + if (-1 == get_nth_start_stop (pt, (unsigned int) *np, &start, &stop)) + { + SLang_push_null (); + return; + } + + if (NULL == (at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &two, 1))) + return; + + data = (int *)at->data; + data[0] = (int)start; + data[1] = (int)stop; + (void) SLang_push_array (at, 1); +} + +static void _pcre_nth_substr (PCRE_Type *pt, char *str, int *np) +{ + unsigned int start, stop; + unsigned int len; + + len = strlen (str); + + if ((-1 == get_nth_start_stop (pt, (unsigned int) *np, &start, &stop)) + || (start > len) || (stop > len)) + { + SLang_push_null (); + return; + } + + str = SLang_create_nslstring (str + start, stop - start); + (void) SLang_push_string (str); + SLang_free_slstring (str); +} + +/* This function converts a slang RE to a pcre expression. It performs the + * following transformations: + * ( --> \( + * ) --> \) + * # --> \# + * | --> \| + * { --> \{ + * } --> \} + * \< --> \b + * \> --> \b + * \C --> (?i) + * \c --> (?-i) + * \( --> ( + * \) --> ) + * \{ --> { + * \} --> } + * Anything else? + */ +static char *_slang_to_pcre (char *slpattern) +{ + char *pattern, *p, *s; + unsigned int len; + int in_bracket; + char ch; + + len = strlen (slpattern); + pattern = SLmalloc (3*len + 1); + if (pattern == NULL) + return NULL; + + p = pattern; + s = slpattern; + in_bracket = 0; + while ((ch = *s++) != 0) + { + switch (ch) + { + case '{': + case '}': + case '(': + case ')': + case '#': + case '|': + if (0 == in_bracket) *p++ = '\\'; + *p++ = ch; + break; + + case '[': + in_bracket = 1; + *p++ = ch; + break; + + case ']': + in_bracket = 0; + *p++ = ch; + break; + + case '\\': + ch = *s++; + switch (ch) + { + case 0: + s--; + break; + + case '<': + case '>': + *p++ = '\\'; *p++ = 'b'; + break; + + case '(': + case ')': + case '{': + case '}': + *p++ = ch; + break; + + case 'C': + *p++ = '('; *p++ = '?'; *p++ = 'i'; *p++ = ')'; + break; + case 'c': + *p++ = '('; *p++ = '?'; *p++ = '-'; *p++ = 'i'; *p++ = ')'; + break; + + default: + *p++ = '\\'; + *p++ = ch; + } + break; + + default: + *p++ = ch; + break; + } + } + *p = 0; + + s = SLang_create_slstring (pattern); + SLfree (pattern); + return s; +} + +static void slang_to_pcre (char *pattern) +{ + /* NULL ok in code below */ + pattern = _slang_to_pcre (pattern); + (void) SLang_push_string (pattern); + SLang_free_slstring (pattern); +} + +static void destroy_pcre (SLtype type, VOID_STAR f) +{ + PCRE_Type *pt; + (void) type; + + pt = (PCRE_Type *) f; + if (pt->extra != NULL) + pcre_free ((char *) pt->extra); + if (pt->p != NULL) + pcre_free ((char *) pt->p); + free_pcre_type (pt); +} + +#define DUMMY_PCRE_TYPE 255 +#define P DUMMY_PCRE_TYPE +#define I SLANG_INT_TYPE +#define V SLANG_VOID_TYPE +#define S SLANG_STRING_TYPE +static SLang_Intrin_Fun_Type PCRE_Intrinsics [] = +{ + MAKE_INTRINSIC_0("pcre_compile", _pcre_compile, V), +/*%+ + *\function{pcre_compile} + *\synopsis{Compile a regular expression} + *\usage{PCRE_Type pcre_compile (String_Type pattern [, Int_Type options])} + *\description + * The \var{pcre_compile} function compiles a PCRE style regular expression + * and returns the result. The optional \var{options} argument may be used + * to provide addition information affecting the compilation of the pattern. + * Specifically, it is a bit-mapped value formed from the logical-or of zero + * or more of the following symbolic constants: + *#v+ + * PCRE_ANCHORED Force the match to be at the start of a string + * PCRE_CASELESS Matches are to be case-insensitive + * PCRE_DOLLAR_ENDONLY (See PCRE docs for more information) + * PCRE_DOTALL The dot pattern matches all characters + * PCRE_EXTENDED Ignore whitespace in the pattern + * PCRE_EXTRA (See PCRE docs for features this activates) + * PCRE_MULTILINE Treat the subject string as multi-lines + * PCRE_UNGREEDY Make the matches greedy + * PCRE_UTF8 Regard the pattern and subject strings as UTF-8 + *#v- + * Many of these flags may be set within the pattern itself. See the PCRE + * library documentation for more information about the precise details + * of these flags and the supported regular expressions. + * + * Upon success, this function returns a \var{PCRE_Type} object representing + * the compiled patterned. If compilation fails, an error will be thrown. + *\seealso{pcre_exec, pcre_nth_match, pcre_nth_substr} + *%- + */ + MAKE_INTRINSIC_0("pcre_exec", _pcre_exec, I), +/*%+ + *\function{pcre_exec} + *\synopsis{Match a string against a compiled PCRE pattern} + *\usage{Int_Type pcre_exec(p, str [,pos [,options]]); + *#v+ + * PCRE_Type p; + * String_Type str; + * Int_Type pos, options; + *#v- + *\description + * The \var{pcre_exec} function applies a pre-compiled pattern \var{p} to a + * string \var{str} and returns the result of the match. The optional third + * argument \var{pos} may be used to specify the point, as an offset from the + * start of the string, where matching is to start. The fourth argument, if + * present, may be used to provide additional information about how matching + * is to take place. Its value may be specified as a logical-or of zero or + * more of the following flags: + *#v+ + * PCRE_NOTBOL + * The first character in the string is not at the beginning of a line. + * PCRE_NOTEOL + * The last character in the string is not at the end of a line. + * PCRE_NOTEMPTY + * An empty string is not a valid match. + *#v- + * See the PCRE library documentation for more information about the meaning + * of these flags. + * + * Upon success, this function returns a positive integer equal to 1 plus the + * number of so-called captured substrings. It returns 0 if the pattern + * fails to match the string. + *\seealso{pcre_compile, pcre_nth_match, pcre_nth_substr} + *%- + */ + MAKE_INTRINSIC_2("pcre_nth_match", _pcre_nth_match, V, P, I), +/*%+ + *\function{pcre_nth_match} + *\synopsis{Return the location of the nth match of a PCRE} + *\usage{Int_Type[2] pcre_nth_match (PCRE_Type p, Int_Type nth)} + *\description + * The \var{pcre_nth_match} function returns an integer array whose values + * specify the locations of the beginning and end of the \var{nth} captured + * substrings of the most recent call to \var{pcre_exec} with the compiled + * pattern. A value of \var{nth} equal to 0 represents the substring + * representing the entire match of the pattern. + * + * If the \var{nth} match did not take place, the function returns \var{NULL}. + *\example + * After the execution of: + *#v+ + * str = "Error in file foo.c, line 127, column 10"; + * pattern = "file ([^,]+), line (\\d+)"; + * p = pcre_compile (pattern); + * if (pcre_exec (p, str)) + * { + * match_pos = pcre_nth_match (p, 0); + * file_pos = pcre_nth_match (p, 1); + * line_pos = pcre_nth_match (p, 2); + * } + *#v- + * \exmp{match_pos} will be set to \exmp{[9,29]}, \exmp{file_pos} to \exmp{[14,19,]} + * and \exmp{line_pos} to \exmp{[26,29]}. These integer arrays may be used to + * extract the substrings matched by the pattern, e.g., + *#v+ + * file = substr (str, file_pos[0]+1, file_pos[1]-file_pos[0]); + *#v- + * Alternatively, the function \var{pcre_nth_substr} may be used to get the + * matched substrings: + *#v+ + * file = pcre_nth_substr (p, str, 0); + *#v- + *\seealso{pcre_compile, pcre_exec, pcre_nth_substr} + *%- + */ + MAKE_INTRINSIC_3("pcre_nth_substr", _pcre_nth_substr, V, P, S, I), +/*%+ + *\function{pcre_nth_substr} + *\synopsis{Extract the nth substring from a PCRE match} + *\usage{String_Type pcre_nth_substr (PCRE_Type p, String_Type str, Int_Type nth)} + *\description + * This function may be used to extract the \var{nth} captured substring + * resulting from the most recent use of the compiled pattern \var{p} by the + * \var{pcre_exec} function. Unlike \var{pcre_nth_match}, this function returns + * the specified captured substring itself and not the position of the substring. + * For this reason, the subject string of the pattern is a required argument. + *\seealso{pcre_compile, pcre_exec, pcre_nth_match} + *%- + */ + MAKE_INTRINSIC_1("slang_to_pcre", slang_to_pcre, V, S), +/*%+ + *\function{slang_to_pcre} + *\synopsis{Convert a S-Lang regular expression to a PCRE one} + *\usage{String_Type slang_to_pcre (String_Type pattern)} + *\description + * This function may be used to convert a slang regular expression to a PCRE + * compatible one. The converted is returned. + *\seealso{pcre_compile, string_match} + *%- + */ + SLANG_END_INTRIN_FUN_TABLE +}; + +static SLang_IConstant_Type PCRE_Consts [] = +{ + /* compile options */ + MAKE_ICONSTANT("PCRE_ANCHORED", PCRE_ANCHORED), + MAKE_ICONSTANT("PCRE_CASELESS", PCRE_CASELESS), + MAKE_ICONSTANT("PCRE_DOLLAR_ENDONLY", PCRE_DOLLAR_ENDONLY), + MAKE_ICONSTANT("PCRE_DOTALL", PCRE_DOTALL), + MAKE_ICONSTANT("PCRE_EXTENDED", PCRE_EXTENDED), + MAKE_ICONSTANT("PCRE_EXTRA", PCRE_EXTRA), + MAKE_ICONSTANT("PCRE_MULTILINE", PCRE_MULTILINE), + MAKE_ICONSTANT("PCRE_UNGREEDY", PCRE_UNGREEDY), + MAKE_ICONSTANT("PCRE_UTF8", PCRE_UTF8), + + /* exec options */ + MAKE_ICONSTANT("PCRE_NOTBOL", PCRE_NOTBOL), + MAKE_ICONSTANT("PCRE_NOTEOL", PCRE_NOTEOL), + MAKE_ICONSTANT("PCRE_NOTEMPTY", PCRE_NOTEMPTY), + SLANG_END_ICONST_TABLE +}; + +#undef P +#undef I +#undef V +#undef S + +static void patchup_intrinsic_table (SLang_Intrin_Fun_Type *table, + unsigned char dummy, unsigned char type) +{ + while (table->name != NULL) + { + unsigned int i, nargs; + unsigned char *args; + + nargs = table->num_args; + args = table->arg_types; + for (i = 0; i < nargs; i++) + { + if (args[i] == dummy) + args[i] = type; + } + + /* For completeness */ + if (table->return_type == dummy) + table->return_type = type; + + table++; + } +} + + +static int register_pcre_type (void) +{ + SLang_Class_Type *cl; + + if (NULL == (cl = SLclass_allocate_class ("PCRE_Type"))) + return -1; + + if (-1 == SLclass_set_destroy_function (cl, destroy_pcre)) + return -1; + + /* By registering as SLANG_VOID_TYPE, slang will dynamically allocate a + * type. + */ + if (-1 == SLclass_register_class (cl, SLANG_VOID_TYPE, sizeof (PCRE_Type), SLANG_CLASS_TYPE_MMT)) + return -1; + + PCRE_Type_Id = SLclass_get_class_id (cl); + patchup_intrinsic_table (PCRE_Intrinsics, DUMMY_PCRE_TYPE, PCRE_Type_Id); + + return 0; +} + +static void *do_malloc (size_t n) +{ + return (void *) SLmalloc (n); +} + +static void do_free (void *x) +{ + SLfree ((char *) x); +} + +int init_pcre_module_ns (char *ns_name) +{ + SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name); + if (ns == NULL) + return -1; + + if (-1 == register_pcre_type ()) + return -1; + + pcre_malloc = do_malloc; + pcre_free = do_free; + + if ((-1 == SLns_add_intrin_fun_table (ns, PCRE_Intrinsics, "__PCRE__")) + || (-1 == SLns_add_iconstant_table (ns, PCRE_Consts, NULL))) + return -1; + + return 0; +} + + +/* This function is optional */ +void deinit_pcre_module (void) +{ +} + diff --git a/libslang/modules/select-module.c b/libslang/modules/select-module.c new file mode 100644 index 0000000..f085152 --- /dev/null +++ b/libslang/modules/select-module.c @@ -0,0 +1,238 @@ +/* Copyright (c) 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include +#include + +#include +#include +#include +#include +#include + +SLANG_MODULE(select); + +static int pop_fd_set (SLang_Array_Type **ats, + fd_set **fd_set_p, fd_set *fd_set_buf, + int *max_n) +{ + unsigned int num, i; + SLang_Array_Type *at; + SLFile_FD_Type **f; + + *ats = NULL; + *fd_set_p = NULL; + + if (SLang_peek_at_stack () == SLANG_NULL_TYPE) + return SLang_pop_null (); + + if (-1 == SLang_pop_array_of_type (&at, SLANG_FILE_FD_TYPE)) + return -1; + + FD_ZERO(fd_set_buf); + *fd_set_p = fd_set_buf; + + *ats = at; + num = at->num_elements; + f = (SLFile_FD_Type **) at->data; + + for (i = 0; i < num; i++) + { + int fd; + + if (-1 == SLfile_get_fd (f[i], &fd)) + continue; + + if (fd > *max_n) + *max_n = fd; + + FD_SET(fd, fd_set_buf); + } + + return 0; +} + +static SLang_Array_Type *do_fdisset (int nready, SLang_Array_Type *fds, fd_set *fdset) +{ + SLang_Array_Type *at; + unsigned int i, num; + SLFile_FD_Type **f; + + if (fds == NULL) + nready = 0; + + if (nready) + { + nready = 0; + num = fds->num_elements; + f = (SLFile_FD_Type **) fds->data; + for (i = 0; i < num; i++) + { + int fd; + + if (-1 == SLfile_get_fd (f[i], &fd)) + continue; + + if (FD_ISSET(fd, fdset)) + nready++; + } + } + + at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &nready, 1); + if (at == NULL) + return NULL; + + if (nready) + { + int *indx = (int *) at->data; + f = (SLFile_FD_Type **) fds->data; + num = fds->num_elements; + for (i = 0; i < num; i++) + { + int fd; + + if (-1 == SLfile_get_fd (f[i], &fd)) + continue; + + if (FD_ISSET(fd, fdset)) + *indx++ = (int) i; + } + } + + return at; +} + +static int push_select_struct (int num, + SLang_Array_Type *at_read, + SLang_Array_Type *at_write, + SLang_Array_Type *at_except, + fd_set *readfs, fd_set *writefds, fd_set *exceptfds) +{ + char *field_names [4]; + unsigned char field_types[4]; + VOID_STAR field_values [4]; + SLang_Array_Type *iread, *iwrite, *iexcept; + + iread = iwrite = iexcept = NULL; + + field_names[0] = "nready"; + field_names[1] = "iread"; + field_names[2] = "iwrite"; + field_names[3] = "iexcept"; + field_types[0] = SLANG_INT_TYPE; + field_types[1] = SLANG_ARRAY_TYPE; + field_types[2] = SLANG_ARRAY_TYPE; + field_types[3] = SLANG_ARRAY_TYPE; + field_values[0] = # + + if ((NULL == (iread = do_fdisset (num, at_read, readfs))) + || (NULL == (iwrite = do_fdisset (num, at_write, writefds))) + || (NULL == (iexcept = do_fdisset (num, at_except, exceptfds)))) + { + SLang_free_array (iread); + SLang_free_array (iwrite); + return -1; + } + + field_values[1] = &iread; + field_values[2] = &iwrite; + field_values[3] = &iexcept; + + /* Note: This function call pushes the struct and frees it upon error. */ + return SLstruct_create_struct (4, field_names, field_types, field_values); +} + + +/* Usage: Struct_Type select (R[],W[],E[],TIME) */ + +static void select_intrin (double *secsp) +{ + SLang_Array_Type *at_read, *at_write, *at_except; + fd_set readfs_buf, writefds_buf, exceptfds_buf; + fd_set readfs_save_buf, writefds_save_buf, exceptfds_save_buf; + fd_set *readfs, *writefds, *exceptfds; + struct timeval tv, *tv_ptr; + double secs; + int ret, n; + + secs = *secsp; + if (secs < 0.0) tv_ptr = NULL; + else + { + tv.tv_sec = (unsigned long) secs; + tv.tv_usec = (unsigned long) ((secs - tv.tv_sec) * 1e6); + tv_ptr = &tv; + } + + n = 0; + if (-1 == pop_fd_set (&at_except, &exceptfds, &exceptfds_buf, &n)) + return; + if (-1 == pop_fd_set (&at_write, &writefds, &writefds_buf, &n)) + { + SLang_free_array (at_except); + return; + } + if (-1 == pop_fd_set (&at_read, &readfs, &readfs_buf, &n)) + goto free_return; + + readfs_save_buf = readfs_buf; + writefds_save_buf = writefds_buf; + exceptfds_save_buf = exceptfds_buf; + + n += 1; + while (-1 == (ret = select (n, readfs, writefds, exceptfds, tv_ptr))) + { +#ifdef EINTR + if (errno == EINTR) + { + readfs_buf = readfs_save_buf; + writefds_buf = writefds_save_buf; + exceptfds_buf = exceptfds_save_buf; + continue; + } +#endif + (void) SLerrno_set_errno (errno); + break; + } + + if (ret == -1) + (void) SLang_push_null (); + else + (void) push_select_struct (ret, at_read, at_write, at_except, + readfs, writefds, exceptfds); + + + free_return: + SLang_free_array (at_read); + SLang_free_array (at_write); + SLang_free_array (at_except); +} + +static SLang_Intrin_Fun_Type Select_Intrinsics [] = +{ + MAKE_INTRINSIC_1("select", select_intrin, SLANG_VOID_TYPE, SLANG_DOUBLE_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + + +int init_select_module_ns (char *ns_name) +{ + SLang_NameSpace_Type *ns; + + ns = SLns_create_namespace (ns_name); + if (ns == NULL) + return -1; + + if (-1 == SLns_add_intrin_fun_table (ns, Select_Intrinsics, "__SELECT__")) + return -1; + + return 0; +} + +/* This function is optional */ +void deinit_select_module (void) +{ +} diff --git a/libslang/modules/smg-module.c b/libslang/modules/smg-module.c new file mode 100644 index 0000000..12a1d90 --- /dev/null +++ b/libslang/modules/smg-module.c @@ -0,0 +1,324 @@ +/* This module implements and interface to the SLang SMG routines */ +#include +#include + +SLANG_MODULE(smg); + +/* If this is +1, the then it is ok to call the SLsmg routines. If it is + * 0, then only SLsmg_init_smg may be called. If it is -1, then SLsmg is + * suspended and one must call SLsmg_resume_smg. + */ + +static int Smg_Initialized; + +static void smg_write_to_status_line (char *s) +{ + if (Smg_Initialized <= 0) + return; + + (void) SLtt_write_to_status_line (s, 0); +} + + +static void smg_suspend_smg (void) +{ + if (Smg_Initialized <= 0) + return; + + (void) SLsmg_suspend_smg (); + Smg_Initialized = -1; +} + +static void smg_resume_smg (void) +{ + if (Smg_Initialized != -1) + return; + + (void) SLsmg_resume_smg (); + Smg_Initialized = 1; +} + +static void smg_erase_eol (void) +{ + if (Smg_Initialized <= 0) + return; + SLsmg_erase_eol (); +} + +static void smg_gotorc (int *r, int *c) +{ + if (Smg_Initialized <= 0) + return; + SLsmg_gotorc (*r, *c); +} + +static void smg_erase_eos (void) +{ + if (Smg_Initialized <= 0) + return; + SLsmg_erase_eos (); +} + +static void smg_reverse_video (void) +{ + if (Smg_Initialized <= 0) + return; + SLsmg_reverse_video (); +} + +static void smg_set_color (int *c) +{ + if (Smg_Initialized <= 0) + return; + SLsmg_set_color (*c); +} + +static void smg_normal_video (void) +{ + if (Smg_Initialized <= 0) + return; + SLsmg_normal_video (); +} + +static void smg_write_string (char *s) +{ + if (Smg_Initialized <= 0) + return; + SLsmg_write_string (s); +} + +static void smg_write_nstring (char *s, int *len) +{ + if ((Smg_Initialized <= 0) + || (*len < 0)) + return; + + SLsmg_write_nstring (s, (unsigned int) *len); +} + +static void smg_write_wrapped_string (char *s, int *r, int *c, int *dr, int *dc, + int *fill) +{ + if (Smg_Initialized <= 0) + return; + + SLsmg_write_wrapped_string (s, *r, *c, *dr, *dc, *fill); +} + +static int smg_char_at (void) +{ + if (Smg_Initialized <= 0) return -1; + return (int) SLsmg_char_at (); +} + +static void smg_set_screen_start (int *rp, int *cp) +{ + int r, c; + + if (Smg_Initialized <= 0) return; + r = *rp; + c = *cp; + SLsmg_set_screen_start (&r, &c); +} + +static void smg_draw_hline (int *dn) +{ + if (Smg_Initialized <= 0) + return; + + SLsmg_draw_hline (*dn); +} + +static void smg_draw_vline (int *dn) +{ + if (Smg_Initialized <= 0) + return; + + SLsmg_draw_vline (*dn); +} + +static void smg_draw_object (int *r, int *c, int *obj) +{ + if (Smg_Initialized <= 0) return; + SLsmg_draw_object (*r, *c, *obj); +} + +static void smg_draw_box (int *r, int *c,int *dr, int *dc) +{ + if (Smg_Initialized <= 0) return; + SLsmg_draw_box (*r, *c, *dr, *dc); +} + +static int smg_get_column (void) +{ + if (Smg_Initialized <= 0) return -1; + return SLsmg_get_column(); +} + +static int smg_get_row (void) +{ + if (Smg_Initialized <= 0) return -1; + return SLsmg_get_row(); +} + +static void smg_forward (int *n) +{ + if (Smg_Initialized <= 0) return; + SLsmg_forward (*n); +} + +static void smg_set_color_in_region (int *color, int *r, int *c, int *dr, int *dc) +{ + if (Smg_Initialized <= 0) return; + SLsmg_set_color_in_region (*color, *r, *c, *dr, *dc); +} + + +static void smg_cls (void) +{ + if (Smg_Initialized <= 0) + return; + SLsmg_cls (); +} + +static void smg_refresh (void) +{ + if (Smg_Initialized <= 0) + return; + SLsig_block_signals (); + SLsmg_refresh (); + SLsig_unblock_signals (); +} + +static void smg_reset_smg (void) +{ + if (Smg_Initialized <= 0) + return; + SLsig_block_signals (); + SLsmg_reset_smg (); + SLsig_unblock_signals (); + Smg_Initialized = 0; +} + +static void smg_init_smg (void) +{ + if (Smg_Initialized != 0) + return; + SLsig_block_signals (); + (void) SLsmg_init_smg (); + SLsig_unblock_signals (); + Smg_Initialized = 1; +} + +static void smg_define_color (int *obj, char *fg, char *bg) +{ + SLtt_set_color (*obj, NULL, fg, bg); +} + +#define I SLANG_INT_TYPE +#define S SLANG_STRING_TYPE +static SLang_Intrin_Fun_Type Smg_Intrinsics [] = +{ + MAKE_INTRINSIC_0("smg_suspend_smg", smg_suspend_smg, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("smg_resume_smg", smg_resume_smg, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("smg_erase_eol", smg_erase_eol, SLANG_VOID_TYPE), + MAKE_INTRINSIC_II("smg_gotorc", smg_gotorc, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("smg_erase_eos", smg_erase_eos, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("smg_reverse_video", smg_reverse_video, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("smg_set_color", smg_set_color, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("smg_normal_video", smg_normal_video, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("smg_write_string", smg_write_string, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("smg_cls", smg_cls, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("smg_refresh", smg_refresh, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("smg_reset_smg", smg_reset_smg, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("smg_init_smg", smg_init_smg, SLANG_VOID_TYPE), + + MAKE_INTRINSIC_SI("smg_write_nstring", smg_write_nstring, SLANG_VOID_TYPE), + MAKE_INTRINSIC_6("smg_write_wrapped_string", smg_write_wrapped_string, SLANG_VOID_TYPE, S,I,I,I,I,I), + MAKE_INTRINSIC_0("smg_char_at", smg_char_at, SLANG_INT_TYPE), + MAKE_INTRINSIC_II("smg_set_screen_start", smg_set_screen_start, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("smg_draw_hline", smg_draw_hline, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("smg_draw_vline", smg_draw_vline, SLANG_VOID_TYPE), + MAKE_INTRINSIC_III("smg_draw_object", smg_draw_object, SLANG_VOID_TYPE), + MAKE_INTRINSIC_4("smg_draw_box", smg_draw_box, SLANG_VOID_TYPE,I,I,I,I), + MAKE_INTRINSIC_0("smg_get_column", smg_get_column, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("smg_get_row", smg_get_row, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("smg_forward", smg_forward, SLANG_VOID_TYPE), + MAKE_INTRINSIC_5("smg_set_color_in_region", smg_set_color_in_region, SLANG_VOID_TYPE, I, I, I, I, I), + + MAKE_INTRINSIC_ISS("smg_define_color", smg_define_color, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("smg_write_to_status_line", smg_write_to_status_line, SLANG_VOID_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +static SLang_Intrin_Var_Type Smg_Variables [] = +{ + MAKE_VARIABLE("Smg_Display_Eight_Bit", &SLsmg_Display_Eight_Bit, I, 0), + MAKE_VARIABLE("Smg_Tab_Width", &SLsmg_Tab_Width, I, 0), + MAKE_VARIABLE("Smg_Newline_Behavior", &SLsmg_Newline_Behavior, I, 0), + MAKE_VARIABLE("Smg_Backspace_Moves", &SLsmg_Backspace_Moves, I, 0), + MAKE_VARIABLE("Smg_Screen_Rows", &SLtt_Screen_Rows, I, 1), + MAKE_VARIABLE("Smg_Screen_Cols", &SLtt_Screen_Cols, I, 1), + SLANG_END_INTRIN_VAR_TABLE +}; + +static SLang_IConstant_Type Smg_Constants [] = +{ + MAKE_ICONSTANT("SMG_NEWLINE_IGNORED", SLSMG_NEWLINE_IGNORED), + MAKE_ICONSTANT("SMG_NEWLINE_MOVES", SLSMG_NEWLINE_MOVES), + MAKE_ICONSTANT("SMG_NEWLINE_SCROLLS", SLSMG_NEWLINE_SCROLLS), + MAKE_ICONSTANT("SMG_NEWLINE_PRINTABLE", SLSMG_NEWLINE_PRINTABLE), + + MAKE_ICONSTANT("SMG_HLINE_CHAR", SLSMG_HLINE_CHAR), + MAKE_ICONSTANT("SMG_VLINE_CHAR", SLSMG_VLINE_CHAR), + MAKE_ICONSTANT("SMG_ULCORN_CHAR", SLSMG_ULCORN_CHAR), + MAKE_ICONSTANT("SMG_URCORN_CHAR", SLSMG_URCORN_CHAR), + MAKE_ICONSTANT("SMG_LLCORN_CHAR", SLSMG_LLCORN_CHAR), + MAKE_ICONSTANT("SMG_LRCORN_CHAR", SLSMG_LRCORN_CHAR), + MAKE_ICONSTANT("SMG_CKBRD_CHAR", SLSMG_CKBRD_CHAR), + MAKE_ICONSTANT("SMG_RTEE_CHAR", SLSMG_RTEE_CHAR), + MAKE_ICONSTANT("SMG_LTEE_CHAR", SLSMG_LTEE_CHAR), + MAKE_ICONSTANT("SMG_UTEE_CHAR", SLSMG_UTEE_CHAR), + MAKE_ICONSTANT("SMG_DTEE_CHAR", SLSMG_DTEE_CHAR), + MAKE_ICONSTANT("SMG_PLUS_CHAR", SLSMG_PLUS_CHAR), + + SLANG_END_ICONST_TABLE +}; +#undef I +#undef S + +int init_smg_module_ns (char *ns_name) +{ + SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name); + if (ns == NULL) + return -1; + + if ((-1 == SLns_add_intrin_fun_table (ns, Smg_Intrinsics, "__SMG__")) + || (-1 == SLns_add_intrin_var_table (ns, Smg_Variables, NULL)) + || (-1 == SLns_add_iconstant_table (ns, Smg_Constants, NULL))) + return -1; + + SLtt_get_terminfo (); + Smg_Initialized = 0; + return 0; +} + +#if 0 +int init_smg_module (void) +{ + if ((-1 == SLadd_intrin_fun_table (Smg_Intrinsics, "__SMG__")) + || (-1 == SLadd_intrin_var_table (Smg_Variables, NULL)) + || (-1 == SLadd_iconstant_table (Smg_Constants, NULL))) + return -1; + + SLtt_get_terminfo (); + Smg_Initialized = 0; + return 0; +} +#endif + +/* This function is optional */ +void deinit_smg_module (void) +{ + smg_reset_smg (); +} diff --git a/libslang/modules/smg.sl b/libslang/modules/smg.sl new file mode 100644 index 0000000..80f9064 --- /dev/null +++ b/libslang/modules/smg.sl @@ -0,0 +1,70 @@ +import ("smg", "Global"); % Global namespace + +static variable Button_Color = 3; +static variable Box_Color = 2; +static variable Normal_Color = 1; + +smg_define_color (Button_Color, "white", "green"); +smg_define_color (Box_Color, "yellow", "blue"); +smg_define_color (Normal_Color, "green", "red"); + +static define display_button (name, r, c) +{ + smg_gotorc (r, c); + smg_set_color (Button_Color); + smg_write_string (" " + name + " "); + smg_set_color (Normal_Color); +} + +static define draw_centered_string (s, r, c, dc) +{ + variable len; + + len = strlen (s); + smg_gotorc (r, c + (dc - len)/2); + smg_write_string (s); +} + +static define get_yes_no_cancel (question) +{ + variable r, c, dr, dc; + + dc = strlen (question) + 5; + dr = 7; + + % We also need room for the yes-no-cancel buttons + if (dc < 32) dc = 36; + + r = (Smg_Screen_Rows - dr)/2; + c = (Smg_Screen_Cols - dc)/2; + + smg_set_color (Box_Color); + smg_draw_box (r, c, dr, dc); + smg_set_color (Normal_Color); + + r += 2; + + draw_centered_string (question + "?", r, c, dc); + + r += 2; + display_button ("Yes", r, c + 4); + display_button ("No", r, c + 14); + display_button ("Cancel", r, c + 24); +} + + +smg_write_to_status_line ("smg-module demo"); +smg_init_smg (); +smg_set_color(Normal_Color); +smg_erase_eos (); +get_yes_no_cancel ("This demo will exit in 5 seconds"); + + +smg_refresh (); +sleep (5); + +smg_write_to_status_line (""); + +%smg_reset_smg (); + +exit(0); diff --git a/libslang/modules/template.c b/libslang/modules/template.c new file mode 100644 index 0000000..b0b7d60 --- /dev/null +++ b/libslang/modules/template.c @@ -0,0 +1,49 @@ +#include +#include + +SLANG_MODULE(); + +#define MODULE_MAJOR_VERSION 0 +#define MODULE_MINOR_VERSION 0 +#define MODULE_PATCH_LEVEL 0 +static char *Module_Version_String = "0.0.0"; +#define MODULE_VERSION_NUMBER \ + (MODULE_MAJOR_VERSION*10000+MODULE_MINOR_VERSION*100+MODULE_PATCH_LEVEL) + +/* Define intrinsics here */ + +static SLang_Intrin_Fun_Type Module_Intrinsics [] = +{ + SLANG_END_INTRIN_FUN_TABLE +}; + +static SLang_Intrin_Var_Type Module_Variables [] = +{ + MAKE_VARIABLE("__module_version_string", &Module_Version_String, SLANG_STRING_TYPE, 1), + SLANG_END_INTRIN_VAR_TABLE +}; + +static SLang_IConstant_Type Module_Constants [] = +{ + MAKE_ICONSTANT("__module_version", MODULE_VERSION_NUMBER), + SLANG_END_ICONST_TABLE +}; + +int init__module_ns (char *ns_name) +{ + SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name); + if (ns == NULL) + return -1; + + if ((-1 == SLns_add_intrin_fun_table (ns, Module_Intrinsics, NULL)) + || (-1 == SLns_add_intrin_var_table (ns, Module_Variables, NULL)) + || (-1 == SLns_add_iconstant_table (ns, Module_Constants, NULL))) + return -1; + + return 0; +} + +/* This function is optional */ +void deinit__module (void) +{ +} diff --git a/libslang/modules/termios-module.c b/libslang/modules/termios-module.c new file mode 100644 index 0000000..e853be9 --- /dev/null +++ b/libslang/modules/termios-module.c @@ -0,0 +1,440 @@ +/* Copyright (c) 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include +#include + +#include +#include +#include +#include + +SLANG_MODULE(termios); + +static int Termios_Type_Id; + +static int check_and_set_errno (int e) +{ +#ifdef EINTR + if (e == EINTR) + return 0; +#endif + (void) SLerrno_set_errno (e); + return -1; +} + +static int do_syscall_0 (int (*fun)(int), SLFile_FD_Type *f) +{ + int fd; + int ret; + + if (-1 == SLfile_get_fd (f, &fd)) + return -1; + + while ((-1 == (ret = (*fun) (fd))) + && (0 == check_and_set_errno (errno))) + ; + + return ret; +} + +static int do_syscall_1 (int (*fun)(int, int), SLFile_FD_Type *f, int arg) +{ + int fd; + int ret; + + if (-1 == SLfile_get_fd (f, &fd)) + return -1; + + while ((-1 == (ret = (*fun) (fd, arg))) + && (0 == check_and_set_errno (errno))) + ; + + return ret; +} + +static int do_syscall_struct_1 (int (*fun)(int, void *), SLFile_FD_Type *f, void *v) +{ + int fd; + int ret; + + if (-1 == SLfile_get_fd (f, &fd)) + return -1; + + while ((-1 == (ret = (*fun) (fd, v))) + && (0 == check_and_set_errno (errno))) + ; + + return ret; +} + +static int do_syscall_struct_2 (int (*fun)(int, int, void *), SLFile_FD_Type *f, int i, void *v) +{ + int fd; + int ret; + + if (-1 == SLfile_get_fd (f, &fd)) + return -1; + + while ((-1 == (ret = (*fun) (fd, i, v))) + && (0 == check_and_set_errno (errno))) + ; + + return ret; +} + +#define DO_SYSCALL_0(fun, f) do_syscall_0((int(*)(int))(fun),(f)) +#define DO_SYSCALL_1(fun, f, i) do_syscall_1((int(*)(int,int))(fun),(f),(i)) +#define DO_SYSCALL_STRUCT_1(fun, f, s) \ + do_syscall_struct_1((int(*)(int, void*))(fun), (f), (void*)(s)) +#define DO_SYSCALL_STRUCT_2(fun, f, i, s) \ + do_syscall_struct_2((int(*)(int, int, void*))(fun), (f), (i), (void*)(s)) + + +static int tcdrain_intrin (SLFile_FD_Type *f) +{ + return DO_SYSCALL_0 (tcdrain, f); +} + +static int tcflow_intrin (SLFile_FD_Type *f, int *action) +{ + return DO_SYSCALL_1 (tcflow, f, *action); +} + +static int tcflush_intrin (SLFile_FD_Type *f, int *action) +{ + return DO_SYSCALL_1 (tcflush, f, *action); +} + +static int tcgetpgrp_intrin (SLFile_FD_Type *f) +{ + return DO_SYSCALL_0 (tcgetpgrp, f); +} + +static int tcsetpgrp_intrin (SLFile_FD_Type *f, int *id) +{ + return DO_SYSCALL_1 (tcgetpgrp, f, *id); +} + +static int tcsendbreak_intrin (SLFile_FD_Type *f, int *action) +{ + return DO_SYSCALL_1 (tcsendbreak, f, *action); +} + +static void destroy_termios (unsigned char type, VOID_STAR f) +{ + (void) type; + SLfree ((char *) f); +} + +static SLang_MMT_Type *allocate_termios (struct termios *s) +{ + struct termios *s1; + SLang_MMT_Type *mmt; + + s1 = (struct termios *) SLmalloc (sizeof (struct termios)); + if (s1 == NULL) + return NULL; + + memcpy (s1, s, sizeof (struct termios)); + if (NULL == (mmt = SLang_create_mmt (Termios_Type_Id, (VOID_STAR) s1))) + SLfree ((char *) s1); + return mmt; +} + +static void tcgetattr_intrin (SLFile_FD_Type *f) +{ + struct termios s; + SLang_MMT_Type *mmt; + + if (-1 == DO_SYSCALL_STRUCT_1(tcgetattr,f,&s)) + { + SLang_push_null (); + return; + } + + mmt = allocate_termios (&s); /* NULL ok */ + if (-1 == SLang_push_mmt (mmt)) + SLang_free_mmt (mmt); +} + +static int tcsetattr_intrin (SLFile_FD_Type *f, int *when, struct termios *s) +{ + return DO_SYSCALL_STRUCT_2(tcsetattr,f,*when,s); +} + +static int termios_get_oflag (struct termios *s) +{ + return s->c_oflag; +} +static int termios_get_iflag (struct termios *s) +{ + return s->c_iflag; +} +static int termios_get_cflag (struct termios *s) +{ + return s->c_cflag; +} +static int termios_get_lflag (struct termios *s) +{ + return s->c_lflag; +} + +static void termios_get_cc (struct termios *s) +{ + SLang_Array_Type *at; + int dims = NCCS; + int i; + unsigned char *at_data; + + at = SLang_create_array (SLANG_UCHAR_TYPE, 0, NULL, &dims, 1); + if (at == NULL) + return; + at_data = (unsigned char *) at->data; + + for (i = 0; i < NCCS; i++) + at_data[i] = (unsigned char) s->c_cc[i]; + + (void) SLang_push_array (at, 1); +} + + +static void termios_set_oflag (struct termios *s, int *flag) +{ + s->c_oflag = *flag; +} +static void termios_set_iflag (struct termios *s, int *flag) +{ + s->c_iflag = *flag; +} +static void termios_set_cflag (struct termios *s, int *flag) +{ + s->c_cflag = *flag; +} +static void termios_set_lflag (struct termios *s, int *flag) +{ + s->c_lflag = *flag; +} + +static void termios_set_cc (void) +{ + SLang_Array_Type *at; + SLang_MMT_Type *mmt; + struct termios *s; + unsigned char *at_data; + int i; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE)) + return; + if (NULL == (mmt = SLang_pop_mmt (Termios_Type_Id))) + goto free_and_return; + + s = SLang_object_from_mmt (mmt); + if (at->num_elements != NCCS) + { + SLang_verror (SL_TYPE_MISMATCH, + "Expecting UChar_Type[%d]", NCCS); + goto free_and_return; + } + + at_data = (unsigned char *) at->data; + for (i = 0; i < NCCS; i++) + s->c_cc[i] = at_data[i]; + + /* drop */ + + free_and_return: + SLang_free_array (at); + SLang_free_mmt (mmt); +} + + +static int termios_dereference (unsigned char type, VOID_STAR addr) +{ + struct termios *s; + SLang_MMT_Type *mmt; + + (void) type; + mmt = *(SLang_MMT_Type **) addr; + if (NULL == (s = SLang_object_from_mmt (mmt))) + return -1; + + mmt = allocate_termios (s); + if (-1 == SLang_push_mmt (mmt)) + { + SLang_free_mmt (mmt); + return -1; + } + + return 0; +} + + +#define DUMMY_TERMIOS_TYPE 255 +#define T DUMMY_TERMIOS_TYPE +#define F SLANG_FILE_FD_TYPE +#define I SLANG_INT_TYPE +#define V SLANG_VOID_TYPE +static SLang_Intrin_Fun_Type Termios_Intrinsics [] = +{ + MAKE_INTRINSIC_1("tcdrain", tcdrain_intrin, I, F), + MAKE_INTRINSIC_2("tcflow", tcflow_intrin, I, F, I), + MAKE_INTRINSIC_2("tcflush", tcflush_intrin, I, F, I), + MAKE_INTRINSIC_1("tcgetpgrp", tcgetpgrp_intrin, I, F), + MAKE_INTRINSIC_2("tcsetpgrp", tcsetpgrp_intrin, I, F, I), + MAKE_INTRINSIC_2("tcsendbreak", tcsendbreak_intrin, I, F, I), + MAKE_INTRINSIC_1("tcgetattr", tcgetattr_intrin, V, F), + MAKE_INTRINSIC_3("tcsetattr", tcsetattr_intrin, I, F, I, T), + MAKE_INTRINSIC_1("termios_get_oflag", termios_get_oflag, I, T), + MAKE_INTRINSIC_1("termios_get_iflag", termios_get_iflag, I, T), + MAKE_INTRINSIC_1("termios_get_cflag", termios_get_cflag, I, T), + MAKE_INTRINSIC_1("termios_get_lflag", termios_get_lflag, I, T), + MAKE_INTRINSIC_1("termios_get_cc", termios_get_cc, V, T), + MAKE_INTRINSIC_2("termios_set_oflag", termios_set_oflag, V, T, I), + MAKE_INTRINSIC_2("termios_set_iflag", termios_set_iflag, V, T, I), + MAKE_INTRINSIC_2("termios_set_cflag", termios_set_cflag, V, T, I), + MAKE_INTRINSIC_2("termios_set_lflag", termios_set_lflag, V, T, I), + MAKE_INTRINSIC_0("termios_set_cc", termios_set_cc, V), + + SLANG_END_INTRIN_FUN_TABLE +}; +#undef T +#undef I +#undef F +#undef V + +static SLang_IConstant_Type Termios_Consts [] = +{ + MAKE_ICONSTANT("TCOOFF", TCOOFF), + MAKE_ICONSTANT("TCOON", TCOON), + MAKE_ICONSTANT("TCIOFF", TCIOFF), + MAKE_ICONSTANT("TCION", TCION), + MAKE_ICONSTANT("TCIFLUSH", TCIFLUSH), + MAKE_ICONSTANT("TCOFLUSH", TCOFLUSH), + MAKE_ICONSTANT("TCIOFLUSH", TCIOFLUSH), + MAKE_ICONSTANT("TCSANOW", TCSANOW), + MAKE_ICONSTANT("TCSADRAIN", TCSADRAIN), + MAKE_ICONSTANT("TCSAFLUSH", TCSAFLUSH), + MAKE_ICONSTANT("BRKINT", BRKINT), + MAKE_ICONSTANT("IGNBRK", IGNBRK), + MAKE_ICONSTANT("IGNPAR", IGNPAR), + MAKE_ICONSTANT("PARMRK", PARMRK), + MAKE_ICONSTANT("INPCK", INPCK), + MAKE_ICONSTANT("ISTRIP", ISTRIP), + MAKE_ICONSTANT("INLCR", INLCR), + MAKE_ICONSTANT("IGNCR", IGNCR), + MAKE_ICONSTANT("ICRNL", ICRNL), + MAKE_ICONSTANT("IXON", IXON), + MAKE_ICONSTANT("IXOFF", IXOFF), + MAKE_ICONSTANT("CLOCAL", CLOCAL), + MAKE_ICONSTANT("CREAD", CREAD), + MAKE_ICONSTANT("CSIZE", CSIZE), + MAKE_ICONSTANT("CSTOPB", CSTOPB), + MAKE_ICONSTANT("HUPCL", HUPCL), + MAKE_ICONSTANT("PARENB", PARENB), + MAKE_ICONSTANT("PARODD", PARODD), + MAKE_ICONSTANT("ECHO", ECHO), + MAKE_ICONSTANT("ECHOE", ECHOE), + MAKE_ICONSTANT("ECHOK", ECHOK), + MAKE_ICONSTANT("ECHONL", ECHONL), + MAKE_ICONSTANT("ICANON", ICANON), + MAKE_ICONSTANT("ISIG", ISIG), + MAKE_ICONSTANT("NOFLSH", NOFLSH), + MAKE_ICONSTANT("TOSTOP", TOSTOP), + MAKE_ICONSTANT("IEXTEN", IEXTEN), + MAKE_ICONSTANT("VEOF", VEOF), + MAKE_ICONSTANT("VEOL", VEOL), + MAKE_ICONSTANT("VERASE", VERASE), + MAKE_ICONSTANT("VINTR", VINTR), + MAKE_ICONSTANT("VKILL", VKILL), + MAKE_ICONSTANT("VQUIT", VQUIT), + MAKE_ICONSTANT("VSUSP", VSUSP), + MAKE_ICONSTANT("VSTART", VSTART), + MAKE_ICONSTANT("VSTOP", VSTOP), +#ifdef ultrix /* Ultrix gets _POSIX_VDISABLE wrong! */ +# define NULL_VALUE -1 +#else +# ifdef _POSIX_VDISABLE +# define NULL_VALUE _POSIX_VDISABLE +# else +# define NULL_VALUE 255 +# endif +#endif + MAKE_ICONSTANT("VDISABLE", NULL_VALUE), + + SLANG_END_ICONST_TABLE +}; + +static void patchup_intrinsic_table (SLang_Intrin_Fun_Type *table, + unsigned char dummy, unsigned char type) +{ + while (table->name != NULL) + { + unsigned int i, nargs; + unsigned char *args; + + nargs = table->num_args; + args = table->arg_types; + for (i = 0; i < nargs; i++) + { + if (args[i] == dummy) + args[i] = type; + } + + /* For completeness */ + if (table->return_type == dummy) + table->return_type = type; + + table++; + } +} + + +static int register_termios_type (void) +{ + SLang_Class_Type *cl; + + if (NULL == (cl = SLclass_allocate_class ("Termios_Type"))) + return -1; + + if (-1 == SLclass_set_destroy_function (cl, destroy_termios)) + return -1; + cl->cl_dereference = termios_dereference; + + /* By registering as SLANG_VOID_TYPE, slang will dynamically allocate a + * type. + */ + if (-1 == SLclass_register_class (cl, SLANG_VOID_TYPE, sizeof (struct termios), SLANG_CLASS_TYPE_MMT)) + return -1; + + Termios_Type_Id = SLclass_get_class_id (cl); + patchup_intrinsic_table (Termios_Intrinsics, DUMMY_TERMIOS_TYPE, Termios_Type_Id); + + return 0; +} + +int init_termios_module_ns (char *ns_name) +{ + SLang_NameSpace_Type *ns; + + ns = SLns_create_namespace (ns_name); + if (ns == NULL) + return -1; + + if (-1 == register_termios_type ()) + return -1; + + if ((-1 == SLns_add_intrin_fun_table (ns, Termios_Intrinsics, "__TERMIOS__")) + || (-1 == SLns_add_iconstant_table (ns, Termios_Consts, NULL))) + return -1; + + return 0; +} + +/* This function is optional */ +void deinit_termios_module (void) +{ +} diff --git a/libslang/modules/varray-module.c b/libslang/modules/varray-module.c new file mode 100644 index 0000000..d9caf3a --- /dev/null +++ b/libslang/modules/varray-module.c @@ -0,0 +1,224 @@ +#include +#include +#include + +#include +#include +#include + +#ifndef MAP_FAILED +# define MAP_FAILED -1 +#endif + +SLANG_MODULE(varray); + +typedef struct +{ + unsigned long size_mmapped; + VOID_STAR addr; + VOID_STAR data; +} +MMap_Type; + +static void free_mmap_type (MMap_Type *m) +{ + if (m == NULL) + return; + if (m->addr != NULL) + (void) munmap ((char *) m->addr, m->size_mmapped); + SLfree ((char *)m); +} + +static void unmmap_array (SLang_Array_Type *at) +{ + if (at->client_data != NULL) + free_mmap_type ((MMap_Type *) at->client_data); + + at->data = NULL; + at->client_data = NULL; +} + + +static MMap_Type *mmap_file (char *file, unsigned int offset, + unsigned long num_bytes) +{ + FILE *fp; + int fd; + struct stat st; + VOID_STAR addr; + MMap_Type *m; + + fp = fopen (file, "rb"); + if (fp == NULL) + { + SLang_verror (SL_OBJ_NOPEN, "mmap_array: unable to open %s for reading", file); + return NULL; + } + fd = fileno (fp); + + if (-1 == fstat (fd, &st)) + { + SLang_verror (SL_INTRINSIC_ERROR, "mmap_array: stat %s failed", file); + fclose (fp); + return NULL; + } + + if (NULL == (m = (MMap_Type *) SLmalloc (sizeof (MMap_Type)))) + { + fclose (fp); + return NULL; + } + + m->size_mmapped = num_bytes + offset; + addr = (VOID_STAR)mmap (NULL, m->size_mmapped, PROT_READ, MAP_SHARED, fd, 0); + if (addr == (VOID_STAR)MAP_FAILED) + { + SLang_verror (SL_INTRINSIC_ERROR, "mmap_array: mmap %s failed", file); + SLfree ((char *) m); + fclose (fp); + return NULL; + } + m->addr = addr; + m->data = (VOID_STAR) ((char *)addr + offset); + + fclose (fp); + + return m; +} + +/* usage: + * a = mmap_array (file, offset, type, [dims]); + */ +static void mmap_array (void) +{ + SLang_Array_Type *a, *a_dims; + char *file; + unsigned char type; + int *dims; + unsigned int num_dims; + unsigned int i; + unsigned int num_elements; + unsigned int offset; + unsigned int sizeof_type; + unsigned long num_bytes; + MMap_Type *m; + VOID_STAR data; + + a_dims = NULL; + file = NULL; + data = NULL; + + if (-1 == SLang_pop_array_of_type (&a_dims, SLANG_INT_TYPE)) + return; + + num_dims = a_dims->num_elements; + dims = (int *)a_dims->data; + + if (-1 == SLang_pop_datatype (&type)) + goto return_error; + + switch (type) + { + case SLANG_CHAR_TYPE: + case SLANG_UCHAR_TYPE: + sizeof_type = 1; + break; + + case SLANG_SHORT_TYPE: + case SLANG_USHORT_TYPE: + sizeof_type = sizeof(short); + break; + + case SLANG_INT_TYPE: + case SLANG_UINT_TYPE: + sizeof_type = sizeof (int); + break; + + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: + sizeof_type = sizeof (long); + break; + + case SLANG_FLOAT_TYPE: + sizeof_type = sizeof (float); + break; + + case SLANG_DOUBLE_TYPE: + sizeof_type = sizeof (double); + break; + + case SLANG_COMPLEX_TYPE: + sizeof_type = 2 * sizeof (double); + break; + + default: + SLang_verror (SL_NOT_IMPLEMENTED, "mmap_array: unsupported data type"); + goto return_error; + } + + num_elements = 1; + for (i = 0; i < num_dims; i++) + { + if (dims[i] < 0) + { + SLang_verror (SL_USER_ERROR, "mmap_array: dims array must be positive"); + goto return_error; + } + + num_elements *= dims[i]; + } + if (num_dims == 0) + num_elements = 0; + + num_bytes = (unsigned long) sizeof_type * (unsigned long) num_elements; + + if (-1 == SLang_pop_uinteger (&offset)) + goto return_error; + + if (-1 == SLang_pop_slstring (&file)) + goto return_error; + + if (NULL == (m = mmap_file (file, offset, num_bytes))) + goto return_error; + + if (NULL == (a = SLang_create_array (type, 1, m->data, dims, num_dims))) + goto return_error; + + a->free_fun = unmmap_array; + a->client_data = (VOID_STAR) m; + + m = NULL; /* done with this */ + + (void) SLang_push_array (a, 1); + + /* drop */ + + return_error: + if (m != NULL) + free_mmap_type (m); + if (a_dims != NULL) + SLang_free_array (a_dims); + if (file != NULL) + SLang_free_slstring (file); +} + +static SLang_Intrin_Fun_Type Module_Intrinsics [] = +{ + MAKE_INTRINSIC_0("mmap_array", mmap_array, SLANG_VOID_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + + +int init_varray_module_ns (char *ns_name) +{ + SLang_NameSpace_Type *ns; + + if (NULL == (ns = SLns_create_namespace (ns_name))) + return -1; + + if (-1 == SLns_add_intrin_fun_table (ns, Module_Intrinsics, NULL)) + return -1; + + return 0; +} + diff --git a/libslang/modules/varray.sl b/libslang/modules/varray.sl new file mode 100644 index 0000000..8b78558 --- /dev/null +++ b/libslang/modules/varray.sl @@ -0,0 +1,37 @@ +% This file shows how to use the varray-module to treat a file as an +% array of objects. +import ("varray"); + +% First of all, create an array of doubles +static variable x = [1:1000.0:1.0]; + +% and write it to disk +static variable file = "varray_example.dat"; +static variable fp = fopen (file, "wb"); +if (fp == NULL) +{ + () = fprintf (stderr, "failed to open %s\n", file); + exit (1); +} +if ((-1 == fwrite (x, fp)) + or (-1 == fclose (fp))) +{ + () = fprintf (stderr, "Failed to write x\n"); + exit (1); +} + +% Now associate an array with the file +variable y = mmap_array (file, 0, _typeof(x), length(x)); + +if (length (where (y != x))) +{ + fprintf (stderr, "mmap_array has failed\n"); + exit (1); +} + +y = 0; % remove the map + +exit (0); + + + diff --git a/libslang/slang.lis b/libslang/slang.lis new file mode 100644 index 0000000..c95d868 --- /dev/null +++ b/libslang/slang.lis @@ -0,0 +1,267 @@ +@COPYING +@COPYING.GPL +@COPYING.ART +@COPYRIGHT +@README +@NEWS +@INSTALL.unx +@INSTALL.vms +@INSTALL.pc +@UPGRADE.txt +@changes.txt +@configure 0755 +@slang.lis +@autoconf/configure.in +@autoconf/install.sh 0755 +@autoconf/mkinsdir.sh 0755 +@autoconf/Makefile.in +@autoconf/config.sub 0755 +@autoconf/config.guess 0755 +# @autoconf/acsite.m4 +@autoconf/aclocal.m4 + +@modules/Makefile.in +@modules/README +@modules/pcre-module.c +@modules/grep 0755 +@modules/newt-module.c +@modules/newt.sl +@modules/smg-module.c +@modules/smg.sl +@modules/termios-module.c +@modules/select-module.c +@modules/fcntl-module.c +@modules/varray-module.c +@modules/varray.sl +@modules/template.c + +@demo/README +@demo/pager.c +@demo/modules.unx +@demo/useropen.c +@demo/configure.in +@demo/configure 0755 +@demo/Makefile.in +@demo/keypad.c +@demo/smgtest.c +@demo/demolib.c +@demo/Makefile.w32 + +@examples/assoc.sl +@examples/sort.sl +@examples/utmp.sl +@examples/prime.sl +@examples/life.sl +@examples/saveobj.sl + +@slsh/slsh.c +@slsh/README +@slsh/INSTALL +@slsh/Makefile.in +@slsh/Makefile.g32 +@slsh/lib/slsh.rc +@slsh/lib/arrayfuns.sl +@slsh/lib/autoload.sl +@slsh/lib/require.sl +@slsh/scripts/htmlstrip 0755 +@slsh/scripts/lsrpm 0755 +@slsh/scripts/ls 0755 +@slsh/scripts/mv 0755 +@slsh/scripts/purge 0755 +@slsh/scripts/badlinks 0755 + +@doc/README +@doc/grammar.txt +@doc/text/cslang.txt +@doc/text/cref.txt +@doc/text/slang.txt +@doc/text/slangfun.txt +@doc/slangdoc.html + +@doc/tm/slangfun.tm +@doc/tm/rtl/array.tm +@doc/tm/rtl/assoc.tm +@doc/tm/rtl/bstr.tm +@doc/tm/rtl/debug.tm +@doc/tm/rtl/eval.tm +@doc/tm/rtl/import.tm +@doc/tm/rtl/info.tm +@doc/tm/rtl/math.tm +@doc/tm/rtl/message.tm +@doc/tm/rtl/misc.tm +@doc/tm/rtl/ospath.tm +@doc/tm/rtl/posix.tm +@doc/tm/rtl/posio.tm +@doc/tm/rtl/stack.tm +@doc/tm/rtl/stdio.tm +@doc/tm/rtl/strops.tm +@doc/tm/rtl/struct.tm +@doc/tm/rtl/time.tm +@doc/tm/rtl/type.tm +@doc/tm/rtl/dir.tm +@doc/tm/rtl/tm-sort.sl 0755 +@doc/tm/rtl/whatelse.sl 0755 + +@doc/tm/cref.tm +@doc/tm/cslang.tm +@doc/tm/slang.tm +@doc/tm/copyright.tm +@doc/tm/preface.tm +@doc/tm/regexp.tm +@doc/tm/fixtex.sl +@doc/tm/Makefile +@doc/tm/tools/sl2tm.c +@doc/tm/tools/tm2txt.c +@doc/tm/tools/Makefile +@doc/tm/tools/README + +#@doc/OLD/README +#@doc/OLD/cslang.tex +#@doc/OLD/object.txt +#@doc/OLD/slang.how +#@doc/OLD/cslang.tex + +@doc/internal/rpn.txt + +@doc/OLD/help/README +@doc/OLD/help/makefile.djg +@doc/OLD/help/makefile.unx +@doc/OLD/help/makefile.os2 +@doc/OLD/help/slang.hlp +@doc/OLD/help/slhelp.c + + +@src/calc.c +@src/calc.sl +@src/keywhash.c +@src/_slang.h +@src/sllimits.h +@src/slinclud.h +@src/jdmacros.h +@src/config.hin +@src/DESCRIP.MMS +@src/Makefile.in +@src/modules.unx +@src/slcmplex.c +@src/sltypes.c +@src/slstring.c +@src/slang.c +@src/slang.h +@src/sl-feat.h +@src/slstruct.c +@src/slistruc.c +@src/slassoc.c +@src/slarray.c +@src/slclass.c +@src/slcmd.c +@src/slconfig.h +@src/slcurses.h +@src/slcurses.c +@src/sldisply.c +@src/sldostty.c +@src/slerr.c +@src/slfile.c +@src/slgetkey.c +@src/slkeymap.c +@src/slkeypad.c +@src/slmalloc.c +@src/slarith.c +@src/slarith.inc +@src/slmath.c +@src/slarrfun.c +@src/slarrfun.inc +@src/slimport.c +@src/slmemchr.c +@src/slmemcmp.c +@src/slmemcpy.c +@src/slmemset.c +@src/slmisc.c +@src/slos2tty.c +@src/slparse.c +@src/slpath.c +@src/slregexp.c +@src/slrline.c +@src/slsearch.c +@src/slsmg.c +@src/slstd.c +@src/sltermin.c +@src/sltoken.c +@src/slutty.c +@src/slvideo.c +@src/slvmstty.c +@src/slw32tty.c +@src/slxstrng.c +@src/untic.c +@src/slprepr.c +@src/VMSMAKE.COM +@src/slscroll.c +@src/slsignal.c +@src/slerrno.c +@src/pcconf.c +@src/slcompat.c +@src/slposdir.c +@src/slstdio.c +@src/slproc.c +@src/sltime.c +@src/slstrops.c +@src/slscanf.c +@src/slbstr.c +@src/slpack.c +@src/slintall.c +@src/slposio.c +@src/slarrmis.c +@src/slnspace.c +@src/slospath.c +@src/slqsort.c + +@src/mkfiles/makefile.all +@src/mkfiles/mkmake.c +*src/mkfiles/mkmake.exe +@src/mkfiles/README + +@src/curses/README +@src/curses/Makefile +@src/curses/battle.c +@src/curses/blue.c +@src/curses/bs.c +@src/curses/firework.c +@src/curses/gdc.c +@src/curses/hanoi.c +@src/curses/knight.c +@src/curses/rain.c +@src/curses/tclock.c +@src/curses/view.c +@src/curses/worm.c + +@src/util/perfhash.c +@src/util/keywords.lis +@src/util/bcdump.c +@src/util/chkproto.c + +@src/test/README +@src/test/Makefile +@src/test/sltest.c +@src/test/arith.sl +@src/test/array.sl +@src/test/assoc.sl +@src/test/bstring.sl +@src/test/inc.sl +@src/test/loops.sl +@src/test/pack.sl +@src/test/prep.sl +@src/test/selfload.sl +@src/test/stdio.sl +@src/test/struct.sl +@src/test/template.sl +@src/test/posixio.sl +@src/test/syntax.sl +@src/test/nspace.sl +@src/test/nspace2.sl +@src/test/strops.sl +@src/test/ifeval.sl +@src/test/ospath.sl +@src/test/anytype.sl +@src/test/arrmult.sl +@src/test/sscanf.sl +@src/test/ns1.inc +@src/test/ns2.inc diff --git a/libslang/slsh/INSTALL b/libslang/slsh/INSTALL new file mode 100644 index 0000000..f129243 --- /dev/null +++ b/libslang/slsh/INSTALL @@ -0,0 +1,26 @@ +Before building slsh, it is wise to first build the slang library and +install it via, e.g., 'make install-elf'. + +On Unix, running 'make install' will put: + + * the slsh executable in $prefix/bin/ + * lib/slsh.rc in $prefix/etc/ + * lib/*.sl in $prefix/share/slsh/ + +(See ../INSTALL.unx for information about $prefix.) To change these +locations, edit the Makefile. + +A mingw32 windows executable may be created using Makefile.g32 via + + make -f Makefile.g32 + make -f Makefile.g32 install + +As above, edit the makefile to change the installation locations. You +will also have to put something like: + + set SLSH_PATH=C:/etc + set SLSH_CONF_DIR=C:/etc + +in your autoexec.bat file and then reboot. + +Good luck. diff --git a/libslang/slsh/Makefile.g32 b/libslang/slsh/Makefile.g32 new file mode 100644 index 0000000..55010f6 --- /dev/null +++ b/libslang/slsh/Makefile.g32 @@ -0,0 +1,36 @@ +# This is a makefile for mingw32. Compiling slsh using other compilers should +# be equally simple. +# +CC = gcc +CFLAGS = -W -Wall -O2 +COPY = cp +SLCONFIG_H = ../src/slconfig.h +#--------------------------------------------------------------------------- +# Installation location of the slang library +#--------------------------------------------------------------------------- +SLANG_INC = -I../src +SLANG_LIB = -L../src/gw32objs -lslang +#---------------------------------------------------------------------------- +# Installation location of lib/slsh.rc and lib/*.sl +#---------------------------------------------------------------------------- +COPY = cp +MKDIR = mkdir +SLSH_CONF_DIR = C:/slsh +SLSH_LIB_DIR = C:/slsh +#---------------------------------------------------------------------------- +# End of user configuration +#---------------------------------------------------------------------------- +LIBS = $(RPATH) $(SLANG_LIB) $(DL_LIB) -lm +#DEFS = -DSLSH_CONF_DIR='"$(SLSH_CONF_DIR)"' -DSLSH_PATH='"$(SLSH_LIB_DIR)"' + +slsh: slsh.c config.h + $(CC) $(CFLAGS) slsh.c -o slsh $(SLANG_INC) $(LIBS) +config.h: ../src/config.h + $(COPY) $(SLCONFIG_H) config.h +install: slsh + -$(MKDIR) $(SLSH_CONF_DIR) + -$(MKDIR) $(SLSH_LIB_DIR) + $(COPY) lib/*.sl $(SLSH_LIB_DIR) + $(COPY) lib/slsh.rc $(SLSH_CONF_DIR) + + diff --git a/libslang/slsh/Makefile.in b/libslang/slsh/Makefile.in new file mode 100644 index 0000000..be30d3e --- /dev/null +++ b/libslang/slsh/Makefile.in @@ -0,0 +1,74 @@ +CC = @CC@ +CFLAGS = @CFLAGS@ +LDFLAGS = @LDFLAGS@ @DYNAMIC_LINK_FLAGS@ +#--------------------------------------------------------------------------- +# Installation location of the slang library +#--------------------------------------------------------------------------- +prefix = @prefix@ +exec_prefix = @exec_prefix@ +SLANG_INC = -I@includedir@ +SLANG_LIB = -L@libdir@ -lslang +#--------------------------------------------------------------------------- +DL_LIB = @DYNAMIC_LINK_LIB@ +RPATH = @RPATH@ +#---------------------------------------------------------------------------- +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +MKINSDIR = ../autoconf/mkinsdir.sh +#---------------------------------------------------------------------------- +# Where system-wide slsh.rc and library files reside +#---------------------------------------------------------------------------- +SLSH_CONF_DIR = @sysconfdir@ +SLSH_LIB_DIR = @datadir@/slsh +SLSH_LOCALLIB_DIR = $(SLSH_LIB_DIR)/local-packages +#--------------------------------------------------------------------------- +# DESTDIR is designed to facilitate making packages. Normally it is empty +#--------------------------------------------------------------------------- +DESTDIR = +BIN_DIR = @bindir@ +DEST_BIN_DIR = $(DESTDIR)$(BIN_DIR) +DEST_SLSH_CONF_DIR = $(DESTDIR)$(SLSH_CONF_DIR) +DEST_SLSH_LIB_DIR = $(DESTDIR)$(SLSH_LIB_DIR) +DEST_SLSH_LOCALLIB_DIR = $(DESTDIR)$(SLSH_LOCALLIB_DIR) +#---------------------------------------------------------------------------- +# End of user configuration +#---------------------------------------------------------------------------- +@SET_MAKE@ +SHELL = /bin/sh +LIBS = $(RPATH) $(SLANG_LIB) $(DL_LIB) -lm +DEFS = -DSLSH_CONF_DIR='"$(SLSH_CONF_DIR)"' -DSLSH_PATH='"$(SLSH_LIB_DIR)"' + +slsh: slsh.c config.h + $(CC) $(CFLAGS) $(DEFS) slsh.c -o slsh $(SLANG_INC) $(LDFLAGS) $(LIBS) +config.h: ../src/config.h + cp ../src/config.h . +install_directories: + $(MKINSDIR) $(DEST_BIN_DIR) + $(MKINSDIR) $(DEST_SLSH_CONF_DIR) + $(MKINSDIR) $(DEST_SLSH_LIB_DIR) + $(MKINSDIR) $(DEST_SLSH_LOCALLIB_DIR) +install_lib_files: + @for X in lib/*.sl; \ + do \ + echo $(INSTALL_DATA) $$X $(DEST_SLSH_LIB_DIR); \ + $(INSTALL_DATA) $$X $(DEST_SLSH_LIB_DIR); \ + if [ "$$?" != "0" ]; then \ + exit 1; \ + fi; \ + done + +install: slsh install_directories install_lib_files + $(INSTALL) slsh $(DEST_BIN_DIR)/ + $(INSTALL_DATA) lib/slsh.rc $(DEST_SLSH_CONF_DIR)/ + echo 'prepend_to_slang_load_path("$(SLSH_LOCALLIB_DIR)");' >> $(DEST_SLSH_CONF_DIR)/slsh.rc +#--------------------------------------------------------------------------- +# Housekeeping +#--------------------------------------------------------------------------- +clean: + -/bin/rm -f *~ slsh scripts/*~ lib/*~ +distclean: clean + -/bin/rm -f Makefile +symlinks: + -/bin/rm -f $(ARCH)objs + -mkdir -p $(HOME)/sys/$(ARCH)/objs/jdl/src + ln -s $(HOME)/sys/$(ARCH)/objs/jdl/src $(ARCH)objs diff --git a/libslang/slsh/README b/libslang/slsh/README new file mode 100644 index 0000000..9fd402e --- /dev/null +++ b/libslang/slsh/README @@ -0,0 +1,43 @@ +slsh (slang-shell) is a work in progress. See the scripts/ +subdirectory for some trivial examples of its use. + +Usage: slsh [OPTIONS] [[-|file] [args ...]] + --help Print this help + --version Show slsh version information + -g Compile with debugging code, tracebacks, etc + -n Don't load personal init file + -i init-file Use this file instead of default + -v Show verbose loading messages + +Along with the slsh executable, the files lib/slsh.rc and lib/*.sl +will also get installed. + +Upon startup, the program will try to load slsh.rc as follows: + + If either SLSH_CONF_DIR or SLSH_LIB_DIR environment variables + exist, then look in the corresponding directories for slsh.rc. + Otherwise look in: + + $(prefix)/etc (specified in Makefile) + /usr/local/etc/ + /usr/local/etc/slsh/ + /etc/ + /etc/slsh/ + +The slsh.rc file may load other files from slsh's library directory in +the manner described below. + +Once slsh.rc is loaded, slsh will load $HOME/.slshrc if present. +Finally, it will load the script specified on the command line. If +the name of the script is "-", then it will be read from stdin. + +When a script loads a file via the built-in "evalfile" function or the +"require" function (autoloaded by slsh.rc), the file is searched for +along the SLSH_PATH as specified in the Makefile. An alternate path +may be specified by the SLSH_PATH environment variable. + +The search path may be queried and set during run time via set the +get_lib_path and set_lib_path functions, e.g., + + set_lib_path ("/home/bill/lib/slsh:/usr/share/slsh"); + diff --git a/libslang/slsh/lib/arrayfuns.sl b/libslang/slsh/lib/arrayfuns.sl new file mode 100644 index 0000000..17d9a49 --- /dev/null +++ b/libslang/slsh/lib/arrayfuns.sl @@ -0,0 +1,50 @@ +%!%+ +%\function{reverse} +%\synopsis{Reverse the elements of a 1-d array} +%\usage{Array_Type reverse (Array_Type A)} +%\description +% The \slfun{reverse} function reverses the elements of a 1-d array and +% returns the result. +%\seealso{shift} +%!%- +public define reverse (a) +{ + variable i = length (a); + if (i <= 1) + return a; + + i--; + __tmp(a)[[i:0:-1]]; +} + + +%!%+ +%\function{shift} +%\synopsis{Shift the elements of a 1-d array} +%\usage{Array_Type shift (Array_Type A, Int_Type n)} +%\description +% The \slfun{shift} function shifts the elements of an array by a specified amount +% and returns the result. If \exmp{n} is positive, the ith element of the array +% will be shifted to the position \exmp{i-n} of the array. Elements for +% which \exmp{i-n} is less than 0 will be moved to the end of the array. +%\example +%#v+ +% A = [1,2,3,4,5,6,7,8,9]; +% B = shift (A, 3); % ==> B = [4,5,6,7,8,9,1,2,3]; +% C = shift (A, -1); % ==> C = [9,1,2,3,4,5,6,7,8]; +%#v- +%\notes +% It many ways \exmp{rotate} would be a better name for this function. +%\seealso{reverse, transpose} +%!%- +public define shift (x, n) +{ + variable len = length(x); + variable i = [0:len-1]; + + % allow n to be negative and large + n = len + n mod len; + return x[(i + n)mod len]; +} + +provide ("arrayfuns"); diff --git a/libslang/slsh/lib/autoload.sl b/libslang/slsh/lib/autoload.sl new file mode 100644 index 0000000..db5837a --- /dev/null +++ b/libslang/slsh/lib/autoload.sl @@ -0,0 +1,4 @@ +autoload ("require", "require"); +autoload ("provide", "require"); +autoload ("reverse", "arrayfuns"); +autoload ("shift", "arrayfuns"); diff --git a/libslang/slsh/lib/require.sl b/libslang/slsh/lib/require.sl new file mode 100644 index 0000000..eec1e0d --- /dev/null +++ b/libslang/slsh/lib/require.sl @@ -0,0 +1,82 @@ +% These functions were taken from the jed editor + +static variable Features = Assoc_Type [Int_Type,0]; + +%!%+ +%\function{_featurep} +%\synopsis{Test whether or not a feature is present} +%\usage{Int_Type _featurep (String_Type feature)} +%\description +% The \sfun{_featurep} function returns a non-zero value if the specified +% feature is present. Otherwise, it returns 0 to indicate that the feature +% has not been loaded. +%\seealso{require, provide} +%!%- +public define _featurep (f) +{ + Features[f]; +} + + +%!%+ +%\function{provide} +%\synopsis{Declare that a specified feature is available} +%\usage{provide (String_Type feature)} +%\description +% The \sfun{provide} function may be used to declare that a "feature" has +% been loaded. See the documentation for \sfun{require} for more information. +%\seealso{require, _featurep} +%!%- +public define provide (f) +{ + Features[f] = 1; +} + +%!%+ +%\function{require} +%\synopsis{Make sure a feature is present, and load it if not} +%\usage{require (String_Type feature [,String_Type file]} +%\description +% The \sfun{require} function ensures that a specified "feature" is present. +% If the feature is not present, the \sfun{require} function will attempt to +% load the feature from a file. If called with two arguments, the feature +% will be loaded from the file specified by the second argument. Otherwise, +% the feature will be loaded from a file given by the name of the feature, +% with ".sl" appended. +% +% If after loading the file, if the feature is not present, +% a warning message will be issued. +%\notes +% "feature" is an abstract quantity that is undefined here. +% +% A popular use of the \sfun{require} function is to ensure that a specified +% file has already been loaded. In this case, the feature is the +% filename itself. The advantage of using this mechanism over using +% \ifun{evalfile} is that if the file has already been loaded, \sfun{require} +% will not re-load it. For this to work, the file must indicate that it +% provides the feature via the \sfun{provide} function. +%\seealso{provide, _featurep, evalfile} +%!%- +public define require () +{ + variable f, file; + + if (_NARGS == 2) + { + (f, file) = (); + } + else + { + f = (); + file = f; + } + + if (_featurep (f)) + return; + + () = evalfile (file); + !if (_featurep (f)) + vmessage ("***Warning: feature %s not found in %s", f, file); +} + + diff --git a/libslang/slsh/lib/slsh.rc b/libslang/slsh/lib/slsh.rc new file mode 100644 index 0000000..10ce328 --- /dev/null +++ b/libslang/slsh/lib/slsh.rc @@ -0,0 +1,46 @@ +% -*- slang -*- + +% This file gets loaded whenever slsh runs. Its primary purpose is to define +% some functions that are useful in scripts, and to set up some local paths + +static define dir_exists (dir) +{ + variable s = stat_file (dir); + if (s == NULL) return 0; + return stat_is ("dir", s.st_mode); +} + +%!%+ +%\function{prepend_to_slang_load_path} +%\synopsis{Prepend a directory to the load-path} +%\usage{prepend_to_slang_load_path (String_Type dir)} +%\description +% This function adds a directory to the beginning of the interpreter's +% load-path. +%\seealso{append_to_slang_load_path, set_slang_load_path} +%!%- +public define prepend_to_slang_load_path (p) +{ + if (dir_exists (p)) + set_slang_load_path (strcat (p, ":", get_slang_load_path ())); +} + +%!%+ +%\function{append_to_slang_load_path} +%\synopsis{Append a directory to the load-path} +%\usage{append_to_slang_load_path (String_Type dir)} +%\description +% This function adds a directory to the end of the interpreter's +% load-path. +%\seealso{prepend_to_slang_load_path, set_slang_load_path} +%!%- +public define append_to_slang_load_path (p) +{ + if (dir_exists (p)) + set_slang_load_path (get_slang_load_path (), ":", p); +} + +() = evalfile ("autoload.sl"); + +% Add local additions here + diff --git a/libslang/slsh/scripts/badlinks b/libslang/slsh/scripts/badlinks new file mode 100755 index 0000000..77409bd --- /dev/null +++ b/libslang/slsh/scripts/badlinks @@ -0,0 +1,78 @@ +#!/usr/bin/env slsh +% Find links that point to non-existent files + +static define warn () +{ + variable args = __pop_args (_NARGS-1); + variable err = (); + variable msg; + + msg = sprintf (__push_args (args)); + + if (err) + err = ": " + errno_string (err); + else + err == ""; + + () = fprintf (stderr, "%s: %s%s\n", + __argv[0], msg, err); +} + +static define badlinks (dir) +{ + variable files, file; + variable st; + + files = listdir (dir); + if (files == NULL) + { + warn (errno, dir); + return; + } + + foreach (files) + { + file = (); + + file = path_concat (dir, file); + st = stat_file (file); + if (st != NULL) + continue; + + if (errno != ENOENT) + { + warn (errno, file); + continue; + } + + if (-1 == fprintf (stdout, "%s\n", file)) + break; + } +} + +define main (argc, argv) +{ + if (argc > 1) + { + if (argv[1] == "--help") + { + () = fprintf (stdout, "Usage: %s [--help] [dirs....]\n", + __argv[0]); + exit (1); + } + } + + if (argc == 1) + { + badlinks ("."); + exit (0); + } + + foreach (argv[[1:]]) + badlinks (); + + exit (0); +} + +main (__argc, __argv); + diff --git a/libslang/slsh/scripts/htmlstrip b/libslang/slsh/scripts/htmlstrip new file mode 100755 index 0000000..c6a6b36 --- /dev/null +++ b/libslang/slsh/scripts/htmlstrip @@ -0,0 +1,48 @@ +#! /usr/bin/env slsh +% -*- mode: slang -*- +%_debug_info = 1; + +% This file strips HTML tags from one or more html files and write the result +% to stdout. It is very simple minded. + +define process_file (file) +{ + variable fp, l; + + if (file != NULL) + { + fp = fopen (file, "r"); + if (fp == NULL) + { + () = fputs (sprintf ("Unable to open %s\n", file), stderr); + return; + } + } + else fp = stdin; + + foreach (fp) + { + l = (); + + l = strtrim (str_uncomment_string (l, "<", ">")); + !if (strlen (l)) + continue; + + () = fputs (l, stdout); + () = fputs ("\n", stdout); + } +} + +if (__argc == 1) +{ + if (isatty (stdin)) + { + () = fprintf (stderr, "Usage: %s [files...]\n", __argv[0]); + exit (1); + } + process_file (NULL); + exit (0); +} + +foreach (__argv[[1:]]) process_file (); +exit (0); diff --git a/libslang/slsh/scripts/ls b/libslang/slsh/scripts/ls new file mode 100755 index 0000000..197d47d --- /dev/null +++ b/libslang/slsh/scripts/ls @@ -0,0 +1,333 @@ +#!/usr/bin/env slsh +%_debug_info = 1; +% A simple ls designed primarily for windows. + +static variable Months = + ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", + "Oct", "Nov", "Dec"]; + +static variable Six_Months_Ago = _time () - 3600*24*30*6; + + +static define ls_long (this_dir, file_list, st_list) +{ + _for (0, length(file_list)-1, 1) + { + variable i = (); + variable file = file_list[i]; + variable st = st_list[i]; + + variable size, mode, owner, group, symlink, mtime; + variable mstring; + variable tm; + + size = st.st_size; + mtime = st.st_mtime; + mode = st.st_mode; + owner = st.st_uid; + group = st.st_gid; +#ifdef WIN32 + variable attrs = st.st_opt_attrs; +#endif + tm = localtime (mtime); +#ifdef WIN32 + if (tm == NULL) + mtime = "Jan 01 1980"; + else +#endif + if (mtime < Six_Months_Ago) + mtime = sprintf ("%s %2d %4d", + Months[tm.tm_mon], + tm.tm_mday, + 1900 + tm.tm_year); + else + mtime = sprintf ("%s %2d %2d:%02d", + Months[tm.tm_mon], + tm.tm_mday, + tm.tm_hour, + tm.tm_min); + + symlink = ""; +#ifexists readlink + if (stat_is ("lnk", mode)) + { + symlink = readlink (path_concat (this_dir, file)); + if (symlink == NULL) + symlink = "??"; + + symlink = " -> " + symlink; + } +#endif +#ifdef WIN32 + mstring = stat_mode_to_string (mode, attrs); +#else + mstring = stat_mode_to_string (mode); +#endif + () = fprintf (stdout, + "%8s %8S %8S %10S %s %s%s\n", + mstring, owner, group, size, mtime, file, symlink); + } +} + +static variable + Use_Long_Form = 0, + Use_atime = 0, + Sort_By_Time = 0, + Sort_By_Size = 0, + Use_a_Option = 0, + Use_F_Option = 1, + Use_R_Option = 0, + Use_d_Option = 0; + + +static define parse_args (args) +{ + variable ch; + + foreach (args) + { + ch = (); + switch (ch) + { case 'l': Use_Long_Form = 1; } + { case 'u': Use_atime = 1; } + { case 't': Sort_By_Time = 1; } + { case 'S': Sort_By_Size = 1; } + { case 'd': Use_d_Option = 1; } + { case 'a': Use_a_Option = 1; } + { case 'R': Use_R_Option = 1; } + { case '-':} % ignore it + { + () = fprintf (stderr, "Option '%c' not supported.\n", ch); + } + } +} + +define ls_short (dirs) +{ + variable max_len; + variable ncols; + variable num, num_per_row, num_rows; + variable stride; + + num = length (dirs); + max_len = 0; + foreach (dirs) + { + variable dir; + + dir = (); + if (strlen (dir) > max_len) + max_len = strlen (dir); + } + + max_len += 2; + + variable format = "%-" + string (max_len) + "s"; + + ncols = 80; + num_per_row = ncols / max_len; + if (num_per_row == 0) + num_per_row = 1; + + num_rows = (num + num_per_row - 1) / num_per_row; + _for (0, num_rows-1, 1) + { + variable r = (); + _for (0, num_per_row-1, 1) + { + variable c = (); + variable i = r + num_rows * c; + + if (i < num) + { + if (c + 1 < num_per_row) + () = fprintf (stdout, format, dirs[i]); + else + () = fputs (dirs[i], stdout); + } + } + () = fputs ("\n", stdout); + } +} + +static define size_sort (a, b) +{ + b.st_size - a.st_size; +} + +static define time_sort (a, b) +{ + b.st_mtime - a.st_mtime; +} + +static define is_non_null_fun (a) +{ + a != NULL; +} + + +define sort_files (dirs, sts) +{ + variable st, i, non_null; + + % Some of the sts structs may be NULL. Get rid of those + non_null = array_map (Char_Type, &is_non_null_fun, sts); + + i = where (non_null); + dirs = dirs [i]; + sts = sts [i]; + + + if (Use_atime) + { + foreach (sts) + { + st = (); + st.st_mtime = st.st_atime; + } + } + + if (Sort_By_Time) + i = array_sort (sts, &time_sort); + else if (Sort_By_Size) + i = array_sort (sts, &size_sort); + else + i = array_sort (dirs); + + return dirs[i], sts[i]; +} + +static define isdir_fun (st) +{ + stat_is ("dir", st.st_mode); +} + +static define list_dir (dir) +{ +#ifndef UNIX + if (Use_a_Option) + listdir (dir, ""); + else +#endif + listdir (dir); +} + + +define do_ls (); +define do_ls (dirs, this_dir, recurse, prune_hidden) +{ + variable i, len, st, sts, dir; + + if (dirs == NULL) + return; + + len = length(dirs); + sts = Struct_Type [len]; + + + _for (0, len-1, 1) + { + i = (); + dir = dirs[i]; + + if (prune_hidden) + { + if ((dir[0] == '.') and (Use_a_Option == 0)) + { + !if (is_substr (dir, "\\")) + continue; + } + } + + st = lstat_file (path_concat (this_dir, dir)); + if (st == NULL) + () = fprintf (stderr, "%s: %s: %s\n", + __argv[0], + path_concat (this_dir, dir), + errno_string (errno)); + else + sts[i] = st; + } + + + (dirs, sts) = sort_files (dirs, sts); + + variable isdir; + + if (length (sts)) isdir = array_map (Char_Type, &isdir_fun, sts); + else isdir = Int_Type[0]; + + variable i_reg = where (isdir == 0); + variable i_dir = where (isdir); + variable dont_recurse; + + + if (Use_F_Option and length (i_dir)) + dirs[i_dir] = array_map (String_Type, &path_concat, dirs[i_dir], ""); + + dont_recurse = (Use_d_Option or not recurse); + + if (dont_recurse) + { + if (Use_Long_Form) + ls_long (this_dir, dirs, sts); + else + ls_short (dirs); + return; + } + + if (Use_Long_Form) + ls_long (this_dir, dirs[i_reg], sts[i_reg]); + else + ls_short (dirs[i_reg]); + + + if (length(i_dir) == 1) + { + if (length (i_reg) == 0) + { + dir = dirs[i_dir][0]; + + do_ls (list_dir (dir), dir, Use_R_Option, 1); + return; + } + () = fputs ("\n", stdout); + } + + + foreach (dirs[i_dir]) + { + dir = (); + dir = path_concat (this_dir, dir); + () = fprintf (stdout, "%s:\n", dir); + do_ls (list_dir (dir), dir, Use_R_Option, 1); + () = fprintf (stdout, "\n"); + } +} + +define main (argc, argv) +{ + variable dirs; + + if (argc == 1) + return do_ls (list_dir("."), ".", 0, 1); + else if (__argv[1][0] == '-') + { + parse_args (__argv[1]); + + if (Use_d_Option and Use_R_Option) + Use_R_Option = 0; + + if (__argc > 2) + dirs = __argv[[2:]]; + else + return do_ls (list_dir("."), ".", Use_R_Option, 1); + } + else + dirs = __argv[[1:]]; + + do_ls (dirs, ".", 1, 0); +} + + +main (__argc, __argv); diff --git a/libslang/slsh/scripts/lsrpm b/libslang/slsh/scripts/lsrpm new file mode 100755 index 0000000..dcd607a --- /dev/null +++ b/libslang/slsh/scripts/lsrpm @@ -0,0 +1,85 @@ +#! /usr/bin/env slsh +% Generate a listing of an RPM file + +static define pgm_usage () +{ + vmessage ("Usage: lsrpm FILENAME"); + exit (1); +} + +static variable RPM_Command = "rpm -q -l --dump -p "; + +static define exit_error (msg) +{ + () = fprintf (stderr, "%s\n", msg); + exit (1); +} + + +static define run_rpm (file) +{ + variable fp; + variable lines; + variable months = + ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", + "Oct", "Nov", "Dec"]; + variable s; + + fp = popen (RPM_Command + file, "r"); + if (fp == NULL) + exit_error ("Failed to open RPM process"); + + % each line contains: + % path size mtime md5sum mode owner group isconfig isdoc rdev symlink + + variable six_months_ago = _time () - 3600*24*30*6; + + foreach (fp) + { + variable path, size, mode, owner, group, symlink, mtime; + variable mstring; + variable tm; + + s = (); + s = strchop (strtrim_end (s, "\n"), ' ', 0); + + path = s[0]; + size = s[1]; + mtime = integer (s[2]); + mode = integer (s[4]); + owner = s[5]; + group = s[6]; + + tm = localtime (mtime); + if (mtime < six_months_ago) + mtime = sprintf ("%s %2d %4d", + months[tm.tm_mon], + tm.tm_mday, + 1900 + tm.tm_year); + else + mtime = sprintf ("%s %2d % 2d:%02d", + months[tm.tm_mon], + tm.tm_mday, + tm.tm_hour, + tm.tm_min); + + + symlink = ""; + if (stat_is ("lnk", mode)) + symlink = " -> " + s[10]; + + mstring = stat_mode_to_string (mode); + + if (-1 == fprintf (stdout, + "%8s %8s %8s %10s %s %s%s\n", + mstring, owner, group, size, mtime, path, symlink)) + exit_error (sprintf ("Write failed: %s", errno_string (errno))); + } + () = pclose (fp); +} + +if (__argc != 2) + pgm_usage (); + +run_rpm (__argv[1]); +exit (0); diff --git a/libslang/slsh/scripts/mv b/libslang/slsh/scripts/mv new file mode 100755 index 0000000..47bc25f --- /dev/null +++ b/libslang/slsh/scripts/mv @@ -0,0 +1,143 @@ +#!/usr/bin/env slsh +% -*- slang -*- + +static variable Confirm_Move = 0; + +static define get_yn () +{ + variable args = __pop_args (_NARGS); + () = fprintf (stdout, __push_args (args)); + () = fflush (stdout); + + variable yn; + if (fgets (&yn, stdin) <= 0) + return -1; + + "y" == strlow (strtrim (yn)); +} + + +static define move_file (from, to) +{ + if (from == to) + { + () = fprintf (stderr, "%s: Cannot move a file to itself.\n", __argv[0]); + return -1; + } + + if (0 == rename (from, to)) + return 0; + + variable st = stat_file (to); + + if (st != NULL) + { + if (1 != get_yn ("%s exists. Overwrite? [y/n]", to)) + { + () = fputs ("Not Confirmed\n", stdout); + return -1; + } + () = remove (to); + } + + if (0 == rename (from, to)) + return 0; + + ()=fprintf (stderr, "Failed to rename %s to %s: %s\n", + from, to, errno_string (errno)); + + return -1; +} + +define move_files (from_files, to) +{ + variable st = stat_file (to); + if (st == NULL) + { + if (length (from_files) != 1) + { + () = fprintf (stderr, "%s must be a directory\n", to); + exit (1); + } + if (-1 == move_file (from_files[0], to)) + exit (1); + exit (0); + } + + !if (stat_is ("dir", st.st_mode)) + { + if (length (from_files) != 1) + { + () = fprintf (stderr, "%s must be a directory\n", to); + exit (1); + } + if (-1 == move_file (from_files[0], to)) + exit (1); + exit (0); + } + + + foreach (from_files) + { + variable old = (); + variable new = path_concat (to, path_basename (old)); + + if (NULL == stat_file (old)) + { + () = fprintf (stderr, "Unable to access %s\n", old); + continue; + } + + if (Confirm_Move) + { + if (1 != get_yn ("Move %s to %s/? [y/n]", old, to)) + { + () = fputs ("Not Confirmed\n", stdout); + continue; + } + } + + + () = move_file (old, new); + } +} + +static define usage () +{ + () = fprintf (stdout, "Usage: %s [-i] files ... dir\n", __argv[0]); + exit (1); +} + +define main (argc, argv) +{ + argc--; + argv = argv[[1:]]; + + while (argc > 1) + { + if (argv[0] == "-i") + { + Confirm_Move = 1; + argc--; + argv = argv[[1:]]; + continue; + } + break; + } + + if (argc < 2) + usage (); + + move_files (argv[[0:argc-2]], argv[argc-1]); +} + + +define slsh_main () +{ + main (__argc, __argv); +} + + + + + diff --git a/libslang/slsh/scripts/purge b/libslang/slsh/scripts/purge new file mode 100755 index 0000000..fae0e20 --- /dev/null +++ b/libslang/slsh/scripts/purge @@ -0,0 +1,65 @@ +#! /usr/bin/env slsh +% -*- mode: slang -*- +_debug_info = 1; + +static define purge_file (file, age, print_option) +{ + variable st = stat_file (file); + if (st == NULL) + { + () = fprintf (stderr, "stat %s failed: %s\n", file, errno_string (errno)); + return; + } + + if (st.st_ctime >= age) + return; + + if (print_option) + { + () = fprintf (stdout, "%s\n", file); + return; + } + + if (-1 == remove (file)) + () = fprintf (stderr, "remove %s failed: %s\n", file, errno_string (errno)); +} + +static define purge_usage () +{ + () = fprintf (stderr, "Usage: %s [-n] NUM-DAYS-OLD files...\n", __argv[0]); + () = fprintf (stderr, " Files older than NUM-DAYS-OLD be deleted.\n"); + () = fprintf (stderr, " -n ==> Just print the files to be removed but do not remove them.\n"); + exit (1); +} + +static define main (argc, argv) +{ + variable age, i, print_option, file; + + if (argc < 3) purge_usage (); + + i = 2; + print_option = 0; + if (argv[1] == "-n") + { + i++; + print_option = 1; + if (argc < 4) + purge_usage (); + } + + age = __argv[i-1]; + if (String_Type == _slang_guess_type (age)) + purge_usage (); + + age = _time() - atof(age) * 24 * 3600; + + foreach (argv[[i:]]) + { + file = (); + purge_file (file, age, print_option); + } + exit (0); +} + +main (__argc, __argv); diff --git a/libslang/slsh/slsh.c b/libslang/slsh/slsh.c new file mode 100644 index 0000000..ffa6c3d --- /dev/null +++ b/libslang/slsh/slsh.c @@ -0,0 +1,481 @@ +#include "config.h" +#include +#include +#ifdef __WIN32__ +# include +#endif + +#include + +#ifdef HAVE_UNISTD_H +# include +#endif +#include +#include + +static char *Slsh_Version = "0.6-0"; +#define SLSHRC_FILE "slsh.rc" + +#ifdef REAL_UNIX_SYSTEM +/* # define DEFAULT_LIBRARY_PATH "/usr/local/share/slsh:/usr/local/lib/slsh:/usr/share/slsh:/usr/lib/slsh"; */ +# define DEFAULT_CONF_PATH "/usr/local/etc:/usr/local/slsh:/etc:/etc/slsh"; +# define USER_SLSHRC ".slshrc" +#else +# define DEFAULT_LIBRARY_PATH NULL +# define USER_SLSHRC "slsh.rc" +#endif + +#ifdef __os2__ +# ifdef __IBMC__ +/* IBM VA3 doesn't declare S_IFMT */ +# define S_IFMT (S_IFDIR | S_IFCHR | S_IFREG) +# endif +#endif + +#ifndef S_ISLNK +# ifdef S_IFLNK +# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) 0 +# endif +#endif + +#ifndef S_ISREG +# ifdef S_IFREG +# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +# else +# define S_ISREG(m) 0 +# endif +#endif + +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +#endif + +#ifndef S_ISCHR +# ifdef S_IFCHR +# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +# else +# define S_ISCHR(m) 0 +# endif +#endif + +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) 0 +# endif +#endif + +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) 0 +# endif +#endif + +#ifndef S_ISSOCK +# ifdef S_IFSOCK +# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) +# else +# define S_ISSOCK(m) 0 +# endif +#endif + + +#ifndef S_IRUSR +# define S_IRUSR 0400 +#endif +#ifndef S_IWUSR +# define S_IWUSR 0200 +#endif +#ifndef S_IXUSR +# define S_IXUSR 0100 +#endif +#ifndef S_IRGRP +# define S_IRGRP 0040 +#endif +#ifndef S_IWGRP +# define S_IWGRP 0020 +#endif +#ifndef S_IXGRP +# define S_IXGRP 0010 +#endif +#ifndef S_IROTH +# define S_IROTH 0004 +#endif +#ifndef S_IWOTH +# define S_IWOTH 0002 +#endif +#ifndef S_IXOTH +# define S_IXOTH 0001 +#endif +#ifndef S_ISUID +# define S_ISUID 04000 +#endif +#ifndef S_ISGID +# define S_ISGID 02000 +#endif +#ifndef S_ISVTX +# define S_ISVTX 01000 +#endif + +typedef struct _AtExit_Type +{ + SLang_Name_Type *nt; + struct _AtExit_Type *next; +} +AtExit_Type; + +static AtExit_Type *AtExit_Hooks; + +static void at_exit (SLang_Ref_Type *ref) +{ + SLang_Name_Type *nt; + AtExit_Type *a; + + if (NULL == (nt = SLang_get_fun_from_ref (ref))) + return; + + a = (AtExit_Type *) SLmalloc (sizeof (AtExit_Type)); + if (a == NULL) + return; + + a->nt = nt; + a->next = AtExit_Hooks; + AtExit_Hooks = a; +} + +static void c_exit (int *code) +{ + while (AtExit_Hooks != NULL) + { + AtExit_Type *next = AtExit_Hooks->next; + if (SLang_Error == 0) + (void) SLexecute_function (AtExit_Hooks->nt); + + SLfree ((char *) AtExit_Hooks); + AtExit_Hooks = next; + } + exit (*code); +} + + +static void stat_mode_to_string (void) +{ + int mode, opts; + char mode_string[12]; + + opts = 0; + if (SLang_Num_Function_Args == 2) + { + if (-1 == SLang_pop_integer (&opts)) + return; + } + + if (-1 == SLang_pop_integer (&mode)) + return; + + + if (S_ISREG(mode)) mode_string[0] = '-'; + else if (S_ISDIR(mode)) mode_string[0] = 'd'; + else if (S_ISLNK(mode)) mode_string[0] = 'l'; + else if (S_ISCHR(mode)) mode_string[0] = 'c'; + else if (S_ISFIFO(mode)) mode_string[0] = 'f'; + else if (S_ISSOCK(mode)) mode_string[0] = 's'; + else if (S_ISBLK(mode)) mode_string[0] = 'b'; + + if (mode & S_IRUSR) mode_string[1] = 'r'; else mode_string[1] = '-'; + if (mode & S_IWUSR) mode_string[2] = 'w'; else mode_string[2] = '-'; + if (mode & S_IXUSR) mode_string[3] = 'x'; else mode_string[3] = '-'; + if (mode & S_ISUID) mode_string[3] = 's'; + +#ifdef __WIN32__ + mode_string[4] = '-'; + mode_string[5] = '-'; + mode_string[6] = '-'; + + if (opts & FILE_ATTRIBUTE_ARCHIVE) mode_string[7] = 'A'; else mode_string[7] = '-'; + if (opts & FILE_ATTRIBUTE_SYSTEM) mode_string[8] = 'S'; else mode_string[8] = '-'; + if (opts & FILE_ATTRIBUTE_HIDDEN) mode_string[9] = 'H'; else mode_string[9] = '-'; +#else + if (mode & S_IRGRP) mode_string[4] = 'r'; else mode_string[4] = '-'; + if (mode & S_IWGRP) mode_string[5] = 'w'; else mode_string[5] = '-'; + if (mode & S_IXGRP) mode_string[6] = 'x'; else mode_string[6] = '-'; + if (mode & S_ISGID) mode_string[6] = 'g'; + + if (mode & S_IROTH) mode_string[7] = 'r'; else mode_string[7] = '-'; + if (mode & S_IWOTH) mode_string[8] = 'w'; else mode_string[8] = '-'; + if (mode & S_IXOTH) mode_string[9] = 'x'; else mode_string[9] = '-'; + if (mode & S_ISVTX) mode_string[9] = 't'; +#endif + + mode_string[10] = 0; + (void) SLang_push_string (mode_string); +} + + +static int Verbose_Loading; + +static int try_to_load_file (char *path, char *file, char *ns) +{ + int status; + + if (path == NULL) + path = "."; + + if (file != NULL) + { + file = SLpath_find_file_in_path (path, file); + if (file == NULL) + return 0; + } + /* otherwise use stdin */ + + status = SLns_load_file (file, ns); + SLfree (file); + if (status == 0) + return 1; + return -1; +} + + +static int load_startup_file (void) +{ + char *dir; + int status; + + dir = getenv ("SLSH_CONF_DIR"); + if (dir == NULL) + dir = getenv ("SLSH_LIB_DIR"); + + if (NULL == dir) + { +#ifdef SLSH_CONF_DIR + dir = SLSH_CONF_DIR; + if (dir != NULL) + { + status = try_to_load_file (dir, SLSHRC_FILE, NULL); + if (status == -1) + return -1; + if (status == 1) + return 0; + } +#endif + dir = DEFAULT_CONF_PATH; + } + + if (-1 == (status = try_to_load_file (dir, SLSHRC_FILE, NULL))) + return -1; + + if ((status == 0) && Verbose_Loading) + { + SLang_vmessage ("*** Installation Problem? Unable to find the %s config file.", + SLSHRC_FILE); + } + + return 0; +} + + +#if 0 +static int is_script (char *file) +{ + FILE *fp; + char buf[3]; + int is; + + if (NULL == (fp = fopen (file, "r"))) + return 0; + + is = ((NULL != fgets (buf, sizeof(buf), fp)) + && (buf[0] == '#') && (buf[1] == '!')); + + fclose (fp); + return is; +} +#endif + +static int setup_paths (void) +{ + char *libpath; + + if (NULL == (libpath = getenv ("SLSH_PATH"))) + { +#ifdef SLSH_PATH + libpath = SLSH_PATH; +#endif + } + + return SLpath_set_load_path (libpath); +} + +/* Create the Table that S-Lang requires */ +static SLang_Intrin_Fun_Type Intrinsics [] = +{ + MAKE_INTRINSIC_I("exit", c_exit, VOID_TYPE), + MAKE_INTRINSIC_1("atexit", at_exit, VOID_TYPE, SLANG_REF_TYPE), + MAKE_INTRINSIC_0("stat_mode_to_string", stat_mode_to_string, VOID_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +static void usage (void) +{ + char *libpath; + fprintf (stderr, "\ +Usage: slsh [OPTIONS] [-|file [args...]]\n\ + --help Print this help\n\ + --version Show slsh version information\n\ + -g Compile with debugging code, tracebacks, etc\n\ + -n Don't load personal init file\n\ + -i init-file Use this file instead of ~/%s\n\ + -v Show verbose loading messages\n\ +", + USER_SLSHRC + ); + libpath = SLpath_get_load_path (); + fprintf (stderr, "Default search path: %s\n", (libpath == NULL) ? "" : libpath); + SLang_free_slstring (libpath); + + exit (1); +} + +static void version (void) +{ + fprintf (stdout, "slsh version %s\n", Slsh_Version); + fprintf (stdout, "S-Lang Library Version: %s\n", SLang_Version_String); + if (SLANG_VERSION != SLang_Version) + { + fprintf (stdout, "\t** Note: This program was compiled against version %s.\n", + SLANG_VERSION_STRING); + } + + exit (0); +} + +int main (int argc, char **argv) +{ + char *file = NULL; + char *init_file = USER_SLSHRC; + char *init_file_dir; + + if (SLang_Version < SLANG_VERSION) + { + fprintf (stderr, "***Warning: Executable compiled against S-Lang %s but linked to %s\n", + SLANG_VERSION_STRING, SLang_Version_String); + fflush (stderr); + } + + if ((-1 == SLang_init_all ()) + || (-1 == SLang_init_array_extra ()) + || (-1 == SLang_init_import ()) /* dynamic linking */ + || (-1 == SLadd_intrin_fun_table (Intrinsics, NULL))) + { + fprintf(stderr, "Unable to initialize S-Lang.\n"); + return 1; + } + + /* FIXME for other systems */ + init_file_dir = getenv ("HOME"); + + if (-1 == setup_paths ()) + return -1; + + while (argc > 1) + { + if (0 == strcmp (argv[1], "--version")) + version (); + + if (0 == strcmp (argv[1], "--help")) + usage (); + + if (0 == strcmp (argv[1], "-g")) + { + SLang_generate_debug_info (1); + argc--; + argv++; + continue; + } + + if (0 == strcmp (argv[1], "-n")) + { + init_file = NULL; + argc--; + argv++; + continue; + } + + if (0 == strcmp (argv[1], "-v")) + { + (void) SLang_load_file_verbose (1); + Verbose_Loading = 1; + argc--; + argv++; + continue; + } + + if ((0 == strcmp (argv[1], "-i")) + && (argc > 2)) + { + init_file = argv[2]; + init_file_dir = NULL; + argc -= 2; + argv += 2; + continue; + } + break; + } + + if (argc == 1) + { + if (0 == isatty (fileno(stdin))) + file = NULL; + else + usage (); + } + else + { + file = argv[1]; + if (0 == strcmp (file, "-")) + file = NULL; +#if 0 + if (is_script (file)) + { + argv++; + argc--; + } +#else + argc--; + argv++; +#endif + } + /* fprintf (stdout, "slsh: argv[0]=%s\n", argv[0]); */ + if (-1 == SLang_set_argc_argv (argc, argv)) + return 1; + + /* Turn on traceback generation */ + SLang_Traceback = 1; + + if (-1 == load_startup_file ()) + return SLang_Error; + + if ((init_file != NULL) + && (-1 == try_to_load_file (init_file_dir, init_file, NULL))) + return SLang_Error; + + /* Now load an initialization file and exit */ + if (0 == try_to_load_file (NULL, file, NULL)) + { + fprintf (stderr, "%s: file not found\n", file); + exit (1); + } + + (void) SLang_run_hooks ("slsh_main", 0); + return SLang_Error; +} diff --git a/libslang/src/DESCRIP.MMS b/libslang/src/DESCRIP.MMS new file mode 100644 index 0000000..79bf971 --- /dev/null +++ b/libslang/src/DESCRIP.MMS @@ -0,0 +1,41 @@ +# Do not run mms/mmk directly. Do @vmsmake which will call mms/mmk. +# +# MMS file to build S-Lang (Thanks to Hunter Goatley) +# Modified by zinser@axp602.gsi.de +# +.IFDEF __MMK__ +.ELSE +EXE = .EXE +OBJ = .OBJ +OLB = .OLB +.ENDIF + +OBJS = SLANG$(OBJ),SLPARSE$(OBJ),SLMATH$(OBJ),- + SLSTD$(OBJ),SLARRAY$(OBJ),SLREGEXP$(OBJ),SLERR$(OBJ),- + SLKEYMAP$(OBJ),SLRLINE$(OBJ),SLTOKEN$(OBJ),SLGETKEY$(OBJ),- + SLVMSTTY$(OBJ),SLMEMCMP$(OBJ),SLMEMCHR$(OBJ),SLMEMCPY$(OBJ)- + SLDISPLY$(OBJ),SLSMG$(OBJ),SLSEARCH$(OBJ),SLCMD$(OBJ)- + SLMALLOC$(OBJ),SLMEMSET$(OBJ),SLMISC$(OBJ),SLPREPR$(OBJ),- + SLCLASS$(OBJ),SLTYPES$(OBJ),SLSCROLL$(OBJ),SLSIGNAL$(OBJ), - + SLKEYPAD$(OBJ),SLERRNO$(OBJ),SLCURSES$(OBJ),SLSTRING$(OBJ),- + SLSTRUCT$(OBJ),SLCMPLEX$(OBJ),SLARRFUN$(OBJ),SLIMPORT$(OBJ),- + SLPATH$(OBJ),SLARITH$(OBJ),SLASSOC$(OBJ),SLCOMPAT$(OBJ),- + SLPOSDIR$(OBJ),SLSTDIO$(OBJ),SLPROC$(OBJ),SLTIME$(OBJ),- + SLSTROPS$(OBJ),SLBSTR$(OBJ),SLPACK$(OBJ),SLINTALL$(OBJ),- + SLISTRUC$(OBJ),SLPOSIO$(OBJ),SLNSPACE$(OBJ),SLARRMIS$(OBJ),- + SLOSPATH$(OBJ),SLSCANF$(OBJ) + +HFILES = SLANG.H,_SLANG.H + +ALL : calc$(exe) + write sys$output "Complete." +CALC$(EXE) : CALC$(OBJ),SLANG$(OLB)($(OBJS)) + $(LINK)$(LINKFLAGS)/NOTRACE CALC$(OBJ),client.opt/opt + +CALC$(OBJ) : CALC.C CONFIG.H + +# +# Most modules depend on most of the .H files, so I'm going to be lazy +# and just make them all depend on all of them. +# +$(OBJS) : $(HFILES) CONFIG.H diff --git a/libslang/src/Makefile.in b/libslang/src/Makefile.in new file mode 100644 index 0000000..30cd2f6 --- /dev/null +++ b/libslang/src/Makefile.in @@ -0,0 +1,214 @@ +# -*- sh -*- +#--------------------------------------------------------------------------- +# ANSI C compiler +#--------------------------------------------------------------------------- +CC = @CC@ +CFLAGS = @CFLAGS@ +LDFLAGS = @LDFLAGS@ @DYNAMIC_LINK_FLAGS@ +#----------------------------------------------------------------------------- +# System library that contains functions for dynamic linking (-ldl) +#----------------------------------------------------------------------------- +DL_LIB= @DYNAMIC_LINK_LIB@ + +#--------------------------------------------------------------------------- +# Compiler for producing a shared library (ELF) +#--------------------------------------------------------------------------- +ELF_CC = @ELF_CC@ +ELF_CFLAGS = @ELF_CFLAGS@ +ELF_LINK = @ELF_LINK@ +ELF_DEP_LIBS = @ELF_DEP_LIBS@ + +#--------------------------------------------------------------------------- +# Set these values to ABSOLUTE path names +#--------------------------------------------------------------------------- +SRCDIR = @SRCDIR@# Location of sources +OBJDIR = @OBJDIR@# Location of objects +ELFDIR = @ELFDIR@# Location of elf objects + +#--------------------------------------------------------------------------- +# Set for termcap support +#TCAPLIB = -ltermcap +TCAPLIB = @TERMCAP@ +MISC_TERMINFO_DIRS = @MISC_TERMINFO_DIRS@ + +#--------------------------------------------------------------------------- +# Directory where library is going to go when installed +#--------------------------------------------------------------------------- +prefix = @prefix@ +exec_prefix = @exec_prefix@ +install_lib_dir = @libdir@ +install_include_dir = @includedir@ +install_doc_dir = $(prefix)/doc/slang +DOC_FILES = ../changes.txt ../COPY* ../doc/slangdoc.html ../doc/text/*.txt +MODULE_INSTALL_DIR = @libdir@/slang/modules +#--------------------------------------------------------------------------- +# DESTDIR is designed to facilitate making packages. Normally it is empty +#--------------------------------------------------------------------------- +DESTDIR = +DEST_LIBDIR = $(DESTDIR)$(install_lib_dir) +DEST_DOCDIR = $(DESTDIR)$(install_doc_dir) +DEST_INCDIR = $(DESTDIR)$(install_include_dir) + +#--------------------------------------------------------------------------- +# Misc commands (safe to leave these untouched) +#--------------------------------------------------------------------------- +RANLIB = @RANLIB@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +MKINSDIR = ../autoconf/mkinsdir.sh +RM = rm -f +RM_R = rm -rf +AR_CR = ar cr +RMDIR = rmdir +LN = /bin/ln -sf +CP = cp +MKDIR = mkdir +@SET_MAKE@ +#--------------------------------------------------------------------------- +# There should be no need to change anything below here. +#--------------------------------------------------------------------------- +THIS_LIB = slang# +OTHERSTUFF = +THIS_LIB_DEFINES = -DSLANG +ELF_MAJOR_VERSION = @slang_major_version@# +ELF_MINOR_VERSION = @slang_minor_version@# + +CONFIG_H = config.h +ALL_CFLAGS = $(CFLAGS) -Dunix $(THIS_LIB_DEFINES) +ALL_ELF_CFLAGS = $(ELF_CFLAGS) -Dunix $(THIS_LIB_DEFINES) +COMPILE_CMD = $(CC) -c $(ALL_CFLAGS) +ELFCOMPILE_CMD = $(ELF_CC) -c $(ALL_ELF_CFLAGS) +ELF_LINK_CMD = @ELF_LINK_CMD@ + +NORMAL_LIB = lib$(THIS_LIB).a +OBJDIR_NORMAL_LIB = $(OBJDIR)/$(NORMAL_LIB) + +# ELFLIB = lib$(THIS_LIB).so# +# ELFLIB_MAJOR = $(ELFLIB).$(ELF_MAJOR_VERSION)# +# ELFLIB_MAJOR_MINOR = $(ELFLIB).$(ELF_MAJOR_VERSION).$(ELF_MINOR_VERSION)# +ELFLIB = @ELFLIB@ +ELFLIB_MAJOR = @ELFLIB_MAJOR@ +ELFLIB_MAJOR_MINOR = @ELFLIB_MAJOR_MINOR@ + +ELFDIR_ELF_LIB = $(ELFDIR)/$(ELFLIB_MAJOR_MINOR)# + +EXECLIBS = -L$(OBJDIR) -lslang -lm $(TCAPLIB) $(DL_LIB) +EXECDEPS = $(OBJDIR_NORMAL_LIB) + +OFILES = @PROGRAM_OFILES@ +OBJS = @PROGRAM_OBJECTS@ +ELFOBJS = @PROGRAM_ELFOBJECTS@ + +SHELL = /bin/sh + +sltoken_O_DEP = keywhash.c +slarith_O_DEP = slarith.inc +slarrfun_O_DEP = slarrfun.inc +slmisc_O_DEP = slang.h +slstd_C_FLAGS = -DSLANG_DOC_DIR='"$(install_doc_dir)"' +slimport_C_FLAGS = -DMODULE_INSTALL_DIR='"$(MODULE_INSTALL_DIR)"' +sltermin_C_FLAGS = -DMISC_TERMINFO_DIRS='"$(MISC_TERMINFO_DIRS)"' + +#--------------------------------------------------------------------------- +# Rules +#--------------------------------------------------------------------------- +all: $(OBJDIR) $(CONFIG_H) $(OBJDIR_NORMAL_LIB) $(OTHERSTUFF) +elf: $(ELFDIR) $(CONFIG_H) $(ELFDIR_ELF_LIB) + +$(OBJDIR_NORMAL_LIB): $(OBJDIR) $(CONFIG_H) $(OBJS) + -$(RM) $(OBJDIR_NORMAL_LIB) + cd $(OBJDIR); $(AR_CR) $(NORMAL_LIB) $(OFILES) + $(RANLIB) $(OBJDIR_NORMAL_LIB) + @echo "" + @echo $(NORMAL_LIB) created in $(OBJDIR) + +$(ELFDIR_ELF_LIB): $(ELFDIR) $(CONFIG_H) $(ELFOBJS) + -$(RM) $(ELFDIR_ELF_LIB) + cd $(ELFDIR); $(ELF_LINK_CMD) -o $(ELFLIB_MAJOR_MINOR) $(OFILES) $(ELF_DEP_LIBS) + cd $(ELFDIR); $(RM) $(ELFLIB); $(LN) $(ELFLIB_MAJOR_MINOR) $(ELFLIB) + @echo "" + @echo $(ELFLIB_MAJOR_MINOR) created in $(ELFDIR). + @echo The link $(ELFLIB) to $(ELFLIB_MAJOR_MINOR) was also created. + @echo "" +$(OBJDIR) : + -$(MKDIR) $(OBJDIR) +$(ELFDIR) : + -$(MKDIR) $(ELFDIR) +$(CONFIG_H) : sysconf.h + -$(CP) sysconf.h $(CONFIG_H) + +#--------------------------------------------------------------------------- +# Intallation rules +#--------------------------------------------------------------------------- +install: install_basic_lib install_docs +install_basic_lib: $(DEST_LIBDIR) $(DEST_INCDIR) $(OBJDIR_NORMAL_LIB) + @echo installing $(OBJDIR_NORMAL_LIB) in $(DEST_LIBDIR) + $(INSTALL_DATA) $(OBJDIR_NORMAL_LIB) $(DEST_LIBDIR) + $(RANLIB) $(DEST_LIBDIR)/$(NORMAL_LIB) + @echo installing slang.h and slcurses.h in $(DEST_INCDIR) + $(INSTALL_DATA) $(SRCDIR)/slang.h $(DEST_INCDIR) + $(INSTALL_DATA) $(SRCDIR)/slcurses.h $(DEST_INCDIR) +install_docs: $(DEST_DOCDIR) + @for i in $(DOC_FILES); \ + do \ + echo $(INSTALL_DATA) $$i $(DEST_DOCDIR)/; \ + $(INSTALL_DATA) $$i $(DEST_DOCDIR); \ + done +$(DEST_DOCDIR): + $(MKINSDIR) $(DEST_DOCDIR) +$(DEST_INCDIR): + $(MKINSDIR) $(DEST_INCDIR) +$(DEST_LIBDIR): + $(MKINSDIR) $(DEST_LIBDIR) +install-elf: elf install + -$(RM) $(DEST_LIBDIR)/$(ELFLIB) + -$(RM) $(DEST_LIBDIR)/$(ELFLIB_MAJOR) + @echo installing $(ELFLIB_MAJOR_MINOR) in $(DEST_LIBDIR) + $(INSTALL_DATA) $(ELFDIR_ELF_LIB) $(DEST_LIBDIR) + @echo creating symbolic links to $(ELFLIB_MAJOR_MINOR) + -cd $(DEST_LIBDIR); $(LN) $(ELFLIB_MAJOR_MINOR) $(ELFLIB_MAJOR) + -cd $(DEST_LIBDIR); $(LN) $(ELFLIB_MAJOR_MINOR) $(ELFLIB) + @echo "" + @echo $(ELFLIB_MAJOR_MINOR) created in $(DEST_LIBDIR). + @echo The links $(ELFLIB) and $(ELFLIB_MAJOR) to $(ELFLIB_MAJOR_MINOR) were also created. + @echo "" +install-links: + -$(RM) $(DEST_LIBDIR)/$(ELFLIB) + -$(RM) $(DEST_LIBDIR)/$(ELFLIB_MAJOR) + cd $(DEST_LIBDIR); $(LN) $(ELFLIB_MAJOR_MINOR) $(ELFLIB_MAJOR) + cd $(DEST_LIBDIR); $(LN) $(ELFLIB_MAJOR) $(ELFLIB) + @echo + @echo A link $(ELFLIB_MAJOR) to $(ELFLIB_MAJOR_MINOR) was created. + @echo A link $(ELFLIB) to $(ELFLIB_MAJOR) was created. + @echo "" +#--------------------------------------------------------------------------- +# Tests +#--------------------------------------------------------------------------- +runtests: + cd test; $(MAKE) CC="$(CC)" CFLAGS="$(CFLAGS)" TCAPLIB="$(TCAPLIB)" +#--------------------------------------------------------------------------- +# Housekeeping +#--------------------------------------------------------------------------- +elf-clean: + -$(RM) $(ELFDIR)/* +clean: elf-clean + -$(RM) *~ "#"* + -$(RM) $(OBJDIR)/* + -$(RM) $(ELFDIR)/* +distclean: clean + -$(RM_R) $(OBJDIR) $(ELFDIR) Makefile sysconf.h $(CONFIG_H) + +# The symlinks target is for my own private use. It simply creates the object +# directory as a symbolic link to a local disk instead of an NFS mounted one. +symlinks: + -/bin/rm -f $(ARCH)objs + mkdir -p $(HOME)/sys/$(ARCH)/objs/slang/src + ln -s $(HOME)/sys/$(ARCH)/objs/slang/src $(ARCH)objs + @echo "Also try: make elfsymlinks" +elfsymlinks: symlinks + -/bin/rm -f elf$(ARCH)objs + mkdir -p $(HOME)/sys/$(ARCH)/objs/slang/src/elf + ln -s $(HOME)/sys/$(ARCH)/objs/slang/src/elf elf$(ARCH)objs +#--------------------------------------------------------------------------- +# Object Rules : These are created from the configure script (hopefully) +#--------------------------------------------------------------------------- diff --git a/libslang/src/VMSMAKE.COM b/libslang/src/VMSMAKE.COM new file mode 100644 index 0000000..7b745b6 --- /dev/null +++ b/libslang/src/VMSMAKE.COM @@ -0,0 +1,119 @@ +$ ver = f$verify(0) +$! Makefile for VMS +$ Make = "" +$ ccopt="/include=[]" +$ cc = "CC" +$! +$! Check for MMK/MMS +$! +$ If F$Search ("Sys$System:MMS.EXE") .nes. "" Then Make = "MMS" +$ If F$Type (MMK) .eqs. "STRING" Then Make = "MMK" +$! +$! Look for the compiler used +$! +$ if p1.nes."" +$ then +$ if f$locate("G",p1).ne.f$length(p1) then goto gnuc +$ if f$locate("V",p1).ne.f$length(p1) then goto vaxc +$ if f$locate("D",p1).ne.f$length(p1) then goto decc +$ endif +$! +$! Option file for test applications +$! +$ open/write optf client.opt +$ write optf "slang/library" +$! +$DECC: +$ if f$search("SYS$SYSTEM:DECC$COMPILER.EXE").nes."" +$ then +$ write sys$output "DECC compiler found" +$ defs = "FLOAT_TYPE" +$ ccopt = "/decc/prefix=all"+ccopt +$ goto compile +$ endif +$! +$VAXC: +$ if f$search("SYS$SYSTEM:VAXC.EXE").nes."" +$ then +$ write sys$output "VAXC compiler found" +$ defs = "FLOAT_TYPE" +$ write optf "sys$library:vaxcrtl.exe/share" +$ goto compile +$ endif +$! +$GNUC: +$ if f$trnlnm("GNU_CC").nes."" +$ then +$ write sys$output "GNUC compiler found" +$ defs = "FLOAT_TYPE" +$ cc="GCC" +$ ccopt = "/warnings/nocase_hack/nolist/optimize=4"+ccopt +$ write optf "gnu_cc:[000000]gcclib.olb/lib" +$ goto compile +$ endif +$! +$! No compiler found - Warning and Exit +$! +$ close optf +$ type sys$input +FATAL: No C-compiler found - Can't build Slang on this system. + +$ goto The_exit +$! +$COMPILE: +$! +$ close optf +$ files = "slang,slparse,slmath,slstd,slarray,slregexp,slerr" +$ files = files + ",slrline,slgetkey,slvmstty,slkeymap,sltoken,slcurses" +$ files = files + ",slmemcpy,slmemcmp,slmemset,slmemchr,slmisc" +$ files = files + ",sldisply,slsmg,slsearch,slcmd,slmalloc,slclass" +$ files = files + ",slprepr,sltypes,slscroll,slsignal,slkeypad,slerrno" +$ files = files + ",slstruct,slcmplex,slarrfun,slimport,slpath,slarith,slassoc" +$ files = files + ",slcompat,slposdir,slstdio,slproc,sltime,slstrops" +$ files = files + ",slbstr,slpack,slintall,slistruc,slposio,slnspace,slarrmis" +$ files = files + ",slospath,slscanf,slstring" +$! +$! simple make +$! +$ copy slconfig.h config.h +$ purge config.h +$ if (Make .nes. "") +$ then +$ 'Make'/Macro = (cc="''CC'", cflags="''CCOPt'/define=(''defs')") +$ else +$ count = 0 +$ olbf = f$search("slang.olb") +$ if (olbf .eqs. "") then library/object/create slang.olb +$ next_file: +$ f = f$element(count, ",", files) +$ count = count + 1 +$ if (f .eqs. ",") then goto testfiles +$ objf = f$search("''f'.obj") +$ if (objf .eqs. "") then goto compile_it +$ tobj = f$file_attr(objf, "RDT") +$ tc = f$file_attr("''f'.c", "RDT") +$ if (f .eqs. "sysdep") +$ then +$ if ( f$cvtime(tobj) .lts. f$cvtime(f$file_attr("vms.c","RDT"))) - + then goto compile_it +$ endif +$ if (f$cvtime(tc) .lts. f$cvtime(tobj)) then goto next_file +$ compile_it: +$ write sys$output "''CC' ''CCOPT'/define=(''defs') ''f'.c" +$ 'CC' 'CCOPT'/define=('defs') 'f'.c +$ library/replace slang.olb 'f' +$ goto next_file +$ testfiles: +$ purge slang.olb +$ write sys$output "''CC' ''CCOPT'/define=(''defs') calc.c" +$ 'CC' 'CCOPT'/define=('defs') calc.c +$ write sys$output "link/exec=calc calc client.opt/opt" +$ link/exec=calc calc, client.opt/opt +$! write sys$output "''CC' ''CCOPT'/define=(''defs') worm.c" +$! 'CC' 'CCOPT'/define=('defs') worm.c +$! write sys$output "link/exec=worm worm client.opt/opt" +$! link/exec=worm worm, client.opt/opt +$ endif +$The_exit: +$ x = f$verify(ver) +$ exit $status diff --git a/libslang/src/_slang.h b/libslang/src/_slang.h new file mode 100644 index 0000000..03e80df --- /dev/null +++ b/libslang/src/_slang.h @@ -0,0 +1,867 @@ +#ifndef _PRIVATE_SLANG_H_ +#define _PRIVATE_SLANG_H_ +/* header file for S-Lang internal structures that users do not (should not) + need. Use slang.h for that purpose. */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* #include "config.h" */ +#include "jdmacros.h" +#include "sllimits.h" + +#ifdef VMS +# define SLANG_SYSTEM_NAME "_VMS" +#else +# if defined (IBMPC_SYSTEM) +# define SLANG_SYSTEM_NAME "_IBMPC" +# else +# define SLANG_SYSTEM_NAME "_UNIX" +# endif +#endif /* VMS */ + +/* These quantities are main_types for byte-compiled code. They are used + * by the inner_interp routine. The _BC_ means byte-code. + */ + +#define _SLANG_BC_LVARIABLE SLANG_LVARIABLE /* 0x01 */ +#define _SLANG_BC_GVARIABLE SLANG_GVARIABLE /* 0x02 */ +#define _SLANG_BC_IVARIABLE SLANG_IVARIABLE /* 0x03 */ +#define _SLANG_BC_RVARIABLE SLANG_RVARIABLE /* 0x04 */ +#define _SLANG_BC_INTRINSIC SLANG_INTRINSIC /* 0x05 */ +#define _SLANG_BC_FUNCTION SLANG_FUNCTION /* 0x06 */ +#define _SLANG_BC_MATH_UNARY SLANG_MATH_UNARY /* 0x07 */ +#define _SLANG_BC_APP_UNARY SLANG_APP_UNARY /* 0x08 */ +#define _SLANG_BC_ICONST SLANG_ICONSTANT /* 0x09 */ +#define _SLANG_BC_DCONST SLANG_DCONSTANT /* 0x0A */ +#define _SLANG_BC_PVARIABLE SLANG_PVARIABLE /* 0x0B */ +#define _SLANG_BC_PFUNCTION SLANG_PFUNCTION /* 0x0C */ + +#define _SLANG_BC_UNUSED_0x0D 0x0D +#define _SLANG_BC_UNUSED_0x0E 0x0E +#define _SLANG_BC_UNUSED_0x0F 0x0F +#define _SLANG_BC_BINARY 0x10 +#define _SLANG_BC_LITERAL 0x11 /* constant objects */ +#define _SLANG_BC_LITERAL_INT 0x12 +#define _SLANG_BC_LITERAL_STR 0x13 +#define _SLANG_BC_BLOCK 0x14 + +/* These 3 MUST be in this order too ! */ +#define _SLANG_BC_RETURN 0x15 +#define _SLANG_BC_BREAK 0x16 +#define _SLANG_BC_CONTINUE 0x17 + +#define _SLANG_BC_EXCH 0x18 +#define _SLANG_BC_LABEL 0x19 +#define _SLANG_BC_LOBJPTR 0x1A +#define _SLANG_BC_GOBJPTR 0x1B +#define _SLANG_BC_X_ERROR 0x1C +/* These must be in this order */ +#define _SLANG_BC_X_USER0 0x1D +#define _SLANG_BC_X_USER1 0x1E +#define _SLANG_BC_X_USER2 0x1F +#define _SLANG_BC_X_USER3 0x20 +#define _SLANG_BC_X_USER4 0x21 + +#define _SLANG_BC_LITERAL_DBL 0x22 +#define _SLANG_BC_UNUSED_0x23 + +#define _SLANG_BC_CALL_DIRECT 0x24 +#define _SLANG_BC_CALL_DIRECT_FRAME 0x25 +#define _SLANG_BC_UNARY 0x26 +#define _SLANG_BC_UNARY_FUNC 0x27 + +#define _SLANG_BC_UNUSED_0x28 0x28 +#define _SLANG_BC_UNUSED_0x29 0x29 +#define _SLANG_BC_UNUSED_0x2A 0x2A +#define _SLANG_BC_UNUSED_0x2B 0x2B +#define _SLANG_BC_UNUSED_0x2C 0x2C +#define _SLANG_BC_UNUSED_0x2D 0x2D +#define _SLANG_BC_UNUSED_0x2E 0x2E +#define _SLANG_BC_UNUSED_0x2F 0x2F + +#define _SLANG_BC_DEREF_ASSIGN 0x30 +#define _SLANG_BC_SET_LOCAL_LVALUE 0x31 +#define _SLANG_BC_SET_GLOBAL_LVALUE 0x32 +#define _SLANG_BC_SET_INTRIN_LVALUE 0x33 +#define _SLANG_BC_SET_STRUCT_LVALUE 0x34 +#define _SLANG_BC_FIELD 0x35 +#define _SLANG_BC_SET_ARRAY_LVALUE 0x36 + +#define _SLANG_BC_UNUSED_0x37 0x37 +#define _SLANG_BC_UNUSED_0x38 0x38 +#define _SLANG_BC_UNUSED_0x39 0x39 +#define _SLANG_BC_UNUSED_0x3A 0x3A +#define _SLANG_BC_UNUSED_0x3B 0x3B +#define _SLANG_BC_UNUSED_0x3C 0x3C +#define _SLANG_BC_UNUSED_0x3D 0x3D +#define _SLANG_BC_UNUSED_0x3E 0x3E +#define _SLANG_BC_UNUSED_0x3F 0x3F + +#define _SLANG_BC_LINE_NUM 0x40 + +#define _SLANG_BC_UNUSED_0x41 0x41 +#define _SLANG_BC_UNUSED_0x42 0x42 +#define _SLANG_BC_UNUSED_0x43 0x43 +#define _SLANG_BC_UNUSED_0x44 0x44 +#define _SLANG_BC_UNUSED_0x45 0x45 +#define _SLANG_BC_UNUSED_0x46 0x46 +#define _SLANG_BC_UNUSED_0x47 0x47 +#define _SLANG_BC_UNUSED_0x48 0x48 +#define _SLANG_BC_UNUSED_0x49 0x49 +#define _SLANG_BC_UNUSED_0x4A 0x4A +#define _SLANG_BC_UNUSED_0x4B 0x4B +#define _SLANG_BC_UNUSED_0x4C 0x4C +#define _SLANG_BC_UNUSED_0x4D 0x4D +#define _SLANG_BC_UNUSED_0x4E 0x4E +#define _SLANG_BC_UNUSED_0x4F 0x4F + +#define _SLANG_BC_TMP 0x50 + +#define _SLANG_BC_UNUSED_0x51 0x51 +#define _SLANG_BC_UNUSED_0x52 0x52 +#define _SLANG_BC_UNUSED_0x53 0x53 +#define _SLANG_BC_UNUSED_0x54 0x54 +#define _SLANG_BC_UNUSED_0x55 0x55 +#define _SLANG_BC_UNUSED_0x56 0x56 +#define _SLANG_BC_UNUSED_0x57 0x57 +#define _SLANG_BC_UNUSED_0x58 0x58 +#define _SLANG_BC_UNUSED_0x59 0x59 +#define _SLANG_BC_UNUSED_0x5A 0x5A +#define _SLANG_BC_UNUSED_0x5B 0x5B +#define _SLANG_BC_UNUSED_0x5C 0x5C +#define _SLANG_BC_UNUSED_0x5D 0x5D +#define _SLANG_BC_UNUSED_0x5E 0x5E +#define _SLANG_BC_UNUSED_0x5F 0x5F + + +#define _SLANG_BC_LVARIABLE_AGET 0x60 +#define _SLANG_BC_LVARIABLE_APUT 0x61 +#define _SLANG_BC_INTEGER_PLUS 0x62 +#define _SLANG_BC_INTEGER_MINUS 0x63 +#define _SLANG_BC_ARG_LVARIABLE 0x64 +#define _SLANG_BC_EARG_LVARIABLE 0x65 + +#define _SLANG_BC_UNUSED_0x66 0x66 +#define _SLANG_BC_UNUSED_0x67 0x67 +#define _SLANG_BC_UNUSED_0x68 0x68 +#define _SLANG_BC_UNUSED_0x69 0x69 +#define _SLANG_BC_UNUSED_0x6A 0x6A +#define _SLANG_BC_UNUSED_0x6B 0x6B +#define _SLANG_BC_UNUSED_0x6C 0x6C +#define _SLANG_BC_UNUSED_0x6D 0x6D +#define _SLANG_BC_UNUSED_0x6E 0x6E +#define _SLANG_BC_UNUSED_0x6F 0x6F + +#define _SLANG_BC_UNUSED_0x70 0x70 +#define _SLANG_BC_UNUSED_0x71 0x71 +#define _SLANG_BC_UNUSED_0x72 0x72 +#define _SLANG_BC_UNUSED_0x73 0x73 +#define _SLANG_BC_UNUSED_0x74 0x74 +#define _SLANG_BC_UNUSED_0x75 0x75 +#define _SLANG_BC_UNUSED_0x76 0x76 +#define _SLANG_BC_UNUSED_0x77 0x77 +#define _SLANG_BC_UNUSED_0x78 0x78 +#define _SLANG_BC_UNUSED_0x79 0x79 +#define _SLANG_BC_UNUSED_0x7A 0x7A +#define _SLANG_BC_UNUSED_0x7B 0x7B +#define _SLANG_BC_UNUSED_0x7C 0x7C +#define _SLANG_BC_UNUSED_0x7D 0x7D +#define _SLANG_BC_UNUSED_0x7E 0x7E +#define _SLANG_BC_UNUSED_0x7F 0x7F + +/* These are used only when compiled with USE_COMBINED_BYTECODES */ +#define _SLANG_BC_CALL_DIRECT_INTRINSIC 0x80 +#define _SLANG_BC_INTRINSIC_CALL_DIRECT 0x81 +#define _SLANG_BC_CALL_DIRECT_LSTR 0x82 +#define _SLANG_BC_CALL_DIRECT_SLFUN 0x83 +#define _SLANG_BC_CALL_DIRECT_INTRSTOP 0x84 +#define _SLANG_BC_INTRINSIC_STOP 0x85 +#define _SLANG_BC_CALL_DIRECT_EARG_LVAR 0x86 +#define _SLANG_BC_CALL_DIRECT_LINT 0x87 +#define _SLANG_BC_CALL_DIRECT_LVAR 0x88 +#define _SLANG_BC_LLVARIABLE_BINARY 0x89 +#define _SLANG_BC_LGVARIABLE_BINARY 0x8A +#define _SLANG_BC_GLVARIABLE_BINARY 0x8B +#define _SLANG_BC_GGVARIABLE_BINARY 0x8C +#define _SLANG_BC_LIVARIABLE_BINARY 0x8D +#define _SLANG_BC_LDVARIABLE_BINARY 0x8E +#define _SLANG_BC_ILVARIABLE_BINARY 0x8F +#define _SLANG_BC_DLVARIABLE_BINARY 0x90 +#define _SLANG_BC_LVARIABLE_BINARY 0x91 +#define _SLANG_BC_GVARIABLE_BINARY 0x92 +#define _SLANG_BC_LITERAL_INT_BINARY 0x93 +#define _SLANG_BC_LITERAL_DBL_BINARY 0x94 + + +#define _SLANG_BC_LVARIABLE_COMBINED 0xA0 +#define _SLANG_BC_GVARIABLE_COMBINED 0xA1 +#define _SLANG_BC_LITERAL_COMBINED 0xA2 + +/* Byte-Code Sub Types (_BCST_) */ + +/* These are sub_types of _SLANG_BC_BLOCK */ +#define _SLANG_BCST_ERROR_BLOCK 0x01 +#define _SLANG_BCST_EXIT_BLOCK 0x02 +#define _SLANG_BCST_USER_BLOCK0 0x03 +#define _SLANG_BCST_USER_BLOCK1 0x04 +#define _SLANG_BCST_USER_BLOCK2 0x05 +#define _SLANG_BCST_USER_BLOCK3 0x06 +#define _SLANG_BCST_USER_BLOCK4 0x07 +/* The user blocks MUST be in the above order */ +#define _SLANG_BCST_LOOP 0x10 +#define _SLANG_BCST_WHILE 0x11 +#define _SLANG_BCST_FOR 0x12 +#define _SLANG_BCST_FOREVER 0x13 +#define _SLANG_BCST_CFOR 0x14 +#define _SLANG_BCST_DOWHILE 0x15 +#define _SLANG_BCST_FOREACH 0x16 + +#define _SLANG_BCST_IF 0x20 +#define _SLANG_BCST_IFNOT 0x21 +#define _SLANG_BCST_ELSE 0x22 +#define _SLANG_BCST_ANDELSE 0x23 +#define _SLANG_BCST_ORELSE 0x24 +#define _SLANG_BCST_SWITCH 0x25 +#define _SLANG_BCST_NOTELSE 0x26 + +/* assignment (_SLANG_BC_SET_*_LVALUE) subtypes. The order MUST correspond + * to the assignment token order with the ASSIGN_TOKEN as the first! + */ +#define _SLANG_BCST_ASSIGN 0x01 +#define _SLANG_BCST_PLUSEQS 0x02 +#define _SLANG_BCST_MINUSEQS 0x03 +#define _SLANG_BCST_TIMESEQS 0x04 +#define _SLANG_BCST_DIVEQS 0x05 +#define _SLANG_BCST_BOREQS 0x06 +#define _SLANG_BCST_BANDEQS 0x07 +#define _SLANG_BCST_PLUSPLUS 0x08 +#define _SLANG_BCST_POST_PLUSPLUS 0x09 +#define _SLANG_BCST_MINUSMINUS 0x0A +#define _SLANG_BCST_POST_MINUSMINUS 0x0B + +/* These use SLANG_PLUS, SLANG_MINUS, SLANG_PLUSPLUS, etc... */ + +typedef union +{ +#if SLANG_HAS_FLOAT + double double_val; + float float_val; +#endif + long long_val; + unsigned long ulong_val; + VOID_STAR ptr_val; + char *s_val; + int int_val; + unsigned int uint_val; + SLang_MMT_Type *ref; + SLang_Name_Type *n_val; + struct _SLang_Struct_Type *struct_val; + struct _SLang_Array_Type *array_val; + short short_val; + unsigned short ushort_val; + char char_val; + unsigned char uchar_val; +} +_SL_Object_Union_Type; + +typedef struct _SLang_Object_Type +{ + SLtype data_type; /* SLANG_INT_TYPE, ... */ + _SL_Object_Union_Type v; +} +SLang_Object_Type; + +struct _SLang_MMT_Type +{ + SLtype data_type; /* int, string, etc... */ + VOID_STAR user_data; /* address of user structure */ + unsigned int count; /* number of references */ +}; + +extern int _SLang_pop_object_of_type (SLtype, SLang_Object_Type *, int); + +typedef struct +{ + char *name; /* slstring */ + SLang_Object_Type obj; +} +_SLstruct_Field_Type; + +typedef struct _SLang_Struct_Type +{ + _SLstruct_Field_Type *fields; + unsigned int nfields; /* number used */ + unsigned int num_refs; +} +_SLang_Struct_Type; + +extern void _SLstruct_delete_struct (_SLang_Struct_Type *); +extern int _SLang_push_struct (_SLang_Struct_Type *); +extern int _SLang_pop_struct (_SLang_Struct_Type **); +extern int _SLstruct_init (void); +/* extern int _SLstruct_get_field (char *); */ +extern int _SLstruct_define_struct (void); +extern int _SLstruct_define_typedef (void); + +struct _SLang_Ref_Type +{ + int is_global; + union + { + SLang_Name_Type *nt; + SLang_Object_Type *local_obj; + } + v; +}; + +extern int _SLang_dereference_ref (SLang_Ref_Type *); +extern int _SLang_deref_assign (SLang_Ref_Type *); +extern int _SLang_push_ref (int, VOID_STAR); + +extern int _SL_increment_frame_pointer (void); +extern int _SL_decrement_frame_pointer (void); + +extern int SLang_pop(SLang_Object_Type *); +extern void SLang_free_object (SLang_Object_Type *); +extern int _SLanytype_typecast (SLtype, VOID_STAR, unsigned int, + SLtype, VOID_STAR); +extern void _SLstring_intrinsic (void); + + +/* These functions are used to create slstrings of a fixed length. Be + * very careful how they are used. In particular, if len bytes are allocated, + * then the string must be len characters long, no more and no less. + */ +extern char *_SLallocate_slstring (unsigned int); +extern char *_SLcreate_via_alloced_slstring (char *, unsigned int); +extern void _SLunallocate_slstring (char *, unsigned int); +extern int _SLpush_alloced_slstring (char *, unsigned int); + +typedef struct +{ + char **buf; + unsigned int max_num; + unsigned int num; + unsigned int delta_num; +} +_SLString_List_Type; +extern int _SLstring_list_append (_SLString_List_Type *, char *); +extern int _SLstring_list_init (_SLString_List_Type *, unsigned int, unsigned int); +extern void _SLstring_list_delete (_SLString_List_Type *); +extern int _SLstring_list_push (_SLString_List_Type *); + +/* This function assumes that s is an slstring. */ +extern char *_SLstring_dup_slstring (char *); +extern int _SLang_dup_and_push_slstring (char *); + + +extern int _SLang_init_import (void); + +/* This function checks to see if the referenced object is initialized */ +extern int _SLang_is_ref_initialized (SLang_Ref_Type *); +extern int _SLcheck_identifier_syntax (char *); +extern int _SLang_uninitialize_ref (SLang_Ref_Type *); + +extern int _SLpush_slang_obj (SLang_Object_Type *); + +extern char *_SLexpand_escaped_char(char *, char *); +extern void _SLexpand_escaped_string (char *, char *, char *); + +/* returns a pointer to an SLstring string-- use SLang_free_slstring */ +extern char *_SLstringize_object (SLang_Object_Type *); +extern int _SLdump_objects (char *, SLang_Object_Type *, unsigned int, int); + +extern SLang_Object_Type *_SLang_get_run_stack_pointer (void); +extern SLang_Object_Type *_SLang_get_run_stack_base (void); +extern int _SLang_dump_stack (void); + +struct _SLang_NameSpace_Type +{ + struct _SLang_NameSpace_Type *next; + char *name; /* this is the load_type name */ + char *namespace_name; /* this name is assigned by implements */ + unsigned int table_size; + SLang_Name_Type **table; +}; +extern SLang_NameSpace_Type *_SLns_allocate_namespace (char *, unsigned int); +extern SLang_NameSpace_Type *_SLns_find_namespace (char *); +extern int _SLns_set_namespace_name (SLang_NameSpace_Type *, char *); +extern SLang_Array_Type *_SLnspace_apropos (SLang_NameSpace_Type *, char *, unsigned int); +extern void _SLang_use_namespace_intrinsic (char *name); +extern char *_SLang_cur_namespace_intrinsic (void); +extern SLang_Array_Type *_SLang_apropos (char *, char *, unsigned int); +extern void _SLang_implements_intrinsic (char *); +extern SLang_Array_Type *_SLns_list_namespaces (void); + +extern int _SLang_Trace; +extern int _SLstack_depth(void); +extern char *_SLang_current_function_name (void); + +extern int _SLang_trace_fun(char *); +extern int _SLang_Compile_Line_Num_Info; + +extern char *_SLstring_dup_hashed_string (char *, unsigned long); +extern unsigned long _SLcompute_string_hash (char *); +extern char *_SLstring_make_hashed_string (char *, unsigned int, unsigned long *); +extern void _SLfree_hashed_string (char *, unsigned int, unsigned long); +unsigned long _SLstring_hash (unsigned char *, unsigned char *); +extern int _SLinit_slcomplex (void); + +extern int _SLang_init_slstrops (void); +extern int _SLstrops_do_sprintf_n (int); +extern int _SLang_sscanf (void); +extern double _SLang_atof (char *); +extern int _SLang_init_bstring (void); +extern int _SLang_init_sltime (void); +extern void _SLpack (void); +extern void _SLunpack (char *, SLang_BString_Type *); +extern void _SLpack_pad_format (char *); +extern unsigned int _SLpack_compute_size (char *); +extern int _SLusleep (unsigned long); + +/* frees upon error. NULL __NOT__ ok. */ +extern int _SLang_push_slstring (char *); + +extern SLtype _SLarith_promote_type (SLtype); +extern int _SLarith_get_precedence (SLtype); +extern int _SLarith_typecast (SLtype, VOID_STAR, unsigned int, + SLtype, VOID_STAR); + +extern int SLang_push(SLang_Object_Type *); +extern int SLadd_global_variable (char *); +extern void _SLang_clear_error (void); + +extern int _SLdo_pop (void); +extern unsigned int _SLsys_getkey (void); +extern int _SLsys_input_pending (int); +#ifdef IBMPC_SYSTEM +extern unsigned int _SLpc_convert_scancode (unsigned int, unsigned int, int); +#define _SLTT_KEY_SHIFT 1 +#define _SLTT_KEY_CTRL 2 +#define _SLTT_KEY_ALT 4 +#endif + +typedef struct _SLterminfo_Type SLterminfo_Type; +extern SLterminfo_Type *_SLtt_tigetent (char *); +extern char *_SLtt_tigetstr (SLterminfo_Type *, char *); +extern int _SLtt_tigetnum (SLterminfo_Type *, char *); +extern int _SLtt_tigetflag (SLterminfo_Type *, char *); + +#if SLTT_HAS_NON_BCE_SUPPORT +extern int _SLtt_get_bce_color_offset (void); +#endif +extern void (*_SLtt_color_changed_hook)(void); + +extern unsigned char SLang_Input_Buffer [SL_MAX_INPUT_BUFFER_LEN]; + +extern int _SLregister_types (void); +extern SLang_Class_Type *_SLclass_get_class (SLtype); +extern VOID_STAR _SLclass_get_ptr_to_value (SLang_Class_Type *, SLang_Object_Type *); +extern void _SLclass_type_mismatch_error (SLtype, SLtype); +extern int _SLclass_init (void); +extern int _SLclass_copy_class (SLtype, SLtype); + +extern int (*_SLclass_get_typecast (SLtype, SLtype, int)) +(SLtype, VOID_STAR, unsigned int, + SLtype, VOID_STAR); + +extern int (*_SLclass_get_binary_fun (int, SLang_Class_Type *, SLang_Class_Type *, SLang_Class_Type **, int)) +(int, + SLtype, VOID_STAR, unsigned int, + SLtype, VOID_STAR, unsigned int, + VOID_STAR); + +extern int (*_SLclass_get_unary_fun (int, SLang_Class_Type *, SLang_Class_Type **, int)) +(int, SLtype, VOID_STAR, unsigned int, VOID_STAR); + +extern int _SLarith_register_types (void); +extern SLtype _SLarith_Arith_Types []; + +extern int _SLang_is_arith_type (SLtype); +extern void _SLang_set_arith_type (SLtype, unsigned char); +#if _SLANG_OPTIMIZE_FOR_SPEED +extern int _SLang_get_class_type (SLtype); +extern void _SLang_set_class_type (SLtype, SLtype); +#endif +extern int _SLarith_bin_op (SLang_Object_Type *, SLang_Object_Type *, int); + +extern int _SLarray_add_bin_op (SLtype); + +extern int _SLang_call_funptr (SLang_Name_Type *); +extern void _SLset_double_format (char *); +extern SLang_Name_Type *_SLlocate_global_name (char *); +extern SLang_Name_Type *_SLlocate_name (char *); + +extern char *_SLdefines[]; + +#define SL_ERRNO_NOT_IMPLEMENTED 0x7FFF +extern int _SLerrno_errno; +extern int _SLerrno_init (void); + +extern int _SLstdio_fdopen (char *, int, char *); + +extern void _SLstruct_pop_args (int *); +extern void _SLstruct_push_args (SLang_Array_Type *); + +extern int _SLarray_aput (void); +extern int _SLarray_aget (void); +extern int _SLarray_inline_implicit_array (void); +extern int _SLarray_inline_array (void); +extern int _SLarray_wildcard_array (void); + +extern int +_SLarray_typecast (SLtype, VOID_STAR, unsigned int, + SLtype, VOID_STAR, int); + +extern int _SLarray_aput_transfer_elem (SLang_Array_Type *, int *, + VOID_STAR, unsigned int, int); +extern int _SLarray_aget_transfer_elem (SLang_Array_Type *, int *, + VOID_STAR, unsigned int, int); +extern void _SLarray_free_array_elements (SLang_Class_Type *, VOID_STAR, unsigned int); + +extern SLang_Foreach_Context_Type * +_SLarray_cl_foreach_open (SLtype, unsigned int); +extern void _SLarray_cl_foreach_close (SLtype, SLang_Foreach_Context_Type *); +extern int _SLarray_cl_foreach (SLtype, SLang_Foreach_Context_Type *); + +extern int _SLarray_matrix_multiply (void); +extern void (*_SLang_Matrix_Multiply)(void); + +extern int _SLarray_next_index (int *, int *, unsigned int); + +extern int _SLarray_init_slarray (void); +extern SLang_Array_Type * +SLang_create_array1 (SLtype, int, VOID_STAR, int *, unsigned int, int); + +extern int _SLassoc_aput (SLtype, unsigned int); +extern int _SLassoc_aget (SLtype, unsigned int); + +extern int _SLcompile_push_context (SLang_Load_Type *); +extern int _SLcompile_pop_context (void); +extern int _SLang_Auto_Declare_Globals; + +typedef struct +{ + union + { + long long_val; + char *s_val; /* Used for IDENT_TOKEN, FLOAT, etc... */ + SLang_BString_Type *b_val; + } v; + int free_sval_flag; + unsigned int num_refs; + unsigned long hash; +#if _SLANG_HAS_DEBUG_CODE + int line_number; +#endif + SLtype type; +} +_SLang_Token_Type; + +extern void _SLcompile (_SLang_Token_Type *); +extern void (*_SLcompile_ptr)(_SLang_Token_Type *); + +/* slmisc.c */ +extern char *_SLskip_whitespace (char *s); + +/* slospath.c */ +extern char *_SLpath_find_file (char *); /* slstring returned */ + + +/* *** TOKENS *** */ + +/* Note that that tokens corresponding to ^J, ^M, and ^Z should not be used. + * This is because a file that contains any of these characters will + * have an OS dependent interpretation, e.g., ^Z is EOF on MSDOS. + */ + +/* Special tokens */ +#define ILLEGAL_TOKEN 0x00 /* no token has this value */ +#define EOF_TOKEN 0x01 +#define RPN_TOKEN 0x02 +#define NL_TOKEN 0x03 +#define NOP_TOKEN 0x05 +#define FARG_TOKEN 0x06 +#define TMP_TOKEN 0x07 + +#define RESERVED1_TOKEN 0x0A /* \n */ +#define RESERVED2_TOKEN 0x0D /* \r */ + +/* Literal tokens */ +#define CHAR_TOKEN 0x10 +#define UCHAR_TOKEN 0x11 +#define SHORT_TOKEN 0x12 +#define USHORT_TOKEN 0x13 +#define INT_TOKEN 0x14 +#define UINT_TOKEN 0x15 +#define LONG_TOKEN 0x16 +#define ULONG_TOKEN 0x17 +#define IS_INTEGER_TOKEN(x) ((x >= CHAR_TOKEN) && (x <= ULONG_TOKEN)) +#define FLOAT_TOKEN 0x18 +#define DOUBLE_TOKEN 0x19 +#define RESERVED3_TOKEN 0x1A /* ^Z */ +#define COMPLEX_TOKEN 0x1B +#define STRING_TOKEN 0x1C +#define BSTRING_TOKEN 0x1D +#define _BSTRING_TOKEN 0x1E /* byte-compiled BSTRING */ +#define ESC_STRING_TOKEN 0x1F + +/* Tokens that can be LVALUES */ +#define IDENT_TOKEN 0x20 +#define ARRAY_TOKEN 0x21 +#define DOT_TOKEN 0x22 +#define METHOD_TOKEN 0x24 +#define IS_LVALUE_TOKEN (((t) <= METHOD_TOKEN) && ((t) >= IDENT_TOKEN)) +/* do not use these values */ +#define RESERVED4_TOKEN 0x23 /* # */ +#define RESERVED5_TOKEN 0x25 /* % */ + +/* Flags for struct fields */ +#define STATIC_TOKEN 0x26 +#define READONLY_TOKEN 0x27 +#define PRIVATE_TOKEN 0x28 +#define PUBLIC_TOKEN 0x29 + +/* Punctuation tokens */ +#define OBRACKET_TOKEN 0x2a +#define CBRACKET_TOKEN 0x2b +#define OPAREN_TOKEN 0x2c +#define CPAREN_TOKEN 0x2d +#define OBRACE_TOKEN 0x2e +#define CBRACE_TOKEN 0x2f + +#define COMMA_TOKEN 0x31 +#define SEMICOLON_TOKEN 0x32 +#define COLON_TOKEN 0x33 +#define NAMESPACE_TOKEN 0x34 + +/* Operators */ +#define POW_TOKEN 0x38 + +/* The order here must match the order in the Binop_Level table in slparse.c */ +#define FIRST_BINARY_OP 0x39 +#define ADD_TOKEN 0x39 +#define SUB_TOKEN 0x3a +#define TIMES_TOKEN 0x3b +#define DIV_TOKEN 0x3c +#define LT_TOKEN 0x3d +#define LE_TOKEN 0x3e +#define GT_TOKEN 0x3f +#define GE_TOKEN 0x40 +#define EQ_TOKEN 0x41 +#define NE_TOKEN 0x42 +#define AND_TOKEN 0x43 +#define OR_TOKEN 0x44 +#define MOD_TOKEN 0x45 +#define BAND_TOKEN 0x46 +#define SHL_TOKEN 0x47 +#define SHR_TOKEN 0x48 +#define BXOR_TOKEN 0x49 +#define BOR_TOKEN 0x4a +#define POUND_TOKEN 0x4b /* matrix multiplication */ + +#define LAST_BINARY_OP 0x4b +#define IS_BINARY_OP(t) ((t >= FIRST_BINARY_OP) && (t <= LAST_BINARY_OP)) + +/* unary tokens -- but not all of them (see grammar) */ +#define DEREF_TOKEN 0x4d +#define NOT_TOKEN 0x4e +#define BNOT_TOKEN 0x4f + +#define IS_INTERNAL_FUNC(t) ((t >= 0x50) && (t <= 0x56)) +#define POP_TOKEN 0x50 +#define CHS_TOKEN 0x51 +#define SIGN_TOKEN 0x52 +#define ABS_TOKEN 0x53 +#define SQR_TOKEN 0x54 +#define MUL2_TOKEN 0x55 +#define EXCH_TOKEN 0x56 + +/* Assignment tokens. Note: these must appear with sequential values. + * The order here must match the specific lvalue assignments below. + * These tokens are used by rpn routines in slang.c. slparse.c maps them + * onto the specific lvalue tokens while parsing infix. + * Also the assignment _SLANG_BCST_ assumes this order + */ +#define ASSIGN_TOKEN 0x57 +#define PLUSEQS_TOKEN 0x58 +#define MINUSEQS_TOKEN 0x59 +#define TIMESEQS_TOKEN 0x5A +#define DIVEQS_TOKEN 0x5B +#define BOREQS_TOKEN 0x5C +#define BANDEQS_TOKEN 0x5D +#define PLUSPLUS_TOKEN 0x5E +#define POST_PLUSPLUS_TOKEN 0x5F +#define MINUSMINUS_TOKEN 0x60 +#define POST_MINUSMINUS_TOKEN 0x61 + +/* Directives */ +#define FIRST_DIRECTIVE_TOKEN 0x62 +#define IFNOT_TOKEN 0x62 +#define IF_TOKEN 0x63 +#define ELSE_TOKEN 0x64 +#define FOREVER_TOKEN 0x65 +#define WHILE_TOKEN 0x66 +#define FOR_TOKEN 0x67 +#define _FOR_TOKEN 0x68 +#define LOOP_TOKEN 0x69 +#define SWITCH_TOKEN 0x6A +#define DOWHILE_TOKEN 0x6B +#define ANDELSE_TOKEN 0x6C +#define ORELSE_TOKEN 0x6D +#define ERRBLK_TOKEN 0x6E +#define EXITBLK_TOKEN 0x6F +/* These must be sequential */ +#define USRBLK0_TOKEN 0x70 +#define USRBLK1_TOKEN 0x71 +#define USRBLK2_TOKEN 0x72 +#define USRBLK3_TOKEN 0x73 +#define USRBLK4_TOKEN 0x74 + +#define CONT_TOKEN 0x75 +#define BREAK_TOKEN 0x76 +#define RETURN_TOKEN 0x77 + +#define CASE_TOKEN 0x78 +#define DEFINE_TOKEN 0x79 +#define DO_TOKEN 0x7a +#define VARIABLE_TOKEN 0x7b +#define GVARIABLE_TOKEN 0x7c +#define _REF_TOKEN 0x7d +#define PUSH_TOKEN 0x7e +#define STRUCT_TOKEN 0x7f +#define TYPEDEF_TOKEN 0x80 +#define NOTELSE_TOKEN 0x81 +#define DEFINE_STATIC_TOKEN 0x82 +#define FOREACH_TOKEN 0x83 +#define USING_TOKEN 0x84 +#define DEFINE_PRIVATE_TOKEN 0x85 +#define DEFINE_PUBLIC_TOKEN 0x86 + +/* Note: the order here must match the order of the generic assignment tokens. + * Also, the first token of each group must be the ?_ASSIGN_TOKEN. + * slparse.c exploits this order, as well as slang.h. + */ +#define FIRST_ASSIGN_TOKEN 0x90 +#define _STRUCT_ASSIGN_TOKEN 0x90 +#define _STRUCT_PLUSEQS_TOKEN 0x91 +#define _STRUCT_MINUSEQS_TOKEN 0x92 +#define _STRUCT_TIMESEQS_TOKEN 0x93 +#define _STRUCT_DIVEQS_TOKEN 0x94 +#define _STRUCT_BOREQS_TOKEN 0x95 +#define _STRUCT_BANDEQS_TOKEN 0x96 +#define _STRUCT_PLUSPLUS_TOKEN 0x97 +#define _STRUCT_POST_PLUSPLUS_TOKEN 0x98 +#define _STRUCT_MINUSMINUS_TOKEN 0x99 +#define _STRUCT_POST_MINUSMINUS_TOKEN 0x9A + +#define _ARRAY_ASSIGN_TOKEN 0xA0 +#define _ARRAY_PLUSEQS_TOKEN 0xA1 +#define _ARRAY_MINUSEQS_TOKEN 0xA2 +#define _ARRAY_TIMESEQS_TOKEN 0xA3 +#define _ARRAY_DIVEQS_TOKEN 0xA4 +#define _ARRAY_BOREQS_TOKEN 0xA5 +#define _ARRAY_BANDEQS_TOKEN 0xA6 +#define _ARRAY_PLUSPLUS_TOKEN 0xA7 +#define _ARRAY_POST_PLUSPLUS_TOKEN 0xA8 +#define _ARRAY_MINUSMINUS_TOKEN 0xA9 +#define _ARRAY_POST_MINUSMINUS_TOKEN 0xAA + +#define _SCALAR_ASSIGN_TOKEN 0xB0 +#define _SCALAR_PLUSEQS_TOKEN 0xB1 +#define _SCALAR_MINUSEQS_TOKEN 0xB2 +#define _SCALAR_TIMESEQS_TOKEN 0xB3 +#define _SCALAR_DIVEQS_TOKEN 0xB4 +#define _SCALAR_BOREQS_TOKEN 0xB5 +#define _SCALAR_BANDEQS_TOKEN 0xB6 +#define _SCALAR_PLUSPLUS_TOKEN 0xB7 +#define _SCALAR_POST_PLUSPLUS_TOKEN 0xB8 +#define _SCALAR_MINUSMINUS_TOKEN 0xB9 +#define _SCALAR_POST_MINUSMINUS_TOKEN 0xBA + +#define _DEREF_ASSIGN_TOKEN 0xC0 +#define _DEREF_PLUSEQS_TOKEN 0xC1 +#define _DEREF_MINUSEQS_TOKEN 0xC2 +#define _DEREF_TIMESEQS_TOKEN 0xC3 +#define _DEREF_DIVEQS_TOKEN 0xC4 +#define _DEREF_BOREQS_TOKEN 0xC5 +#define _DEREF_BANDEQS_TOKEN 0xC6 +#define _DEREF_PLUSPLUS_TOKEN 0xC7 +#define _DEREF_POST_PLUSPLUS_TOKEN 0xC8 +#define _DEREF_MINUSMINUS_TOKEN 0xC9 +#define _DEREF_POST_MINUSMINUS_TOKEN 0xCA + +#define LAST_ASSIGN_TOKEN 0xCA +#define IS_ASSIGN_TOKEN(t) (((t)>=FIRST_ASSIGN_TOKEN)&&((t)<=LAST_ASSIGN_TOKEN)) + +#define _INLINE_ARRAY_TOKEN 0xE0 +#define _INLINE_IMPLICIT_ARRAY_TOKEN 0xE1 +#define _NULL_TOKEN 0xE2 +#define _INLINE_WILDCARD_ARRAY_TOKEN 0xE3 + +#define LINE_NUM_TOKEN 0xFC +#define ARG_TOKEN 0xFD +#define EARG_TOKEN 0xFE +#define NO_OP_LITERAL 0xFF + +typedef struct +{ + /* sltoken.c */ + /* SLang_eval_object */ + SLang_Load_Type *llt; + SLPreprocess_Type *this_slpp; + /* prep_get_char() */ + char *input_line; + char cchar; + /* get_token() */ + int want_nl_token; + + /* slparse.c */ + _SLang_Token_Type ctok; + int block_depth; + int assignment_expression; + + /* slang.c : SLcompile() */ + _SLang_Token_Type save_token; + _SLang_Token_Type next_token; + void (*slcompile_ptr)(_SLang_Token_Type *); +} +_SLEval_Context; + +extern int _SLget_token (_SLang_Token_Type *); +extern void _SLparse_error (char *, _SLang_Token_Type *, int); +extern void _SLparse_start (SLang_Load_Type *); +extern int _SLget_rpn_token (_SLang_Token_Type *); +extern void _SLcompile_byte_compiled (void); + +extern int (*_SLprep_eval_hook) (char *); + +#ifdef HAVE_VSNPRINTF +#define _SLvsnprintf vsnprintf +#else +extern int _SLvsnprintf (char *, unsigned int, char *, va_list); +#endif + +#ifdef HAVE_SNPRINTF +# define _SLsnprintf snprintf +#else +extern int _SLsnprintf (char *, unsigned int, char *, ...); +#endif + +extern int _SLsecure_issetugid (void); +extern char *_SLsecure_getenv (char *); + + +#undef _INLINE_ +#if defined(__GNUC__) && _SLANG_USE_INLINE_CODE +# define _INLINE_ __inline__ +#else +# define _INLINE_ +#endif + + +#endif /* _PRIVATE_SLANG_H_ */ diff --git a/libslang/src/calc.c b/libslang/src/calc.c new file mode 100644 index 0000000..6dde654 --- /dev/null +++ b/libslang/src/calc.c @@ -0,0 +1,225 @@ +/* This is a simple demo program for the S-Lang interpreter. */ + +#include "config.h" +#include +#include +#ifdef HAVE_STDLIB_H +# include +#endif + +#define BENCHMARK_TESTING 0 + +#if BENCHMARK_TESTING +# include +# include +# include +#endif + +#include "slang.h" + +static int open_readline (void); +static void close_readline (void); + +static void help (void) +{ + puts("ALL statements MUST be terminated with a ';' character, e.g., quit();\n"); + puts("Available functions:"); + puts(" cos, sin, tan, atan, acos, asin, exp, log, sqrt, fabs, log10, pow, PI, E"); + puts("\nas well as other intrinsic S-Lang functions."); + puts("See S-Lang language documentation for further details.\n"); + SLang_run_hooks ("calc_help", 0); +} + +/* The following three functions will be callable from the interpreter */ +static void quit_calc (void) +{ + close_readline (); + exit (SLang_Error); +} + +static void exit_calc (int *status) +{ + close_readline (); + exit (*status); +} + + +/* Now here is a table that provides the link between the above functions and + the S-Lang interpreter */ +static SLang_Intrin_Fun_Type Calc_Intrinsics [] = +{ + MAKE_INTRINSIC("quit", quit_calc, SLANG_VOID_TYPE, 0), + MAKE_INTRINSIC_I("exit", exit_calc, SLANG_VOID_TYPE), + MAKE_INTRINSIC("help", help, SLANG_VOID_TYPE, 0), + SLANG_END_INTRIN_FUN_TABLE +}; + +typedef struct +{ + int i_value; + char *s_value; + double d_value; +} +My_Struct_Type; + +static My_Struct_Type My_Struct = +{ + -41, + NULL, + 7.18 +}; + +static My_Struct_Type *My_Struct_Ptr = &My_Struct; + +static SLang_IStruct_Field_Type My_Struct_Field_Table [] = +{ + MAKE_ISTRUCT_FIELD(My_Struct_Type, i_value, "i", SLANG_INT_TYPE, 0), + MAKE_ISTRUCT_FIELD(My_Struct_Type, s_value, "s", SLANG_STRING_TYPE, 0), + MAKE_ISTRUCT_FIELD(My_Struct_Type, d_value, "d", SLANG_DOUBLE_TYPE, 0), + SLANG_END_ISTRUCT_TABLE +}; + + +static int add_my_struct_type (void) +{ + return SLadd_istruct_table (My_Struct_Field_Table, + (VOID_STAR) &My_Struct_Ptr, + "MyS"); +} + +static int take_input (void); + +int main (int argc, char **argv) +{ + if ((-1 == SLang_init_all ()) + /* || (-1 == SLang_init_import ()) / * dynamic linking */ + || (-1 == add_my_struct_type ()) + || (-1 == SLadd_intrin_fun_table (Calc_Intrinsics, NULL))) + { + fprintf(stderr, "Unable to initialize S-Lang.\n"); + exit (1); + } + + if (-1 == open_readline ()) + return SLang_Error; + + SLang_Traceback = 1; + + if (argc == 1) + SLang_load_file("calc.sl"); + + while (--argc && !SLang_Error) + { + argv++; + SLang_load_file (*argv); + } + + fputs("Type 'help();' for help and a list of available functions.\n", stdout); + fputs("All statements must end with a ';' character, e.g, 2*7+3;\n", stdout); + fputs("\nType `quit;' to exit this program.\n", stdout); + + while (1) + { + if (SLang_Error) + { + SLang_doerror (NULL); + SLang_restart (1); + } + + SLKeyBoard_Quit = SLang_Error = 0; + take_input (); + } +} + +/* For a detailed explanation of all of this, see slang/demo/useropen.c */ + +static SLang_RLine_Info_Type Calc_RLI; +static unsigned char Calc_RLI_Buf[256]; +SLang_Load_Type *Readline_Load_Object; + +static char *read_using_readline (SLang_Load_Type *x) +{ + int n; + static char *input_hook = "calc_take_input_hook"; + + Calc_RLI_Buf[0] = 0; + + if (x->parse_level == 0) + { + if ((input_hook != NULL) + && (-1 == SLang_run_hooks (input_hook, 0))) + { + input_hook = NULL; + return NULL; + } + + Calc_RLI.prompt = "Calc> "; + } + else Calc_RLI.prompt = " "; + + n = SLang_read_line (&Calc_RLI); + putc ('\n', stdout); fflush (stdout); + + if (n < 0) return NULL; + if ((n == 0) + && (SLang_Last_Key_Char == SLang_RL_EOF_Char)) + return "quit;"; + + SLang_rline_save_line (&Calc_RLI); + return (char *) Calc_RLI_Buf; +} + +static int open_readline (void) +{ + if (SLang_init_tty (-1, 0, 1)) + { + fprintf(stderr, "Unable to initialize tty.\n"); + return -1; + } + SLang_set_abort_signal (NULL); + + Calc_RLI.buf = Calc_RLI_Buf; + Calc_RLI.buf_len = 255; + Calc_RLI.tab = 8; + Calc_RLI.edit_width = 79; + Calc_RLI.dhscroll = 20; + Calc_RLI.prompt = "Calc> "; + Calc_RLI.getkey = SLang_getkey; + Calc_RLI.flags = SL_RLINE_BLINK_MATCH; + Calc_RLI.input_pending = SLang_input_pending; + +#ifndef IBMPC_SYSTEM + Calc_RLI.flags |= SL_RLINE_USE_ANSI; +#endif + + if (-1 == SLang_init_readline (&Calc_RLI)) + { + close_readline (); + return -1; + } + + if (NULL == (Readline_Load_Object = SLallocate_load_type (""))) + { + close_readline (); + return -1; + } + + Readline_Load_Object->read = read_using_readline; + return 0; +} + +static void close_readline (void) +{ + if (Readline_Load_Object != NULL) + { + SLdeallocate_load_type (Readline_Load_Object); + Readline_Load_Object = NULL; + } + + SLang_reset_tty (); +} + +static int take_input (void) +{ + return SLang_load_object (Readline_Load_Object); +} diff --git a/libslang/src/calc.sl b/libslang/src/calc.sl new file mode 100644 index 0000000..813dccf --- /dev/null +++ b/libslang/src/calc.sl @@ -0,0 +1,374 @@ +variable X = Any_Type[1]; +X[0] = "foo"; + +% a print function +_debug_info = 1; +set_float_format ("%.32e"); +define p(obj) +{ + () = fprintf (stdout, "%S\n", obj); + () = fflush (stdout); +} + +define print_struct (s) +{ + variable name, value; + + foreach (get_struct_field_names (s)) + { + name = (); + value = get_struct_field (s, name); + + () = printf ("s.%s = %S\n", name, value); + } +} + +static variable Static_Variable; + +static define test1 () +{ + loop (_NARGS) p; +} + +define test () +{ + usage ("silly silly silly"); + variable args = __pop_args (_NARGS); + test1 (__push_args (args)); +} + +define calc_take_input_hook () +{ + while (_stkdepth ()) + p (); +} + +define print_array (a) +{ + variable num_dims, dims; + variable nr, nc; + variable i, j; + + (dims ,num_dims,) = array_info (a); + if (num_dims > 2) + { + p (a); + return; + } + + nr = dims [0]; + nc = 0; + if (num_dims == 2) + nc = dims[1]; + + _for (0, nr - 1, 1) + { + i = (); + !if (nc) + { + () = printf ("Array[%d] = %S\n", i, a[i]); + continue; + } + _for (0, nc - 1, 1) + { + j = (); + () = printf ("\t%S", a[i, j]); + } + () = fputs ("\n", stdout); + } +} + +define read_file (file) +{ + variable line, len; + variable root, tail, s; + variable fp; + + fp = fopen (file, "r"); + if (fp == NULL) + error ("unable to open file"); + + root = NULL; + tail = NULL; + while (-1 != fgets (&line, fp)) + { + s = struct { next, value }; + s.value = line; + s.next = NULL; + + if (root == NULL) + root = s; + else + tail.next = s; + + tail = s; + } + () = fclose (fp); + return root; +} + +define list_len (list) +{ + variable len = 0; + + foreach (list) using ("next") + { + () = (); + len++; + } + return len; +} + + + + + + +% calc.sl--- Init file for calc. This file must be placed in the default +% directory for calc and is automatically loaded when calc runs. +% +% This file contains S-Lang code for Newton's method, etc... +% +% Here is a function which computes the root of the equation y = f(x) using +% Newtons method. The usage is: +% +% root = newton(s, &f); +% +% where s is a seed value and f is the function whose root is sought. +% +% For example, consider the function my_fun(x) = x^2 - 2 with solution +% x = sqrt(2). This function may be expressed in S-Lang as: +% +% define my_func(x) +% { +% return (x * x - 2); +% } +% +% To solve the equation my_fun(x) = 0 using the newton routine below, use +% +% newton(5.0, &myfun); +% +% Here, I have randomly chosen 5.0 as an initial guess. In addition, +% I have used the '&' operator to pass the function 'myfun' to the routine. + + +% Newton's method requires the derivative of a function. Here is such a +% function called by newton. Given f(x), it returns df/dx at the point x. +% +% Its usage is: +% +% derivative(x, &f); + +define derivative(x, f) +{ + variable dx; + dx = 1.0e-4; % small number + + return ((@f(x + dx) - @f(x - dx))/(2 * dx)); +} + +% And now the Newton's method: + +define newton(x, f) +{ + variable err, max, dx; + + err = 1.0e-6; + max = 1000; + + while (max) + { + --max; + dx = @f(x) / derivative(x, f); + if (abs(dx) < err) + { + return(x); + } + + x -= dx; + } + + message ("\7Root not found. Try another seed!"); + return(x); +} + + + +%% This is a standard benchmark for interpreters. It is a heavily +%% recursive routine that returns the nth Fibonacci number. +%% It is defined recursively as: +%% +%% f_0 = 0, f_1 = 1, .... , f_{n+1} = f_n + f_{n-1}, ... +%% +%% or {0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, ...} +%% + +define fib(); % required for recursion + +define fib(n) +{ + !if (n) return(0); + --n; + !if (n) return(1); + + return fib(n) + fib(n--, n); %Note that this expression parses to RPN + % n fib --n n fib + + %and since --n does not change the stack, the + %effect is the same as the C comma operator. +} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Two routines which illustrate the how to deal with files +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% type out a file to terminal +define type_file(file) +{ + variable fp, n, line; + + fp = fopen(file, "r"); + if (fp == NULL) + verror ("%s failed to open.", file); + + while (-1 != fgets (&line, fp)) + { + () = fputs (line, stdout); + } + + if (-1 == fclose(fp)) + verror ("Error closing %s", file); +} + + +% +% Here is a function that prints the number of lines in a file +% + +define count_lines1 (file) +{ + variable fp, lines, nchars, num_lines, st; + + fp = fopen (file, "r"); + if (fp == NULL) + verror ("count_lines1: unable to open %s", file); + + st = stat_file (file); + if (st == NULL) + verror ("stat_file failed"); + + lines = fgetslines (fp); + nchars = st.st_size; + + num_lines = length (lines); + + () = fclose (fp); + vmessage ("%s consists of %d characters and %d lines.\n", + file, nchars, num_lines); +} + + +define count_lines(f) +{ + variable fp, n, nchars, dn, line; + + fp = fopen(f, "r"); + if (fp == NULL) error("Unable to open file!"); + n = 0; nchars = 0; + + while (dn = fgets (&line, fp), dn != -1) + { + ++n; + nchars += dn; + } + () = fclose(fp); %/* ignore return value */ + + vmessage ("%s consists of %d characters and %d lines.\n", + f, nchars, n); +} + +define count_lines2(f) +{ + variable fp, n, nchars, dn, line; + + fp = fopen(f, "r"); + if (fp == NULL) error("Unable to open file!"); + n = 0; nchars = 0; + + foreach (fp) + { + nchars += strlen (); + ++n; + } + () = fclose(fp); %/* ignore return value */ + + vmessage ("%s consists of %d characters and %d lines.\n", + f, nchars, n); +} + + +define count_lines3(f) +{ + variable fp, n, nchars, dn, line; + + fp = fopen(f, "r"); + if (fp == NULL) error("Unable to open file!"); + n = 0; nchars = 0; + + n = 1; + foreach (fp) using ("char") + { + variable ch = (); + if (ch == '\n') + n++; + nchars++; + } + () = fclose(fp); %/* ignore return value */ + + vmessage ("%s consists of %d characters and %d lines.\n", + f, nchars, n); +} + + +% an apropos function +define apropos (what) +{ + variable n = _apropos(what, 0xF); + variable i, f1, f2, f3; + + if (n) () = printf ("Found %d matches:\n", n); + else + { + () = printf ("No matches.\n"); + return; + } + + loop (n / 3) + { + f1 = (); f2 = (); f3 = (); + () = printf ("%-26s %-26s %s\n", f1, f2, f3); + } + n = n mod 3; + loop (n) + { + f1 = (); + () = printf ("%-26s ", f1); + } + if (n) () = printf("\n"); +} + +%%% more help (called from calc.c) +define calc_help () +{ + p("Additional functions:"); + p(" p(); -- displays top element of the stack (discarding it)."); + p(" quit(); -- quit calculator"); + p(" apropos(\"STRING\"); -- lists all objects containing \"STRING\""); + p("\nExample: p (2.4 * E); yields 6.52388.\n"); +} + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% end of calc.sl +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/libslang/src/config.hin b/libslang/src/config.hin new file mode 100644 index 0000000..3ed3a3f --- /dev/null +++ b/libslang/src/config.hin @@ -0,0 +1,165 @@ +/* -*- c -*- */ +/* Note: this is for unix only. */ + +#ifndef SL_CONFIG_H +#define SL_CONFIG_H + +/* define if you have stdlib.h */ +#undef HAVE_STDLIB_H + +/* define if you have unistd.h */ +#undef HAVE_UNISTD_H + +/* define if you have termios.h */ +#undef HAVE_TERMIOS_H + +/* define if you have memory.h */ +#undef HAVE_MEMORY_H + +/* define if you have malloc.h */ +#undef HAVE_MALLOC_H + +/* define if you have memset */ +#undef HAVE_MEMSET + +/* define if you have memcpy */ +#undef HAVE_MEMCPY + +#undef HAVE_SETLOCALE +#undef HAVE_LOCALE_H + +#undef HAVE_VFSCANF +#undef HAVE_STRTOD + +/* define if you have fcntl.h */ +#undef HAVE_FCNTL_H + +/* Define if you have the vsnprintf, snprintf functions and they return + * EOF upon failure. + */ +#undef HAVE_VSNPRINTF +#undef HAVE_SNPRINTF + +/* define if you have sys/fcntl.h */ +#undef HAVE_SYS_FCNTL_H + +#undef HAVE_SYS_TYPES_H +#undef HAVE_SYS_WAIT_H +#undef HAVE_SYS_TIMES_H + +/* Set these to the appropriate values */ +#undef SIZEOF_SHORT +#undef SIZEOF_INT +#undef SIZEOF_LONG +#undef SIZEOF_FLOAT +#undef SIZEOF_DOUBLE + +/* define if you have these. */ +#undef HAVE_ATEXIT +#undef HAVE_ON_EXIT +#undef HAVE_PUTENV +#undef HAVE_GETCWD +#undef HAVE_TCGETATTR +#undef HAVE_TCSETATTR +#undef HAVE_CFGETOSPEED +#undef HAVE_LSTAT +#undef HAVE_KILL +#undef HAVE_CHOWN +#undef HAVE_VSNPRINTF +#undef HAVE_POPEN +#undef HAVE_UMASK +#undef HAVE_READLINK +#undef HAVE_TIMES +#undef HAVE_GMTIME +#undef HAVE_MKFIFO + +#undef HAVE_GETPPID +#undef HAVE_GETGID +#undef HAVE_GETEGID +#undef HAVE_GETEUID +#undef HAVE_GETUID + +#undef HAVE_SETGID +#undef HAVE_SETPGID +#undef HAVE_SETUID + +#undef HAVE_ISSETUGID + +#undef HAVE_ACOSH +#undef HAVE_ASINH +#undef HAVE_ATANH + +#undef HAVE_DIRENT_H +#undef HAVE_SYS_NDIR_H +#undef HAVE_SYS_DIR_H +#undef HAVE_NDIR_H + +#undef HAVE_DLFCN_H + +#undef HAVE_SYS_UTSNAME_H +#undef HAVE_UNAME + +/* These two are needed on DOS-like systems. Unix does not require them. + * They are included here for consistency. + * +#define HAVE_IO_H +#define HAVE_PROCESS_H + */ + +#undef USE_TERMCAP + +#undef mode_t +#undef uid_t +#undef pid_t +#undef gid_t + +/* Do we have posix signals? */ +#undef HAVE_SIGACTION +#undef HAVE_SIGPROCMASK +#undef HAVE_SIGEMPTYSET +#undef HAVE_SIGADDSET + +#if defined(HAVE_SIGADDSET) && defined(HAVE_SIGEMPTYSET) +# if defined(HAVE_SIGACTION) && defined(HAVE_SIGPROCMASK) +# define SLANG_POSIX_SIGNALS +# endif +#endif + +/* Define if you need to in order for stat and other things to work. */ +#undef _POSIX_SOURCE + +#ifdef _AIX +# ifndef _POSIX_SOURCE +# define _POSIX_SOURCE 1 +# endif +# ifndef _ALL_SOURCE +# define _ALL_SOURCE +# endif +/* This may generate warnings but the fact is that without it, xlc will + * INCORRECTLY inline many str* functions. */ +# undef __STR__ +#endif + +/* define USE_TERMCAP if you want to use it instead of terminfo. */ +#if defined(sequent) || defined(NeXT) +# ifndef USE_TERMCAP +# define USE_TERMCAP +# endif +#endif + +#if defined(ultrix) && !defined(__GNUC__) +# ifndef NO_PROTOTYPES +# define NO_PROTOTYPES +# endif +#endif + +#ifndef unix +# define unix 1 +#endif + +#ifndef __unix__ +# define __unix__ 1 +#endif + +#define _SLANG_SOURCE_ 1 +#endif /* SL_CONFIG_H */ diff --git a/libslang/src/curses/Makefile b/libslang/src/curses/Makefile new file mode 100644 index 0000000..0ca340b --- /dev/null +++ b/libslang/src/curses/Makefile @@ -0,0 +1,51 @@ +COMPILE = $(CC) $(CFLAGS) -g -DSLANG -I.. +LFLAGS = -L../$(ARCH)objs -lslang + +CURSES_H = ../curses.h + +EXECS = rain blue hanoi firework \ + bs battle gdc tclock worm view +#knight newdemo testcurs xmas + +all: $(CURSES_H) $(EXECS) + +$(CURSES_H): + echo '#include ' > $(CURSES_H) + +view: view.c + $(COMPILE) $@.c -o $@ $(LFLAGS) +bs: $(CURSES_H) bs.c + $(COMPILE) $@.c -o $@ $(LFLAGS) +gdc: $(CURSES_H) gdc.c + $(COMPILE) $@.c -o $@ $(LFLAGS) +battle: $(CURSES_H) battle.c + $(COMPILE) $@.c -o $@ $(LFLAGS) +hanoi: $(CURSES_H) hanoi.c + $(COMPILE) $@.c -o $@ $(LFLAGS) +blue: $(CURSES_H) blue.c + $(COMPILE) $@.c -o $@ $(LFLAGS) +rain: $(CURSES_H) rain.c + $(COMPILE) $@.c -o $@ $(LFLAGS) +firework: $(CURSES_H) firework.c + $(COMPILE) $@.c -o $@ $(LFLAGS) +tclock: $(CURSES_H) tclock.c + $(COMPILE) $@.c -o $@ $(LFLAGS) -lm +worm: worm.c + $(COMPILE) $@.c -o $@ $(LFLAGS) -lm +knight: knight.c + $(COMPILE) $@.c -o $@ $(LFLAGS) -lm +xmas: xmas.c + $(COMPILE) $@.c -o $@ $(LFLAGS) -lm +newdemo: newdemo.c + $(COMPILE) $@.c -o $@ $(LFLAGS) -lm +testcurs: testcurs.c + $(COMPILE) $@.c -o $@ $(LFLAGS) -lm +lrtest: lrtest.c + $(COMPILE) $@.c -o $@ $(LFLAGS) -lm +t: t.c + $(COMPILE) $@.c -o $@ $(LFLAGS) -lm +key: key.c + $(COMPILE) $@.c -o $@ $(LFLAGS) -lm + +clean: + /bin/rm $(EXECS) diff --git a/libslang/src/curses/README b/libslang/src/curses/README new file mode 100644 index 0000000..68af77e --- /dev/null +++ b/libslang/src/curses/README @@ -0,0 +1,11 @@ +The files in this directory serve to illustrate the S-Lang library curses +emulation. The emulation is far from complete; however, for many simple +programs, it is adequate. + +The C files in the directory come from the ncurses test directory. The only +modifications I have made to them involve adding code to stop gcc warnings, +e.g., + +./bs.c: In function `main': +./bs.c:1250: warning: control reaches end of non-void function + diff --git a/libslang/src/curses/battle.c b/libslang/src/curses/battle.c new file mode 100644 index 0000000..3bfbe5a --- /dev/null +++ b/libslang/src/curses/battle.c @@ -0,0 +1,710 @@ +/* + * battle.c - original author: Bruce Holloway + * mods by: Chuck A DeGaul + */ + +#include +#include +#include +#include +#include +#ifdef SLANG +# include +#else +# include +#endif + +#define OTHER 1-turn + +char numbers[] = " 0 1 2 3 4 5 6 7 8 9"; + +char carrier[] = "Aircraft Carrier"; +char battle[] = "Battleship"; +char sub[] = "Submarine"; +char destroy[] = "Destroyer"; +char ptboat[] = "PT Boat"; + +char name[40]; +char dftname[] = "Stranger"; + +struct _ships { + char *name; + char symbol; + char length; + char start; /* Coordinates - 0,0=0; 10,10=100. */ + char dir; /* Direction - 0 = right; 1 = down. */ + char hits; /* How many times has this ship been hit? (-1==sunk) */ +}; + +struct _ships plyship[] = { + { carrier,'A',5,0,0,0 }, + { battle,'B',4,0,0,0 }, + { destroy,'D',3,0,0,0 }, + { sub,'S',3,0,0,0 }, + { ptboat,'P',2,0,0,0 }, +}; + +struct _ships cpuship[] = { + { carrier,'A',5,0,0,0 }, + { battle,'B',4,0,0,0 }, + { destroy,'D',3,0,0,0 }, + { sub,'S',3,0,0,0 }, + { ptboat,'P',2,0,0,0 }, +}; + +char hits[2][100], board[2][100]; /* "Hits" board, and main board. */ + +int srchstep; +int cpuhits; +int cstart, cdir; +int plywon=0, cpuwon=0; /* How many games has each won? */ +int turn; /* 0=player, 1=computer */ +int huntoffs; /* Offset on search strategy */ + +int salvo, blitz, ask, seemiss; /* options */ + +void intro(void); +void initgame(void); +int rnd(int); +void plyplace(struct _ships *); +int getdir(void); +void placeship(struct _ships *, int, int); +int checkplace(struct _ships *, int, int); +void error(char *); +void prompt(void); +char getcoord(void); +void cpuplace(struct _ships *); +int awinna(void); +int plyturn(void); +int hitship(int); +int cputurn(void); +int playagain(void); +void uninitgame(); +int sgetc(char *); +int do_options(int, char *[]); +int scount(int); + +int +main(int argc, char **argv) +{ + do_options(argc, argv); + + intro(); + do { + initgame(); + while(awinna() == -1) { + if (!blitz) { + if (!salvo) { + if (turn) + cputurn(); + else plyturn(); + } else { + register int i; + + i = scount(turn); + while (i--) { + if (turn) + if (cputurn()) + if (awinna() != -1) + i = 0; + else + if(plyturn()) + if (awinna() != -1) + i = 0; + } + } + } else { + while((turn) ? cputurn() : plyturn()); + } + turn = OTHER; + } + } while(playagain()); + uninitgame(); + exit(0); +} + +#define PR addstr + +void +intro() +{ +char *tmpname; + + srand(time(0L)); /* Kick the random number generator */ + + signal(SIGINT,uninitgame); + if(signal(SIGQUIT,SIG_IGN) != SIG_IGN) signal(SIGQUIT,uninitgame); +#if 1 + /* for some bizzare reason, getlogin or cuserid cause havoc with the terminal */ + if ((tmpname = getlogin()) != NULL) { + strcpy(name, tmpname); + } else +#endif + strcpy(name,dftname); + name[0] = toupper(name[0]); + + initscr(); + savetty(); + nonl(); + cbreak(); + noecho(); + clear(); + mvaddstr(4,29,"Welcome to Battleship!"); + move(8,0); +PR(" \\\n"); +PR(" \\ \\ \\\n"); +PR(" \\ \\ \\ \\ \\_____________\n"); +PR(" \\ \\ \\_____________ \\ \\/ |\n"); +PR(" \\ \\/ \\ \\/ |\n"); +PR(" \\/ \\_____/ |__\n"); +PR(" ________________/ |\n"); +PR(" \\ S.S. Penguin |\n"); +PR(" \\ /\n"); +PR(" \\___________________________________________________/\n"); + mvaddstr(20,27,"Hit any key to continue..."); refresh(); + getch(); +} + +void +initgame() +{ +int i; + + clear(); + mvaddstr(0,35,"BATTLESHIP"); + mvaddstr(4,12,"Main Board"); + mvaddstr(6,0,numbers); + move(7,0); + for(i=0; i<10; ++i){ + printw("%c . . . . . . . . . . %c\n",i+'A',i+'A'); + } + mvaddstr(17,0,numbers); + mvaddstr(4,55,"Hit/Miss Board"); + mvaddstr(6,45,numbers); + for(i=0; i<10; ++i){ + mvprintw(7+i,45,"%c . . . . . . . . . . %c",i+'A',i+'A'); + } + mvaddstr(17,45,numbers); + for(turn=0; turn<2; ++turn) + for(i=0; i<100; ++i){ + hits[turn][i] = board[turn][i] = 0; + } + for(turn=0; turn<2; ++turn){ + for(i=0; i<5; ++i) + if (!turn) + plyplace(&plyship[i]); + else + cpuplace(&cpuship[i]); + } + turn = rnd(2); + cstart = cdir = -1; + cpuhits = 0; + srchstep = 3; + huntoffs = rnd(srchstep); +} + +int +rnd(int n) +{ + return(((rand() & 0x7FFF) % n)); +} + +void +plyplace(ss) +struct _ships *ss; +{ +int c, d; + + do { + prompt(); + printw("Place your %s (ex.%c%d) ? ",ss->name,rnd(10)+'A',rnd(10)); + c = getcoord(); + d = getdir(); + } while(!checkplace(ss,c,d)); + placeship(ss,c,d); +} + +int +getdir() +{ + + prompt(); + addstr("What direction (0=right, 1=down) ? "); + return(sgetc("01")-'0'); +} + +void +placeship(ss,c,d) +struct _ships *ss; +int c, d; +{ +int x, y, l, i; + + for(l=0; llength; ++l){ + i = c + l * ((d) ? 10 : 1); + board[turn][i] = ss->symbol; + x = (i % 10) * 3 + 3; + y = (i / 10) + 7; + if(!turn) mvaddch(y,x,ss->symbol); + } + ss->start = c; + ss->dir = d; + ss->hits = 0; +} + +int +checkplace(ss,c,d) +struct _ships *ss; +int c, d; +{ +int x, y, l; + + x = c%10; y = c/10; + if(((x+ss->length) > 10 && !d) || ((y+ss->length) > 10 && d==1)){ + if(!turn) + switch(rnd(3)){ + case 0: + error("Ship is hanging from the edge of the world"); + break; + case 1: + error("Try fitting it on the board"); + break; + case 2: + error("Figure I won't find it if you put it there?"); + break; + } + return(0); + } + for(l=0; llength; ++l){ + x = c + l * ((d) ? 10 : 1); + if(board[turn][x]){ + if(!turn) + switch(rnd(3)){ + case 0: + error("There's already a ship there"); + break; + case 1: + error("Collision alert! Aaaaaagh!"); + break; + case 2: + error("Er, Admiral, what about the other ship?"); + break; + } + return(0); + } + } + return(1); +} + +void +error(s) +char *s; +{ + prompt(); + beep(); + printw("%s -- hit any key to continue --",s); + refresh(); + getch(); +} + +void +prompt(){ + move(22,0); + clrtoeol(); +} + +char +getcoord() +{ +int ch, x, y; + +redo: + y = sgetc("ABCDEFGHIJ"); + do { + ch = getch(); + if (ch == 0x7F || ch == 8) { + addstr("\b \b"); + refresh(); + goto redo; + } + } while(ch < '0' || ch > '9'); + addch(x = ch); + refresh(); + return((y-'A')*10+x-'0'); +} + +void +cpuplace(ss) +struct _ships *ss; +{ +int c, d; + + do{ + c = rnd(100); + d = rnd(2); + } while(!checkplace(ss,c,d)); + placeship(ss,c,d); +} + +int +awinna() +{ +int i, j; +struct _ships *ss; + + for (i = 0; i < 2; ++i) { + ss = (i) ? cpuship : plyship; + for(j=0; j<5; ++j, ++ss) + if(ss->length != ss->hits) + break; + if(j == 5) return(OTHER); + } + return(-1); +} + +int +plyturn() +{ +int c, res; +char *m; + + prompt(); + addstr("Where do you want to shoot? "); + c = getcoord(); + if(!(res = hits[turn][c])){ + hits[turn][c] = res = (board[OTHER][c]) ? 'H' : 'M'; + mvaddch(7+c/10,48+3*(c%10),(res=='H') ? 'H' : 'o'); + if(0 != (c = hitship(c))){ + prompt(); + switch(rnd(3)){ + case 0: + m = "You sank my %s!"; + break; + case 1: + m = "I have this sinking feeling about my %s...."; + break; + case 2: + m = "Have some mercy for my %s!"; + break; + } + move(23,0); + clrtoeol(); + beep(); + printw(m,cpuship[c-1].name); refresh(); + return(awinna() == -1); + } + } + prompt(); + move(23,0); clrtoeol(); + printw("You %s.",(res=='M')?"missed":"scored a hit"); refresh(); + return(res == 'H'); +} + +int +hitship(c) +int c; +{ +struct _ships *ss; +int sym, i, j; + + ss = (turn) ? plyship : cpuship; + if (!(sym = board[OTHER][c])) return(0); + for (i = 0; i < 5; ++i, ++ss) + if (ss->symbol == sym) { + j = ss->hits; + ++j; + ss->hits = j; + if (j == ss->length) + return(i+1); + return(0); + } + return 0; +} + +int +cputurn() +{ +int c, res, x, y, i, d; + +redo: + if (cstart == -1){ + if (cpuhits){ + for(i=0, c=rnd(100); i<100; ++i, c = (c+1) % 100) + if(hits[turn][c] == 'H') + break; + if(i != 100){ + cstart = c; + cdir = -1; + goto fndir; + } + } + do { + i = 0; + do{ + while(hits[turn][c=rnd(100)]); + x = c % 10; y = c / 10; + if(++i == 1000) break; + } while(((x+huntoffs) % srchstep) != (y % srchstep)); + if(i == 1000) --srchstep; + } while(i == 1000); + } + else if(cdir == -1){ +fndir: for(i=0, d=rnd(4); i++ < 4; d = (d+1) % 4){ + x = cstart%10; y = cstart/10; + switch(d){ + case 0: ++x; break; + case 1: ++y; break; + case 2: --x; break; + case 3: --y; break; + } + if(x<0 || x>9 || y<0 || y>9) continue; + if(hits[turn][c=y*10+x]) continue; + cdir = -2; + break; + } + if(i == 4){ + cstart = -1; + goto redo; + } + } + else{ + x = cstart%10; y = cstart/10; + switch(cdir){ + case 0: ++x; break; + case 1: ++y; break; + case 2: --x; break; + case 3: --y; break; + } + if(x<0 || x>9 || y<0 || y>9 || hits[turn][y*10+x]){ + cdir = (cdir+2) % 4; + for(;;){ + switch(cdir){ + case 0: ++x; break; + case 1: ++y; break; + case 2: --x; break; + case 3: --y; break; + } + if(x<0 || x>9 || y<0 || y>9){ cstart = -1; + goto redo; + } + if(!hits[turn][y*10+x]) break; + } + } + c = y*10 + x; + } + + if (!ask) { + res = (board[OTHER][c]) ? 'H' : 'M'; + move(21,0); clrtoeol(); + printw("I shoot at %c%d. I %s!",c/10+'A',c%10,(res=='H')?"hit":"miss"); + } else { + for(;;){ + prompt(); + printw("I shoot at %c%d. Do I (H)it or (M)iss? ",c/10+'A',c%10); + res = sgetc("HM"); + if((res=='H' && !board[OTHER][c]) || (res=='M' && board[OTHER][c])){ + error("You lie!"); + continue; + } + break; + } + addch(res); + } + hits[turn][c] = res; + if(res == 'H') { + ++cpuhits; + if(cstart == -1) cdir = -1; + cstart = c; + if(cdir == -2) cdir = d; + mvaddch(7+(c/10),3+3*(c%10),'*'); + if (blitz && !ask) { + refresh(); + sleep(1); + } + } + else { + if (seemiss) { + mvaddch(7+(c/10),3+3*(c%10),' '); + } else { + if(cdir == -2) cdir = -1; + } + } + if(0 != (c=hitship(c))){ + cstart = -1; + cpuhits -= plyship[c-1].length; + x = plyship[c-1].start; + d = plyship[c-1].dir; + y = plyship[c-1].length; + for(i=0; i= 10) ++i; + if(cpuwon >= 10) ++i; + mvprintw(2,(80-i)/2,"%s: %d Computer: %d",name,plywon,cpuwon); + + prompt(); + printw((awinna()) ? "Want to be humiliated again, %s? " + : "Going to give me a chance for revenge, %s? ",name); + return(sgetc("YN") == 'Y'); +} + +void +uninitgame(int sig) +{ + refresh(); + endwin(); + exit(0); +} + +int +sgetc(s) +char *s; +{ +char *s1; +int ch; + + refresh(); + for (;;) { + ch = toupper(getch()); + for (s1 = s; *s1 && ch != *s1; ++s1); + if (*s1) { + addch(ch); + refresh(); + return(ch); + } + } +} + +/* + * I should use getopts() from libc.a, but I'm leary that other UNIX + * systems might not have it, although I'd love to use it. + */ + +int +do_options(c,op) +int c; +char *op[]; +{ +register int i; + + if (c > 1) { + for (i=1; ihits == (char) -1 || sp->hits >= sp->length) { + continue; /* dead ship */ + } else { + shots++; + } + } + return(shots); +} + diff --git a/libslang/src/curses/blue.c b/libslang/src/curses/blue.c new file mode 100644 index 0000000..27d9815 --- /dev/null +++ b/libslang/src/curses/blue.c @@ -0,0 +1,415 @@ +/***************************************************************************** + * * + * B l u e M o o n * + * ================= * + * V2.2 * + * A patience game by T.A.Lister * + * Integral screen support by Eric S. Raymond * + * * + *****************************************************************************/ + +/* + * Compile this with the command `cc -O blue.c -lcurses -o blue'. For best + * results, use the portable freeware ncurses(3) library. On non-Intel + * machines, SVr4 curses is just as good. + */ + +#include +#include +#include +#include +#include + +#if HAVE_TERMIOS_H +#include +#endif + +#include +#ifndef SLANG +#include +#endif + +#define NOCARD (-1) + +#define ACE 0 +#define KING 12 +#define SUIT_LENGTH 13 + +#define HEARTS 0 +#define SPADES 1 +#define DIAMONDS 2 +#define CLUBS 3 +#define NSUITS 4 + +#define GRID_WIDTH 14 /* 13+1 */ +#define GRID_LENGTH 56 /* 4*(13+1) */ +#define PACK_SIZE 52 + +#define BASEROW 1 +#define PROMPTROW 11 + +static int deck_size = PACK_SIZE; /* initial deck */ +static int deck[PACK_SIZE]; + +static int grid[GRID_LENGTH]; /* card layout grid */ +static int freeptr[4]; /* free card space pointers */ + +static int deal_number=0; + +static chtype ranks[SUIT_LENGTH][2] = +{ + {' ', 'A'}, + {' ', '2'}, + {' ', '3'}, + {' ', '4'}, + {' ', '5'}, + {' ', '6'}, + {' ', '7'}, + {' ', '8'}, + {' ', '9'}, + {'1', '0'}, + {' ', 'J'}, + {' ', 'Q'}, + {' ', 'K'} +}; + +static chtype letters[] = +{ + 'h' | COLOR_PAIR(COLOR_RED), /* hearts */ + 's' | COLOR_PAIR(COLOR_GREEN), /* spades */ + 'd' | COLOR_PAIR(COLOR_RED), /* diamonds */ + 'c' | COLOR_PAIR(COLOR_GREEN), /* clubs */ +}; + +#if defined(__i386__) +static chtype glyphs[] = +{ + '\003' | A_ALTCHARSET | COLOR_PAIR(COLOR_RED), /* hearts */ + '\006' | A_ALTCHARSET | COLOR_PAIR(COLOR_GREEN), /* spades */ + '\004' | A_ALTCHARSET | COLOR_PAIR(COLOR_RED), /* diamonds */ + '\005' | A_ALTCHARSET | COLOR_PAIR(COLOR_GREEN), /* clubs */ +}; +#endif /* __i386__ */ + +static chtype *suits = letters; /* this may change to glyphs below */ + +static void die(int onsig) +{ + signal(onsig, SIG_IGN); + endwin(); + exit(0); +} + +static void init_vars(void) +{ + int i; + + deck_size = PACK_SIZE; + for (i=0; i < PACK_SIZE; i++) + deck[i]=i; + for (i = 0; i < 4; i++) + freeptr[i]=i * GRID_WIDTH; +} + +static void shuffle(int size) +{ + int i,j,numswaps,swapnum,temp; + + numswaps=size*10; /* an arbitrary figure */ + + for (swapnum=0;swapnum=PACK_SIZE)) + return(NOCARD); + for(i = 0; i < GRID_LENGTH; i++) + if (grid[i] == card) + return i; + return(NOCARD); +} + +static void movecard(int src, int dst) +{ + grid[dst]=grid[src]; + grid[src]=NOCARD; + + move( BASEROW + (dst / GRID_WIDTH)*2+2, (dst % GRID_WIDTH)*5 + 1); + printcard(grid[dst]); + + move( BASEROW + (src / GRID_WIDTH)*2+2, (src % GRID_WIDTH)*5 + 1); + printcard(grid[src]); + + refresh(); +} + +static void play_game(void) +{ + int dead=0, i, j; + char c; + int select[4], card; + + while (dead<4) + { + dead=0; + for (i=0;i<4;i++) + { + card=grid[freeptr[i]-1]; + + if ( ((card % SUIT_LENGTH)==KING) + || + (card==NOCARD) ) + select[i]=NOCARD; + else + select[i]=find(card+1); + + if (select[i]==NOCARD) + dead++; + }; + + if (dead < 4) + { + char live[NSUITS+1], *lp = live; + + for (i=0;i<4;i++) + { + if (select[i] != NOCARD) + { + move(BASEROW + (select[i] / GRID_WIDTH)*2+3, + (select[i] % GRID_WIDTH)*5); + (void)printw(" %c ", *lp++ = 'a' + i); + } + }; + *lp = '\0'; + + if (strlen(live) == 1) + { + move(PROMPTROW,0); + (void)printw( + "Making forced moves... "); + refresh(); + (void) sleep(1); + c = live[0]; + } + else + { + char buf[BUFSIZ]; + + (void)sprintf(buf, + "Type [%s] to move, r to redraw, q or INTR to quit: ", + live); + + do { + move(PROMPTROW,0); + (void) addstr(buf); + move(PROMPTROW, (int)strlen(buf)); + clrtoeol(); + (void) addch(' '); + } while + (((c = getch())<'a' || c>'d') && (c!='r') && (c!='q')); + } + + for (j = 0; j < 4; j++) + if (select[j]!=NOCARD) + { + move(BASEROW + (select[j] / GRID_WIDTH)*2+3, + (select[j] % GRID_WIDTH)*5); + (void)printw(" "); + } + + if (c == 'r') + display_cards(deal_number); + else if (c == 'q') + die(SIGINT); + else + { + i = c-'a'; + if (select[i] == NOCARD) + beep(); + else + { + movecard(select[i], freeptr[i]); + freeptr[i]=select[i]; + } + } + } + } + + move(PROMPTROW, 0); + standout(); + (void)printw("Finished deal %d - type any character to continue...", deal_number); + standend(); + (void) getch(); +} + +static int collect_discards(void) +{ + int row, col, cardno=0, finish, gridno; + + for (row=HEARTS;row<=CLUBS;row++) + { + finish=0; + for (col=1;col + * v1.2 with color support and minor portability fixes, November 1990 + * v2.0 featuring strict ANSI/POSIX conformance, November 1993. + * v2.1 with ncurses mouse support, September 1995 + */ +/* #define _POSIX_SOURCE -- incompatible with solaris termios.h */ + +#include +#include +#include +#include +#include +#include +#include + +#if HAVE_TERMIOS_H +#include /* required before solaris curses.h */ +#endif + +#include + +#ifndef SIGIOT +#define SIGIOT SIGABRT +#endif + +#ifndef A_UNDERLINE /* BSD curses */ +#define beep() write(1,"\007",1); +#define cbreak crmode +#define saveterm savetty +#define resetterm resetty +#define nocbreak nocrmode +#define strchr index +#endif /* !A_UNDERLINE */ + +static int getcoord(int); + +/* + * Constants for tuning the random-fire algorithm. It prefers moves that + * diagonal-stripe the board with a stripe separation of srchstep. If + * no such preferred moves are found, srchstep is decremented. + */ +#define BEGINSTEP 3 /* initial value of srchstep */ + +/* miscellaneous constants */ +#define SHIPTYPES 5 +#define OTHER (1-turn) +#define PLAYER 0 +#define COMPUTER 1 +#define MARK_HIT 'H' +#define MARK_MISS 'o' +#define CTRLC '\003' /* used as terminate command */ +#define FF '\014' /* used as redraw command */ + +/* coordinate handling */ +#define BWIDTH 10 +#define BDEPTH 10 + +/* display symbols */ +#define SHOWHIT '*' +#define SHOWSPLASH ' ' +#define IS_SHIP(c) isupper(c) + +/* how to position us on player board */ +#define PYBASE 3 +#define PXBASE 3 +#define PY(y) (PYBASE + (y)) +#define PX(x) (PXBASE + (x)*3) +#define pgoto(y, x) (void)move(PY(y), PX(x)) + +/* how to position us on cpu board */ +#define CYBASE 3 +#define CXBASE 48 +#define CY(y) (CYBASE + (y)) +#define CX(x) (CXBASE + (x)*3) +#define CYINV(y) ((y) - CYBASE) +#define CXINV(x) (((x) - CXBASE) / 3) +#define cgoto(y, x) (void)move(CY(y), CX(x)) + +#define ONBOARD(x, y) (x >= 0 && x < BWIDTH && y >= 0 && y < BDEPTH) + +/* other board locations */ +#define COLWIDTH 80 +#define PROMPTLINE 21 /* prompt line */ +#define SYBASE CYBASE + BDEPTH + 3 /* move key diagram */ +#define SXBASE 63 +#define MYBASE SYBASE - 1 /* diagram caption */ +#define MXBASE 64 +#define HYBASE SYBASE - 1 /* help area */ +#define HXBASE 0 + +/* this will need to be changed if BWIDTH changes */ +static char numbers[] = " 0 1 2 3 4 5 6 7 8 9"; + +static char carrier[] = "Aircraft Carrier"; +static char battle[] = "Battleship"; +static char sub[] = "Submarine"; +static char destroy[] = "Destroyer"; +static char ptboat[] = "PT Boat"; + +static char name[40]; +static char dftname[] = "stranger"; + +/* direction constants */ +#define E 0 +#define SE 1 +#define S 2 +#define SW 3 +#define W 4 +#define NW 5 +#define N 6 +#define NE 7 +static int xincr[8] = {1, 1, 0, -1, -1, -1, 0, 1}; +static int yincr[8] = {0, 1, 1, 1, 0, -1, -1, -1}; + +/* current ship position and direction */ +static int curx = (BWIDTH / 2); +static int cury = (BDEPTH / 2); + +typedef struct +{ + char *name; /* name of the ship type */ + unsigned hits; /* how many times has this ship been hit? */ + char symbol; /* symbol for game purposes */ + char length; /* length of ship */ + char x, y; /* coordinates of ship start point */ + unsigned char dir; /* direction of `bow' */ + bool placed; /* has it been placed on the board? */ +} +ship_t; + +static bool checkplace(int b, ship_t *ss, int vis); + +ship_t plyship[SHIPTYPES] = +{ + { carrier, 0, 'A', 5}, + { battle, 0, 'B', 4}, + { destroy, 0, 'D', 3}, + { sub, 0, 'S', 3}, + { ptboat, 0, 'P', 2}, +}; + +ship_t cpuship[SHIPTYPES] = +{ + { carrier, 0, 'A', 5}, + { battle, 0, 'B', 4}, + { destroy, 0, 'D', 3}, + { sub, 0, 'S', 3}, + { ptboat, 0, 'P', 2}, +}; + +/* "Hits" board, and main board. */ +static char hits[2][BWIDTH][BDEPTH], board[2][BWIDTH][BDEPTH]; + +static int turn; /* 0=player, 1=computer */ +static int plywon=0, cpuwon=0; /* How many games has each won? */ + +static int salvo, blitz, closepack; + +#define PR (void)addstr + +static void uninitgame(int sig) +/* end the game, either normally or due to signal */ +{ + clear(); + (void)refresh(); + (void)resetterm(); + (void)echo(); + (void)endwin(); + exit(sig); +} + +static void announceopts(void) +/* announce which game options are enabled */ +{ + if (salvo || blitz || closepack) + { + (void) printw("Playing optional game ("); + if (salvo) + (void) printw("salvo, "); + else + (void) printw("nosalvo, "); + if (blitz) + (void) printw("blitz "); + else + (void) printw("noblitz, "); + if (closepack) + (void) printw("closepack)"); + else + (void) printw("noclosepack)"); + } + else + (void) printw( + "Playing standard game (noblitz, nosalvo, noclosepack)"); +} + +static void intro(void) +{ + extern char *getlogin(void); + char *tmpname; + + srand((unsigned)(time(0L)+getpid())); /* Kick the random number generator */ + + (void) signal(SIGINT,uninitgame); + (void) signal(SIGINT,uninitgame); + (void) signal(SIGIOT,uninitgame); /* for assert(3) */ + if(signal(SIGQUIT,SIG_IGN) != SIG_IGN) + (void)signal(SIGQUIT,uninitgame); + + if((tmpname = getlogin()) != 0) + { + (void)strcpy(name,tmpname); + name[0] = toupper(name[0]); + } + else + (void)strcpy(name,dftname); + + (void)initscr(); +#ifdef KEY_MIN + keypad(stdscr, TRUE); +#endif /* KEY_MIN */ + (void)saveterm(); + (void)nonl(); + (void)cbreak(); + (void)noecho(); + +#ifdef PENGUIN + (void)clear(); + (void)mvaddstr(4,29,"Welcome to Battleship!"); + (void)move(8,0); + PR(" \\\n"); + PR(" \\ \\ \\\n"); + PR(" \\ \\ \\ \\ \\_____________\n"); + PR(" \\ \\ \\_____________ \\ \\/ |\n"); + PR(" \\ \\/ \\ \\/ |\n"); + PR(" \\/ \\_____/ |__\n"); + PR(" ________________/ |\n"); + PR(" \\ S.S. Penguin |\n"); + PR(" \\ /\n"); + PR(" \\___________________________________________________/\n"); + + (void) mvaddstr(22,27,"Hit any key to continue..."); (void)refresh(); + (void) getch(); +#endif /* PENGUIN */ + +#ifdef A_COLOR + start_color(); + + init_pair(COLOR_BLACK, COLOR_BLACK, COLOR_BLACK); + init_pair(COLOR_GREEN, COLOR_GREEN, COLOR_BLACK); + init_pair(COLOR_RED, COLOR_RED, COLOR_BLACK); + init_pair(COLOR_CYAN, COLOR_CYAN, COLOR_BLACK); + init_pair(COLOR_WHITE, COLOR_WHITE, COLOR_BLACK); + init_pair(COLOR_MAGENTA, COLOR_MAGENTA, COLOR_BLACK); + init_pair(COLOR_BLUE, COLOR_BLUE, COLOR_BLACK); + init_pair(COLOR_YELLOW, COLOR_YELLOW, COLOR_BLACK); +#endif /* A_COLOR */ + +#ifdef NCURSES_MOUSE_VERSION + (void) mousemask(BUTTON1_CLICKED, (mmask_t *)NULL); +#endif /* NCURSES_MOUSE_VERSION*/ +} + +/* VARARGS1 */ +static void prompt(int n, char *f, char *s) +/* print a message at the prompt line */ +{ + (void) move(PROMPTLINE + n, 0); + (void) clrtoeol(); + (void) printw(f, s); + (void) refresh(); +} + +static void error(char *s) +{ + (void) move(PROMPTLINE + 2, 0); + (void) clrtoeol(); + if (s) + { + (void) addstr(s); + (void) beep(); + } +} + +static void placeship(int b, ship_t *ss, int vis) +{ + int l; + + for(l = 0; l < ss->length; ++l) + { + int newx = ss->x + l * xincr[ss->dir]; + int newy = ss->y + l * yincr[ss->dir]; + + board[b][newx][newy] = ss->symbol; + if (vis) + { + pgoto(newy, newx); + (void) addch((chtype)ss->symbol); + } + } + ss->hits = 0; +} + +static int rnd(int n) +{ + return(((rand() & 0x7FFF) % n)); +} + +static void randomplace(int b, ship_t *ss) +/* generate a valid random ship placement into px,py */ +{ + register int bwidth = BWIDTH - ss->length; + register int bdepth = BDEPTH - ss->length; + + do { + ss->y = rnd(bdepth); + ss->x = rnd(bwidth); + ss->dir = rnd(2) ? E : S; + } while + (!checkplace(b, ss, FALSE)); +} + +static void initgame(void) +{ + int i, j, unplaced; + ship_t *ss; + + (void) clear(); + (void) mvaddstr(0,35,"BATTLESHIPS"); + (void) move(PROMPTLINE + 2, 0); + announceopts(); + + memset(board, 0, sizeof(char) * BWIDTH * BDEPTH * 2); + memset(hits, 0, sizeof(char) * BWIDTH * BDEPTH * 2); + for (i = 0; i < SHIPTYPES; i++) + { + ss = cpuship + i; + ss->x = ss->y = ss->dir = ss->hits = ss->placed = 0; + ss = plyship + i; + ss->x = ss->y = ss->dir = ss->hits = ss->placed = 0; + } + + /* draw empty boards */ + (void) mvaddstr(PYBASE - 2, PXBASE + 5, "Main Board"); + (void) mvaddstr(PYBASE - 1, PXBASE - 3,numbers); + for(i=0; i < BDEPTH; ++i) + { + (void) mvaddch(PYBASE + i, PXBASE - 3, (chtype)(i + 'A')); +#ifdef A_COLOR + if (has_colors()) + attron(COLOR_PAIR(COLOR_BLUE)); +#endif /* A_COLOR */ + (void) addch(' '); + for (j = 0; j < BWIDTH; j++) + (void) addstr(" . "); +#ifdef A_COLOR + attrset(0); +#endif /* A_COLOR */ + (void) addch(' '); + (void) addch((chtype)(i + 'A')); + } + (void) mvaddstr(PYBASE + BDEPTH, PXBASE - 3,numbers); + (void) mvaddstr(CYBASE - 2, CXBASE + 7,"Hit/Miss Board"); + (void) mvaddstr(CYBASE - 1, CXBASE - 3, numbers); + for(i=0; i < BDEPTH; ++i) + { + (void) mvaddch(CYBASE + i, CXBASE - 3, (chtype)(i + 'A')); +#ifdef A_COLOR + if (has_colors()) + attron(COLOR_PAIR(COLOR_BLUE)); +#endif /* A_COLOR */ + (void) addch(' '); + for (j = 0; j < BWIDTH; j++) + (void) addstr(" . "); +#ifdef A_COLOR + attrset(0); +#endif /* A_COLOR */ + (void) addch(' '); + (void) addch((chtype)(i + 'A')); + } + + (void) mvaddstr(CYBASE + BDEPTH,CXBASE - 3,numbers); + + (void) mvprintw(HYBASE, HXBASE, + "To position your ships: move the cursor to a spot, then"); + (void) mvprintw(HYBASE+1,HXBASE, + "type the first letter of a ship type to select it, then"); + (void) mvprintw(HYBASE+2,HXBASE, + "type a direction ([hjkl] or [4862]), indicating how the"); + (void) mvprintw(HYBASE+3,HXBASE, + "ship should be pointed. You may also type a ship letter"); + (void) mvprintw(HYBASE+4,HXBASE, + "followed by `r' to position it randomly, or type `R' to"); + (void) mvprintw(HYBASE+5,HXBASE, + "place all remaining ships randomly."); + + (void) mvaddstr(MYBASE, MXBASE, "Aiming keys:"); + (void) mvaddstr(SYBASE, SXBASE, "y k u 7 8 9"); + (void) mvaddstr(SYBASE+1, SXBASE, " \\|/ \\|/ "); + (void) mvaddstr(SYBASE+2, SXBASE, "h-+-l 4-+-6"); + (void) mvaddstr(SYBASE+3, SXBASE, " /|\\ /|\\ "); + (void) mvaddstr(SYBASE+4, SXBASE, "b j n 1 2 3"); + + /* have the computer place ships */ + for(ss = cpuship; ss < cpuship + SHIPTYPES; ss++) + { + randomplace(COMPUTER, ss); + placeship(COMPUTER, ss, FALSE); + } + + ss = (ship_t *)NULL; + do { + char c, docked[SHIPTYPES + 2], *cp = docked; + + /* figure which ships still wait to be placed */ + *cp++ = 'R'; + for (i = 0; i < SHIPTYPES; i++) + if (!plyship[i].placed) + *cp++ = plyship[i].symbol; + *cp = '\0'; + + /* get a command letter */ + prompt(1, "Type one of [%s] to pick a ship.", docked+1); + do { + c = getcoord(PLAYER); + } while + (!strchr(docked, c)); + + if (c == 'R') + (void) ungetch('R'); + else + { + /* map that into the corresponding symbol */ + for (ss = plyship; ss < plyship + SHIPTYPES; ss++) + if (ss->symbol == c) + break; + + prompt(1, "Type one of [hjklrR] to place your %s.", ss->name); + pgoto(cury, curx); + } + + do { + c = getch(); + } while + (!strchr("hjklrR", c) || c == FF); + + if (c == FF) + { + (void)clearok(stdscr, TRUE); + (void)refresh(); + } + else if (c == 'r') + { + prompt(1, "Random-placing your %s", ss->name); + randomplace(PLAYER, ss); + placeship(PLAYER, ss, TRUE); + error((char *)NULL); + ss->placed = TRUE; + } + else if (c == 'R') + { + prompt(1, "Placing the rest of your fleet at random...", ""); + for (ss = plyship; ss < plyship + SHIPTYPES; ss++) + if (!ss->placed) + { + randomplace(PLAYER, ss); + placeship(PLAYER, ss, TRUE); + ss->placed = TRUE; + } + error((char *)NULL); + } + else if (strchr("hjkl8462", c)) + { + ss->x = curx; + ss->y = cury; + + switch(c) + { + case 'k': case '8': ss->dir = N; break; + case 'j': case '2': ss->dir = S; break; + case 'h': case '4': ss->dir = W; break; + case 'l': case '6': ss->dir = E; break; + } + + if (checkplace(PLAYER, ss, TRUE)) + { + placeship(PLAYER, ss, TRUE); + error((char *)NULL); + ss->placed = TRUE; + } + } + + for (unplaced = i = 0; i < SHIPTYPES; i++) + unplaced += !plyship[i].placed; + } while + (unplaced); + + turn = rnd(2); + + (void) mvprintw(HYBASE, HXBASE, + "To fire, move the cursor to your chosen aiming point "); + (void) mvprintw(HYBASE+1, HXBASE, + "and strike any key other than a motion key. "); + (void) mvprintw(HYBASE+2, HXBASE, + " "); + (void) mvprintw(HYBASE+3, HXBASE, + " "); + (void) mvprintw(HYBASE+4, HXBASE, + " "); + (void) mvprintw(HYBASE+5, HXBASE, + " "); + + (void) prompt(0, "Press any key to start...", ""); + (void) getch(); +} + +static int getcoord(int atcpu) +{ + int ny, nx, c; + + if (atcpu) + cgoto(cury,curx); + else + pgoto(cury, curx); + (void)refresh(); + for (;;) + { + if (atcpu) + { + (void) mvprintw(CYBASE + BDEPTH+1, CXBASE+11, "(%d, %c)", curx, 'A'+cury); + cgoto(cury, curx); + } + else + { + (void) mvprintw(PYBASE + BDEPTH+1, PXBASE+11, "(%d, %c)", curx, 'A'+cury); + pgoto(cury, curx); + } + + switch(c = getch()) + { + case 'k': case '8': +#ifdef KEY_MIN + case KEY_UP: +#endif /* KEY_MIN */ + ny = cury+BDEPTH-1; nx = curx; + break; + case 'j': case '2': +#ifdef KEY_MIN + case KEY_DOWN: +#endif /* KEY_MIN */ + ny = cury+1; nx = curx; + break; + case 'h': case '4': +#ifdef KEY_MIN + case KEY_LEFT: +#endif /* KEY_MIN */ + ny = cury; nx = curx+BWIDTH-1; + break; + case 'l': case '6': +#ifdef KEY_MIN + case KEY_RIGHT: +#endif /* KEY_MIN */ + ny = cury; nx = curx+1; + break; + case 'y': case '7': +#ifdef KEY_MIN + case KEY_A1: +#endif /* KEY_MIN */ + ny = cury+BDEPTH-1; nx = curx+BWIDTH-1; + break; + case 'b': case '1': +#ifdef KEY_MIN + case KEY_C1: +#endif /* KEY_MIN */ + ny = cury+1; nx = curx+BWIDTH-1; + break; + case 'u': case '9': +#ifdef KEY_MIN + case KEY_A3: +#endif /* KEY_MIN */ + ny = cury+BDEPTH-1; nx = curx+1; + break; + case 'n': case '3': +#ifdef KEY_MIN + case KEY_C3: +#endif /* KEY_MIN */ + ny = cury+1; nx = curx+1; + break; + case FF: + nx = curx; ny = cury; + (void)clearok(stdscr, TRUE); + (void)refresh(); + break; +#ifdef NCURSES_MOUSE_VERSION + case KEY_MOUSE: + { + MEVENT myevent; + + getmouse(&myevent); + if (atcpu + && myevent.y >= CY(0) && myevent.y <= CY(BDEPTH) + && myevent.x >= CX(0) && myevent.x <= CX(BDEPTH)) + { + curx = CXINV(myevent.x); + cury = CYINV(myevent.y); + return(' '); + } + else + { + beep(); + continue; + } + } + /* no fall through */ +#endif /* NCURSES_MOUSE_VERSION */ + + default: + if (atcpu) + (void) mvaddstr(CYBASE + BDEPTH + 1, CXBASE + 11, " "); + else + (void) mvaddstr(PYBASE + BDEPTH + 1, PXBASE + 11, " "); + return(c); + } + + curx = nx % BWIDTH; + cury = ny % BDEPTH; + } +} + +static int collidecheck(int b, int y, int x) +/* is this location on the selected zboard adjacent to a ship? */ +{ + int collide; + + /* anything on the square */ + if ((collide = IS_SHIP(board[b][x][y])) != 0) + return(collide); + + /* anything on the neighbors */ + if (!closepack) + { + int i; + + for (i = 0; i < 8; i++) + { + int xend, yend; + + yend = y + yincr[i]; + xend = x + xincr[i]; + if (ONBOARD(xend, yend)) + collide += IS_SHIP(board[b][xend][yend]); + } + } + return(collide); +} + +static bool checkplace(int b, ship_t *ss, int vis) +{ + int l, xend, yend; + + /* first, check for board edges */ + xend = ss->x + ss->length * xincr[ss->dir]; + yend = ss->y + ss->length * yincr[ss->dir]; + if (!ONBOARD(xend, yend)) + { + if (vis) + switch(rnd(3)) + { + case 0: + error("Ship is hanging from the edge of the world"); + break; + case 1: + error("Try fitting it on the board"); + break; + case 2: + error("Figure I won't find it if you put it there?"); + break; + } + return(0); + } + + for(l = 0; l < ss->length; ++l) + { + if(collidecheck(b, ss->y+l*yincr[ss->dir], ss->x+l*xincr[ss->dir])) + { + if (vis) + switch(rnd(3)) + { + case 0: + error("There's already a ship there"); + break; + case 1: + error("Collision alert! Aaaaaagh!"); + break; + case 2: + error("Er, Admiral, what about the other ship?"); + break; + } + return(FALSE); + } + } + return(TRUE); +} + +static int awinna(void) +{ + int i, j; + ship_t *ss; + + for(i=0; i<2; ++i) + { + ss = (i) ? cpuship : plyship; + for(j=0; j < SHIPTYPES; ++j, ++ss) + if(ss->length > ss->hits) + break; + if (j == SHIPTYPES) + return(OTHER); + } + return(-1); +} + +static ship_t *hitship(int x, int y) +/* register a hit on the targeted ship */ +{ + ship_t *sb, *ss; + char sym; + int oldx, oldy; + + getyx(stdscr, oldy, oldx); + sb = (turn) ? plyship : cpuship; + if(!(sym = board[OTHER][x][y])) + return((ship_t *)NULL); + for(ss = sb; ss < sb + SHIPTYPES; ++ss) + if(ss->symbol == sym) + { + if (++ss->hits < ss->length) /* still afloat? */ + return((ship_t *)NULL); + else /* sunk! */ + { + int i, j; + + if (!closepack) + for (j = -1; j <= 1; j++) + { + int bx = ss->x + j * xincr[(ss->dir + 2) % 8]; + int by = ss->y + j * yincr[(ss->dir + 2) % 8]; + + for (i = -1; i <= ss->length; ++i) + { + int x1, y1; + + x1 = bx + i * xincr[ss->dir]; + y1 = by + i * yincr[ss->dir]; + if (ONBOARD(x1, y1)) + { + hits[turn][x1][y1] = MARK_MISS; + if (turn % 2 == PLAYER) + { + cgoto(y1, x1); +#ifdef A_COLOR + if (has_colors()) + attron(COLOR_PAIR(COLOR_GREEN)); +#endif /* A_COLOR */ + (void)addch(MARK_MISS); +#ifdef A_COLOR + attrset(0); +#endif /* A_COLOR */ + } + } + } + } + + for (i = 0; i < ss->length; ++i) + { + int x1 = ss->x + i * xincr[ss->dir]; + int y1 = ss->y + i * yincr[ss->dir]; + + hits[turn][x1][y1] = ss->symbol; + if (turn % 2 == PLAYER) + { + cgoto(y1, x1); + (void) addch((chtype)(ss->symbol)); + } + } + + (void) move(oldy, oldx); + return(ss); + } + } + (void) move(oldy, oldx); + return((ship_t *)NULL); +} + +static int plyturn(void) +{ + ship_t *ss; + bool hit; + char *m = NULL; + + prompt(1, "Where do you want to shoot? ", ""); + for (;;) + { + (void) getcoord(COMPUTER); + if (hits[PLAYER][curx][cury]) + { + prompt(1, "You shelled this spot already! Try again.", ""); + beep(); + } + else + break; + } + hit = IS_SHIP(board[COMPUTER][curx][cury]); + hits[PLAYER][curx][cury] = hit ? MARK_HIT : MARK_MISS; + cgoto(cury, curx); +#ifdef A_COLOR + if (has_colors()) + if (hit) + attron(COLOR_PAIR(COLOR_RED)); + else + attron(COLOR_PAIR(COLOR_GREEN)); +#endif /* A_COLOR */ + (void) addch((chtype)hits[PLAYER][curx][cury]); +#ifdef A_COLOR + attrset(0); +#endif /* A_COLOR */ + + prompt(1, "You %s.", hit ? "scored a hit" : "missed"); + if(hit && (ss = hitship(curx, cury))) + { + switch(rnd(5)) + { + case 0: + m = " You sank my %s!"; + break; + case 1: + m = " I have this sinking feeling about my %s...."; + break; + case 2: + m = " My %s has gone to Davy Jones's locker!"; + break; + case 3: + m = " Glub, glub -- my %s is headed for the bottom!"; + break; + case 4: + m = " You'll pick up survivors from my my %s, I hope...!"; + break; + } + (void)printw(m, ss->name); + (void)beep(); + return(awinna() == -1); + } + return(hit); +} + +static int sgetc(char *s) +{ + char *s1; + int ch; + + (void)refresh(); + for(;;) + { + ch = getch(); + if (islower(ch)) + ch = toupper(ch); + if (ch == CTRLC) + uninitgame(0); + for (s1=s; *s1 && ch != *s1; ++s1) + continue; + if (*s1) + { + (void) addch((chtype)ch); + (void)refresh(); + return(ch); + } + } +} + + +static void randomfire(int *px, int *py) +/* random-fire routine -- implements simple diagonal-striping strategy */ +{ + static int turncount = 0; + static int srchstep = BEGINSTEP; + static int huntoffs; /* Offset on search strategy */ + int ypossible[BWIDTH * BDEPTH], xpossible[BWIDTH * BDEPTH], nposs; + int ypreferred[BWIDTH * BDEPTH], xpreferred[BWIDTH * BDEPTH], npref; + int x, y, i; + + if (turncount++ == 0) + huntoffs = rnd(srchstep); + + /* first, list all possible moves */ + nposs = npref = 0; + for (x = 0; x < BWIDTH; x++) + for (y = 0; y < BDEPTH; y++) + if (!hits[COMPUTER][x][y]) + { + xpossible[nposs] = x; + ypossible[nposs] = y; + nposs++; + if (((x+huntoffs) % srchstep) != (y % srchstep)) + { + xpreferred[npref] = x; + ypreferred[npref] = y; + npref++; + } + } + + if (npref) + { + i = rnd(npref); + + *px = xpreferred[i]; + *py = ypreferred[i]; + } + else if (nposs) + { + i = rnd(nposs); + + *px = xpossible[i]; + *py = ypossible[i]; + + if (srchstep > 1) + --srchstep; + } + else + { + error("No moves possible?? Help!"); + exit(1); + /*NOTREACHED*/ + } +} + +#define S_MISS 0 +#define S_HIT 1 +#define S_SUNK -1 + +static bool cpufire(int x, int y) +/* fire away at given location */ +{ + bool hit, sunk; + ship_t *ss = NULL; + + hits[COMPUTER][x][y] = (hit = (board[PLAYER][x][y])) ? MARK_HIT : MARK_MISS; + (void) mvprintw(PROMPTLINE, 0, + "I shoot at %c%d. I %s!", y + 'A', x, hit ? "hit" : "miss"); + if ((sunk = (hit && (ss = hitship(x, y))))) + (void) printw(" I've sunk your %s", ss->name); + (void)clrtoeol(); + + pgoto(y, x); +#ifdef A_COLOR + if (has_colors()) + if (hit) + attron(COLOR_PAIR(COLOR_RED)); + else + attron(COLOR_PAIR(COLOR_GREEN)); +#endif /* A_COLOR */ + (void)addch((chtype)(hit ? SHOWHIT : SHOWSPLASH)); +#ifdef A_COLOR + attrset(0); +#endif /* A_COLOR */ + + return(hit ? (sunk ? S_SUNK : S_HIT) : S_MISS); +} + +/* + * This code implements a fairly irregular FSM, so please forgive the rampant + * unstructuredness below. The five labels are states which need to be held + * between computer turns. + */ +static bool cputurn(void) +{ +#define POSSIBLE(x, y) (ONBOARD(x, y) && !hits[COMPUTER][x][y]) +#define RANDOM_FIRE 0 +#define RANDOM_HIT 1 +#define HUNT_DIRECT 2 +#define FIRST_PASS 3 +#define REVERSE_JUMP 4 +#define SECOND_PASS 5 + static int next = RANDOM_FIRE; + static bool used[4]; + static ship_t ts; + int navail, x, y, d, n, hit = S_MISS; + + switch(next) + { + case RANDOM_FIRE: /* last shot was random and missed */ + refire: + randomfire(&x, &y); + if (!(hit = cpufire(x, y))) + next = RANDOM_FIRE; + else + { + ts.x = x; ts.y = y; + ts.hits = 1; + next = (hit == S_SUNK) ? RANDOM_FIRE : RANDOM_HIT; + } + break; + + case RANDOM_HIT: /* last shot was random and hit */ + used[E/2] = used[S/2] = used[W/2] = used[N/2] = FALSE; + /* FALLTHROUGH */ + + case HUNT_DIRECT: /* last shot hit, we're looking for ship's long axis */ + for (d = navail = 0; d < 4; d++) + { + x = ts.x + xincr[d*2]; y = ts.y + yincr[d*2]; + if (!used[d] && POSSIBLE(x, y)) + navail++; + else + used[d] = TRUE; + } + if (navail == 0) /* no valid places for shots adjacent... */ + goto refire; /* ...so we must random-fire */ + else + { + for (d = 0, n = rnd(navail) + 1; n; n--) + while (used[d]) + d++; + + assert(d <= 4); + + used[d] = FALSE; + x = ts.x + xincr[d*2]; + y = ts.y + yincr[d*2]; + + assert(POSSIBLE(x, y)); + + if (!(hit = cpufire(x, y))) + next = HUNT_DIRECT; + else + { + ts.x = x; ts.y = y; ts.dir = d*2; ts.hits++; + next = (hit == S_SUNK) ? RANDOM_FIRE : FIRST_PASS; + } + } + break; + + case FIRST_PASS: /* we have a start and a direction now */ + x = ts.x + xincr[ts.dir]; + y = ts.y + yincr[ts.dir]; + if (POSSIBLE(x, y) && (hit = cpufire(x, y))) + { + ts.x = x; ts.y = y; ts.hits++; + next = (hit == S_SUNK) ? RANDOM_FIRE : FIRST_PASS; + } + else + next = REVERSE_JUMP; + break; + + case REVERSE_JUMP: /* nail down the ship's other end */ + d = ts.dir + 4; + x = ts.x + ts.hits * xincr[d]; + y = ts.y + ts.hits * yincr[d]; + if (POSSIBLE(x, y) && (hit = cpufire(x, y))) + { + ts.x = x; ts.y = y; ts.dir = d; ts.hits++; + next = (hit == S_SUNK) ? RANDOM_FIRE : SECOND_PASS; + } + else + next = RANDOM_FIRE; + break; + + case SECOND_PASS: /* kill squares not caught on first pass */ + x = ts.x + xincr[ts.dir]; + y = ts.y + yincr[ts.dir]; + if (POSSIBLE(x, y) && (hit = cpufire(x, y))) + { + ts.x = x; ts.y = y; ts.hits++; + next = (hit == S_SUNK) ? RANDOM_FIRE: SECOND_PASS; + break; + } + else + next = RANDOM_FIRE; + break; + } + + /* check for continuation and/or winner */ + if (salvo) + { + (void)refresh(); + (void)sleep(1); + } + if (awinna() != -1) + return(FALSE); + +#ifdef DEBUG + (void) mvprintw(PROMPTLINE + 2, 0, + "New state %d, x=%d, y=%d, d=%d", + next, x, y, d); +#endif /* DEBUG */ + return(hit); +} + +static +int playagain(void) +{ + int j; + ship_t *ss; + + for (ss = cpuship; ss < cpuship + SHIPTYPES; ss++) + for(j = 0; j < ss->length; j++) + { + cgoto(ss->y + j * yincr[ss->dir], ss->x + j * xincr[ss->dir]); + (void)addch((chtype)ss->symbol); + } + + if(awinna()) + ++cpuwon; + else + ++plywon; + j = 18 + strlen(name); + if(plywon >= 10) + ++j; + if(cpuwon >= 10) + ++j; + (void) mvprintw(1,(COLWIDTH-j)/2, + "%s: %d Computer: %d",name,plywon,cpuwon); + + prompt(2, (awinna()) ? "Want to be humiliated again, %s [yn]? " + : "Going to give me a chance for revenge, %s [yn]? ",name); + return(sgetc("YN") == 'Y'); +} + +static void do_options(int c, char *op[]) +{ + register int i; + + if (c > 1) + { + for (i=1; ihits >= sp->length) + continue; /* dead ship */ + else + shots++; + } + return(shots); +} + +int main(int argc, char *argv[]) +{ + do_options(argc, argv); + + intro(); + do { + initgame(); + while(awinna() == -1) + { + if (!blitz) + { + if (!salvo) + { + if(turn) + (void) cputurn(); + else + (void) plyturn(); + } + else + { + register int i; + + i = scount(turn); + while (i--) + { + if (turn) + { + if (cputurn() && awinna() != -1) + i = 0; + } + else + { + if (plyturn() && awinna() != -1) + i = 0; + } + } + } + } + else + while(turn ? cputurn() : plyturn()) + continue; + turn = OTHER; + } + } while + (playagain()); + uninitgame(0); + /*NOTREACHED*/ + return 1; +} + +/* bs.c ends here */ diff --git a/libslang/src/curses/firework.c b/libslang/src/curses/firework.c new file mode 100644 index 0000000..f4aa51a --- /dev/null +++ b/libslang/src/curses/firework.c @@ -0,0 +1,123 @@ +#include +#include +#include +#include +#include +#include +#include + +static int get_colour(void); +static void explode(int row, int col); +static void showit(void); + +int main(int argc, char *argv[]) +{ +int start,end,row,diff,flag = 0,direction; +unsigned seed; + + initscr(); + if (has_colors()) + start_color(); + seed = time((time_t *)0); + srand(seed); + cbreak(); + for (;;) { + do { + start = rand() % (COLS -3); + end = rand() % (COLS - 3); + start = (start < 2) ? 2 : start; + end = (end < 2) ? 2 : end; + direction = (start > end) ? -1 : 1; + diff = abs(start-end); + } while (diff<2 || diff>=LINES-2); + attrset(A_NORMAL); + for (row=1;row 8) + attr |= A_BOLD; + return(attr); +} + +static void +showit(void) +{ + refresh(); + napms(120); +} diff --git a/libslang/src/curses/gdc.c b/libslang/src/curses/gdc.c new file mode 100644 index 0000000..4e549f4 --- /dev/null +++ b/libslang/src/curses/gdc.c @@ -0,0 +1,212 @@ +/* + * Grand digital clock for curses compatible terminals + * Usage: gdc [-s] [n] -- run for n seconds (default infinity) + * Flags: -s: scroll + * + * modified 10-18-89 for curses (jrl) + * 10-18-89 added signal handling + */ + +#include +#include +#include +#include +#include +#ifndef NONPOSIX +#include +#endif + +#define YBASE 10 +#define XBASE 10 +#define XLENGTH 54 +#define YDEPTH 5 + +/* it won't be */ +time_t now; /* yeah! */ +struct tm *tm; + +short disp[11] = { + 075557, 011111, 071747, 071717, 055711, + 074717, 074757, 071111, 075757, 075717, 002020 +}; +long old[6], next[6], new[6], mask; +char scrol; + +int sigtermed=0; + +int hascolor = 0; + +void set(int, int); +void standt(int); +void movto(int, int); + +static +void sighndl(int signo) +{ + signal(signo, sighndl); + sigtermed=signo; +} + +int +main(int argc, char *argv[]) +{ +long t, a; +int i, j, s, k; +int n = 0; + + signal(SIGINT,sighndl); + signal(SIGTERM,sighndl); + signal(SIGKILL,sighndl); + + initscr(); + cbreak(); + noecho(); + nodelay(stdscr, 1); + + hascolor = has_colors(); + + if(hascolor) { + start_color(); + init_pair(1, COLOR_BLACK, COLOR_RED); + init_pair(2, COLOR_RED, COLOR_BLACK); + init_pair(3, COLOR_WHITE, COLOR_BLACK); + attrset(COLOR_PAIR(2)); + } + + clear(); + refresh(); + while(--argc > 0) { + if(**++argv == '-') + scrol = 1; + else + n = atoi(*argv); + } + + if(hascolor) { + attrset(COLOR_PAIR(3)); + + mvaddch(YBASE - 1, XBASE - 1, ACS_ULCORNER); + hline(ACS_HLINE, XLENGTH); + mvaddch(YBASE - 1, XBASE + XLENGTH, ACS_URCORNER); + + mvaddch(YBASE + YDEPTH, XBASE - 1, ACS_LLCORNER); + hline(ACS_HLINE, XLENGTH); + mvaddch(YBASE + YDEPTH, XBASE + XLENGTH, ACS_LRCORNER); + + move(YBASE, XBASE - 1); + vline(ACS_VLINE, YDEPTH); + + move(YBASE, XBASE + XLENGTH); + vline(ACS_VLINE, YDEPTH); + + attrset(COLOR_PAIR(2)); + } + do { + char buf[30]; + + mask = 0; + time(&now); + tm = localtime(&now); + set(tm->tm_sec%10, 0); + set(tm->tm_sec/10, 4); + set(tm->tm_min%10, 10); + set(tm->tm_min/10, 14); + set(tm->tm_hour%10, 20); + set(tm->tm_hour/10, 24); + set(10, 7); + set(10, 17); + for(k=0; k<6; k++) { + if(scrol) { + for(i=0; i<5; i++) + new[i] = (new[i]&~mask) | (new[i+1]&mask); + new[5] = (new[5]&~mask) | (next[k]&mask); + } else + new[k] = (new[k]&~mask) | (next[k]&mask); + next[k] = 0; + for(s=1; s>=0; s--) { + standt(s); + for(i=0; i<6; i++) { + if((a = (new[i]^old[i])&(s ? new : old)[i]) != 0) { + for(j=0,t=1<<26; t; t>>=1,j++) { + if(a&t) { + if(!(a&(t<<1))) { + movto(YBASE + i, XBASE + 2*j); + } + addstr(" "); + } + } + } + if(!s) { + old[i] = new[i]; + } + } + if(!s) { + refresh(); + } + } + } + + /* this depends on the detailed format of ctime(3) */ + (void) strcpy(buf, ctime(&now)); + (void) strcpy(buf + 10, buf + 19); + mvaddstr(16, 30, buf); + + movto(6, 0); + refresh(); + sleep(1); + while(wgetch(stdscr) != ERR) + continue; + if (sigtermed) { + standend(); + clear(); + refresh(); + endwin(); + fprintf(stderr, "gdc terminated by signal %d\n", sigtermed); + exit(1); + } + } while(--n); + standend(); + clear(); + refresh(); + endwin(); + return(0); +} + +void +set(int t, int n) +{ +int i, m; + + m = 7<>(4-i)*3)&07)< +#include +#include +#include + +#define NPEGS 3 /* This is not configurable !! */ +#define MINTILES 3 +#define MAXTILES 9 +#define DEFAULTTILES 7 +#define TOPLINE 6 +#define BASELINE 16 +#define STATUSLINE (LINES-3) +#define LEFTPEG 19 +#define MIDPEG 39 +#define RIGHTPEG 59 + +#define LENTOIND(x) (((x)-1)/2) +#define OTHER(a,b) (3-((a)+(b))) + +struct Peg { + size_t Length[MAXTILES]; + int Count; +}; + +struct Peg Pegs[NPEGS]; +int PegPos[] = { LEFTPEG, MIDPEG, RIGHTPEG }; +int TileColour[] = { + COLOR_GREEN, /* Length 3 */ + COLOR_MAGENTA, /* Length 5 */ + COLOR_RED, /* Length 7 */ + COLOR_BLUE, /* Length 9 */ + COLOR_CYAN, /* Length 11 */ + COLOR_YELLOW, /* Length 13 */ + COLOR_GREEN, /* Length 15 */ + COLOR_MAGENTA, /* Length 17 */ + COLOR_RED, /* Length 19 */ +}; +int NMoves = 0; + +void InitTiles(int NTiles); +void DisplayTiles(void); +void MakeMove(int From, int To); +void AutoMove(int From, int To, int Num); +void Usage(void); +int Solved(int NumTiles); +int GetMove(int *From, int *To); +int InvalidMove(int From, int To); + +int +main(int argc, char **argv) +{ +int NTiles, FromCol, ToCol; +unsigned char AutoFlag = 0; + + switch(argc) { + case 1: + NTiles = DEFAULTTILES; + break; + case 2: + NTiles = atoi(argv[1]); + if (NTiles > MAXTILES || NTiles < MINTILES) { + fprintf(stderr, "Range %d to %d\n", MINTILES, MAXTILES); + exit(1); + } + break; + case 3: + if (strcmp(argv[2], "a")) { + Usage(); + exit(1); + } + NTiles = atoi(argv[1]); + if (NTiles > MAXTILES || NTiles < MINTILES) { + fprintf(stderr, "Range %d to %d\n", MINTILES, MAXTILES); + exit(1); + } + AutoFlag = TRUE; + break; + default: + Usage(); + exit(1); + } +#ifdef NCURSES_VERSION + trace(TRACE_MAXIMUM); +#endif + initscr(); + if (!has_colors()) { + endwin(); + puts("terminal doesn't support color."); + exit(1); + } + start_color(); + { + int i; + for (i = 0; i < 9; i++) + init_pair(i+1, COLOR_BLACK, TileColour[i]); + } + cbreak(); + if (LINES < 24) { + endwin(); + fprintf(stderr, "Min screen length 24 lines\n"); + exit(1); + } + if(AutoFlag) + leaveok(stdscr, TRUE); /* Attempt to remove cursor */ + InitTiles(NTiles); + DisplayTiles(); + if(AutoFlag) { + do { + noecho(); + AutoMove(0, 2, NTiles); + } while(!Solved(NTiles)); + sleep(2); + } else { + for(;;) { + if(GetMove(&FromCol, &ToCol)) + break; + if(InvalidMove(FromCol, ToCol)) { + mvaddstr(STATUSLINE, 0, "Invalid Move !!"); + refresh(); + beep(); + continue; + } + MakeMove(FromCol, ToCol); + if(Solved(NTiles)) { + mvprintw(STATUSLINE, 0, "Well Done !! You did it in %d moves", NMoves); + refresh(); + sleep(5); + break; + } + } + } + curs_set(1); + endwin(); + exit(0); +} + +int +InvalidMove(int From, int To) +{ + if(From >= NPEGS) + return TRUE; + if(From < 0) + return TRUE; + if(To >= NPEGS) + return TRUE; + if(To < 0) + return TRUE; + if(From == To) + return TRUE; + if(!Pegs[From].Count) + return TRUE; + if(Pegs[To].Count && + Pegs[From].Length[Pegs[From].Count-1] > + Pegs[To].Length[Pegs[To].Count-1]) + return TRUE; + return FALSE; +} + +void +InitTiles(int NTiles) +{ +int Size, SlotNo; + + for(Size=NTiles*2+1, SlotNo=0; Size>=3; Size-=2) + Pegs[0].Length[SlotNo++] = Size; + + Pegs[0].Count = NTiles; + Pegs[1].Count = 0; + Pegs[2].Count = 0; +} + +void +DisplayTiles() +{ + int Line, Peg, SlotNo; + char TileBuf[BUFSIZ]; + + erase(); + mvaddstr(1, 24, "T O W E R S O F H A N O I"); + mvaddstr(3, 34, "SJR 1990"); + mvprintw(19, 5, "Moves : %d", NMoves); + attrset(A_REVERSE); + mvaddstr(BASELINE, 8, " "); + + for(Line=TOPLINE; Line] [a]\n"); + fprintf(stderr, "The 'a' option causes the tower to be solved automatically\n"); +} + diff --git a/libslang/src/curses/knight.c b/libslang/src/curses/knight.c new file mode 100644 index 0000000..7314eac --- /dev/null +++ b/libslang/src/curses/knight.c @@ -0,0 +1,555 @@ +/* + * Knight's Tour - a brain game + * + * The original of this game was anonymous. It had an unbelievably bogus + * interface, you actually had to enter square coordinates! Redesign by + * Eric S. Raymond July 22 1995. Mouse support + * added September 20th 1995. + */ + +#include +#include +#include +#include +#include +#include + +/* board size */ +#define BDEPTH 8 +#define BWIDTH 8 + +/* where to start the instructions */ +#define INSTRY 2 +#define INSTRX 35 + +/* corner of board */ +#define BOARDY 2 +#define BOARDX 0 + +/* notification line */ +#define NOTIFYY 21 + +/* virtual color values */ +#define TRAIL_COLOR 1 +#define PLUS_COLOR 2 +#define MINUS_COLOR 3 + +#define CX(x) (2 + 4 * (x)) +#define CY(y) (1 + 2 * (y)) +#define cellmove(y, x) wmove(boardwin, CY(y), CX(x)) +#define CXINV(x) (((x) - 1) / 4) +#define CYINV(y) (((y) - 2) / 2) + +typedef struct +{ + short x, y; +} +cell; + +static short board[BDEPTH][BWIDTH]; /* the squares */ +static int rw,col; /* current row and column */ +static int lastrow,lastcol; /* last location visited */ +static cell history[BDEPTH*BWIDTH]; /* choice history */ +static int movecount; /* count of moves so far */ +static WINDOW *boardwin; /* the board window */ +static WINDOW *helpwin; /* the help window */ +static WINDOW *msgwin; /* the message window */ +static chtype trail = '#'; /* trail character */ +static chtype plus = '+'; /* cursor hot-spot character */ +static chtype minus = '-'; /* possible-move character */ +static chtype oldch; + +static void init(void); +static void play(void); +static void dosquares(void); +static void drawmove(char, int, int, int, int); +static bool evalmove(int, int); +static bool chkmoves(void); +static bool chksqr(int, int); +static int iabs(int); + +int main(int argc, char *argv[]) +{ + init(); + + play(); + + endwin(); + exit(0); +} + +static void init (void) +{ + srand ((unsigned)getpid()); + initscr (); + cbreak (); /* immediate char return */ + noecho (); /* no immediate echo */ + boardwin = newwin(BDEPTH * 2 + 1, BWIDTH * 4 + 1, BOARDY, BOARDX); + helpwin = newwin(0, 0, INSTRY, INSTRX); + msgwin = newwin(1, INSTRX-1, NOTIFYY, 0); + keypad(boardwin, TRUE); + + if (has_colors()) + { + start_color(); + + (void) init_pair(TRAIL_COLOR, COLOR_CYAN, COLOR_BLACK); + (void) init_pair(PLUS_COLOR, COLOR_RED, COLOR_BLACK); + (void) init_pair(MINUS_COLOR, COLOR_GREEN, COLOR_BLACK); + + trail |= COLOR_PAIR(TRAIL_COLOR); + plus |= COLOR_PAIR(PLUS_COLOR); + minus |= COLOR_PAIR(MINUS_COLOR); + } + +#ifdef NCURSES_MOUSE_VERSION + (void) mousemask(BUTTON1_CLICKED, (mmask_t *)NULL); +#endif /* NCURSES_MOUSE_VERSION*/ + + oldch = minus; +} + +static void help1(void) +/* game explanation -- initial help screen */ +{ + (void)waddstr(helpwin, "Knight's move is a solitaire puzzle. Your\n"); + (void)waddstr(helpwin, "objective is to visit each square of the \n"); + (void)waddstr(helpwin, "chessboard exactly once by making knight's\n"); + (void)waddstr(helpwin, "moves (one square right or left followed \n"); + (void)waddstr(helpwin, "by two squares up or down, or two squares \n"); + (void)waddstr(helpwin, "right or left followed by one square up or\n"); + (void)waddstr(helpwin, "down). You may start anywhere.\n\n"); + + (void)waddstr(helpwin, "Use arrow keys to move the cursor around.\n"); + (void)waddstr(helpwin, "When you want to move your knight to the \n"); + (void)waddstr(helpwin, "cursor location, press or Enter.\n"); + (void)waddstr(helpwin, "Illegal moves will be rejected with an \n"); + (void)waddstr(helpwin, "audible beep.\n\n"); + (void)waddstr(helpwin, "The program will detect if you solve the\n"); + (void)waddstr(helpwin, "puzzle; also inform you when you run out\n"); + (void)waddstr(helpwin, "of legal moves.\n\n"); + + (void)mvwaddstr(helpwin, NOTIFYY-INSTRY, 0, + "Press `?' to go to keystroke help."); +} + +static void help2(void) +/* keystroke help screen */ +{ + (void)waddstr(helpwin, "Possible moves are shown with `-'.\n\n"); + + (void)waddstr(helpwin, "You can move around with the arrow keys or\n"); + (void)waddstr(helpwin, "with the rogue/hack movement keys. Other\n"); + (void)waddstr(helpwin, "commands allow you to undo moves or redraw.\n"); + (void)waddstr(helpwin, "Your mouse may work; try left-button to\n"); + (void)waddstr(helpwin, "move to the square under the pointer.\n\n"); + + (void)waddstr(helpwin, "x,q -- exit y k u 7 8 9\n"); + (void)waddstr(helpwin, "r -- redraw screen \\|/ \\|/ \n"); + (void)waddstr(helpwin, "u -- undo move h-+-l 4-+-6\n"); + (void)waddstr(helpwin, " /|\\ /|\\ \n"); + (void)waddstr(helpwin, " b j n 1 2 3\n"); + + (void)waddstr(helpwin,"\nYou can place your knight on the selected\n"); + (void)waddstr(helpwin, "square with spacebar, Enter, or the keypad\n"); + (void)waddstr(helpwin, "center key. You can quit with `x' or `q'.\n"); + + (void)mvwaddstr(helpwin, NOTIFYY-INSTRY, 0, + "Press `?' to go to game explanation"); +} + +static void play (void) +/* play the game */ +{ + bool keyhelp; /* TRUE if keystroke help is up */ + int c, ny = 0, nx = 0; + int i, j, count; + + do { + /* clear screen and draw board */ + werase(boardwin); + werase(helpwin); + werase(msgwin); + dosquares(); + help1(); + wnoutrefresh(stdscr); + wnoutrefresh(helpwin); + wnoutrefresh(msgwin); + wnoutrefresh(boardwin); + doupdate(); + + for (i = 0; i < BDEPTH; i++) + for (j = 0; j < BWIDTH; j++) + { + board[i][j] = FALSE; + cellmove(i, j); + waddch(boardwin, minus); + } + memset(history, '\0', sizeof(history)); + history[0].y = history[0].x = -1; + lastrow = lastcol = -2; + movecount = 1; + keyhelp = FALSE; + + for (;;) + { + if (rw != lastrow || col != lastcol) + { + if (lastrow >= 0 && lastcol >= 0) + { + cellmove(lastrow, lastcol); + if (board[lastrow][lastcol]) + waddch(boardwin, trail); + else + waddch(boardwin, oldch); + } + + cellmove(rw, col); + oldch = winch(boardwin); + + lastrow = rw; + lastcol= col; + } + cellmove(rw, col); + waddch(boardwin, plus); + cellmove(rw, col); + + wrefresh(msgwin); + + c = wgetch(boardwin); + + werase(msgwin); + + switch (c) + { + case 'k': case '8': + case KEY_UP: + ny = rw+BDEPTH-1; nx = col; + break; + case 'j': case '2': + case KEY_DOWN: + ny = rw+1; nx = col; + break; + case 'h': case '4': + case KEY_LEFT: + ny = rw; nx = col+BWIDTH-1; + break; + case 'l': case '6': + case KEY_RIGHT: + ny = rw; nx = col+1; + break; + case 'y': case '7': + case KEY_A1: + ny = rw+BDEPTH-1; nx = col+BWIDTH-1; + break; + case 'b': case '1': + case KEY_C1: + ny = rw+1; nx = col+BWIDTH-1; + break; + case 'u': case '9': + case KEY_A3: + ny = rw+BDEPTH-1; nx = col+1; + break; + case 'n': case '3': + case KEY_C3: + ny = rw+1; nx = col+1; + break; + +#ifdef NCURSES_MOUSE_VERSION + case KEY_MOUSE: + { + MEVENT myevent; + + getmouse(&myevent); + if (myevent.y >= CY(0) && myevent.y <= CY(BDEPTH) + && myevent.x >= CX(0) && myevent.x <= CX(BWIDTH)) + { + nx = CXINV(myevent.x); + ny = CYINV(myevent.y); + ungetch('\n'); + break; + } + else + { + beep(); + continue; + } + } +#endif /* NCURSES_MOUSE_VERSION */ + + case KEY_B2: + case '\n': + case ' ': + if (evalmove(rw, col)) + { + drawmove(trail, + history[movecount-1].y, history[movecount-1].x, + rw, col); + history[movecount].y = rw; + history[movecount].x = col; + movecount++; + + if (!chkmoves()) + goto dropout; + } + else + beep(); + break; + + case KEY_REDO: + case '\f': + case 'r': + clearok(curscr, TRUE); + wnoutrefresh(stdscr); + wnoutrefresh(boardwin); + wnoutrefresh(msgwin); + wnoutrefresh(helpwin); + doupdate(); + break; + + case KEY_UNDO: + case KEY_BACKSPACE: + case '\b': + if (movecount == 1) + { + ny = lastrow; + nx = lastcol; + waddstr(msgwin, "\nNo previous move."); + beep(); + } + else + { + int oldy = history[movecount-1].y; + int oldx = history[movecount-1].x; + + board[oldy][oldx] = FALSE; + --movecount; + ny = history[movecount-1].y; + nx = history[movecount-1].x; + drawmove(' ', oldy, oldx, ny, nx); + + /* avoid problems if we just changed the current cell */ + cellmove(lastrow, lastcol); + oldch = winch(boardwin); + } + break; + + case 'q': + case 'x': + goto dropout; + + case '?': + werase(helpwin); + if (keyhelp) + { + help1(); + keyhelp = FALSE; + } + else + { + help2(); + keyhelp = TRUE; + } + wrefresh(helpwin); + break; + + default: + beep(); + break; + } + + col = nx % BWIDTH; + rw = ny % BDEPTH; + } + + dropout: + count = 0; + for (i = 0; i < BDEPTH; i++) + for (j = 0; j < BWIDTH; j++) + if (board[i][j] != 0) + count += 1; + if (count == (BWIDTH * BDEPTH)) + wprintw(msgwin, "\nYou won. Care to try again? "); + else + wprintw(msgwin, "\n%d squares filled. Try again? ", count); + } while + (tolower(wgetch(msgwin)) == 'y'); +} + +static void dosquares (void) +{ + int i, j; + + mvaddstr(0, 20, "KNIGHT'S MOVE -- a logical solitaire"); + + move(BOARDY,BOARDX); + waddch(boardwin, ACS_ULCORNER); + for (j = 0; j < 7; j++) + { + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_TTEE); + } + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_URCORNER); + + for (i = 1; i < BDEPTH; i++) + { + move(BOARDY + i * 2 - 1, BOARDX); + waddch(boardwin, ACS_VLINE); + for (j = 0; j < BWIDTH; j++) + { + waddch(boardwin, ' '); + waddch(boardwin, ' '); + waddch(boardwin, ' '); + waddch(boardwin, ACS_VLINE); + } + move(BOARDY + i * 2, BOARDX); + waddch(boardwin, ACS_LTEE); + for (j = 0; j < BWIDTH - 1; j++) + { + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_PLUS); + } + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_RTEE); + } + + move(BOARDY + i * 2 - 1, BOARDX); + waddch(boardwin, ACS_VLINE); + for (j = 0; j < BWIDTH; j++) + { + waddch(boardwin, ' '); + waddch(boardwin, ' '); + waddch(boardwin, ' '); + waddch(boardwin, ACS_VLINE); + } + + move(BOARDY + i * 2, BOARDX); + waddch(boardwin, ACS_LLCORNER); + for (j = 0; j < BWIDTH - 1; j++) + { + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_BTEE); + } + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_HLINE); + waddch(boardwin, ACS_LRCORNER); +} + +static void mark_possibles(int prow, int pcol, chtype mark) +{ + if (chksqr(prow+2,pcol+1)){cellmove(prow+2,pcol+1);waddch(boardwin,mark);}; + if (chksqr(prow+2,pcol-1)){cellmove(prow+2,pcol-1);waddch(boardwin,mark);}; + if (chksqr(prow-2,pcol+1)){cellmove(prow-2,pcol+1);waddch(boardwin,mark);}; + if (chksqr(prow-2,pcol-1)){cellmove(prow-2,pcol-1);waddch(boardwin,mark);}; + if (chksqr(prow+1,pcol+2)){cellmove(prow+1,pcol+2);waddch(boardwin,mark);}; + if (chksqr(prow+1,pcol-2)){cellmove(prow+1,pcol-2);waddch(boardwin,mark);}; + if (chksqr(prow-1,pcol+2)){cellmove(prow-1,pcol+2);waddch(boardwin,mark);}; + if (chksqr(prow-1,pcol-2)){cellmove(prow-1,pcol-2);waddch(boardwin,mark);}; +} + +static void drawmove(char tchar, int oldy, int oldx, int row, int column) +/* place the stars, update board & currents */ +{ + if (movecount <= 1) + { + int i, j; + + for (i = 0; i < BDEPTH; i++) + for (j = 0; j < BWIDTH; j++) + { + cellmove(i, j); + if (winch(boardwin) == minus) + waddch(boardwin, movecount ? ' ' : minus); + } + } + else + { + cellmove(oldy, oldx); + waddch(boardwin, '\b'); + waddch(boardwin, tchar); + waddch(boardwin, tchar); + waddch(boardwin, tchar); + mark_possibles(oldy, oldx, ' '); + } + + if (row != -1 && column != -1) + { + cellmove(row, column); + waddch(boardwin, '\b'); + waddch(boardwin, trail); + waddch(boardwin, trail); + waddch(boardwin, trail); + mark_possibles(row, column, minus); + board[row][column] = TRUE; + } + + wprintw(msgwin, "\nMove %d", movecount); +} + +static bool evalmove(int row, int column) +/* evaluate move */ +{ + if (movecount == 1) + return(TRUE); + else if (board[row][column] == TRUE) + { + waddstr(msgwin, "\nYou've already been there."); + return(FALSE); + } + else + { + int rdif = iabs(row - history[movecount-1].y); + int cdif = iabs(column - history[movecount-1].x); + + if (!((rdif == 1) && (cdif == 2)) && !((rdif == 2) && (cdif == 1))) + { + waddstr(msgwin, "\nThat's not a legal knight's move."); + return(FALSE); + } + } + + return(TRUE); +} + +static bool chkmoves (void) +/* check to see if valid moves are available */ +{ + if (chksqr(rw+2,col+1)) return(TRUE); + if (chksqr(rw+2,col-1)) return(TRUE); + if (chksqr(rw-2,col+1)) return(TRUE); + if (chksqr(rw-2,col-1)) return(TRUE); + if (chksqr(rw+1,col+2)) return(TRUE); + if (chksqr(rw+1,col-2)) return(TRUE); + if (chksqr(rw-1,col+2)) return(TRUE); + if (chksqr(rw-1,col-2)) return(TRUE); + return (FALSE); +} + +static int iabs(int num) +{ + if (num < 0) return (-num); + else return (num); +} + +static bool chksqr (int r1, int c1) +{ + if ((r1 < 0) || (r1 > BDEPTH - 1)) + return(FALSE); + if ((c1 < 0) || (c1 > BWIDTH - 1)) + return(FALSE); + return (!board[r1][c1]); +} + +/* knight.c ends here */ diff --git a/libslang/src/curses/rain.c b/libslang/src/curses/rain.c new file mode 100644 index 0000000..792dab9 --- /dev/null +++ b/libslang/src/curses/rain.c @@ -0,0 +1,97 @@ +#include +#include +#include + +/* rain 11/3/1980 EPS/CITHEP */ + +#define cursor(col,row) move(row,col) + +float ranf(void); +void onsig(int sig); + +int +main(int argc, char *argv[]) +{ +int x, y, j; +static int xpos[5], ypos[5]; +float r; +float c; + + for (j=SIGHUP;j<=SIGTERM;j++) + if (signal(j,SIG_IGN)!=SIG_IGN) signal(j,onsig); + + initscr(); + nl(); + noecho(); + r = (float)(LINES - 4); + c = (float)(COLS - 4); + for (j=5;--j>=0;) { + xpos[j]=(int)(c* ranf())+2; + ypos[j]=(int)(r* ranf())+2; + } + for (j=0;;) { + x=(int)(c*ranf())+2; + y=(int)(r*ranf())+2; + + cursor(x,y); addch('.'); + + cursor(xpos[j],ypos[j]); addch('o'); + + if (j==0) j=4; else --j; + cursor(xpos[j],ypos[j]); addch('O'); + + if (j==0) j=4; else --j; + cursor(xpos[j],ypos[j]-1); + addch('-'); + cursor(xpos[j]-1,ypos[j]); + addstr("|.|"); + cursor(xpos[j],ypos[j]+1); + addch('-'); + + if (j==0) j=4; else --j; + cursor(xpos[j],ypos[j]-2); + addch('-'); + cursor(xpos[j]-1,ypos[j]-1); + addstr("/ \\"); + cursor(xpos[j]-2,ypos[j]); + addstr("| O |"); + cursor(xpos[j]-1,ypos[j]+1); + addstr("\\ /"); + cursor(xpos[j],ypos[j]+2); + addch('-'); + + if (j==0) j=4; else --j; + cursor(xpos[j],ypos[j]-2); + addch(' '); + cursor(xpos[j]-1,ypos[j]-1); + addstr(" "); + cursor(xpos[j]-2,ypos[j]); + addstr(" "); + cursor(xpos[j]-1,ypos[j]+1); + addstr(" "); + cursor(xpos[j],ypos[j]+2); + addch(' '); + xpos[j]=x; ypos[j]=y; + refresh(); + napms(50); + } +} + +void +onsig(int n) +{ + endwin(); + exit(n); +} + +float +ranf(void) +{ + float rv; + long r = rand(); + + r &= 077777; + rv =((float)r/32767.); + return rv; +} + diff --git a/libslang/src/curses/tclock.c b/libslang/src/curses/tclock.c new file mode 100644 index 0000000..12c0125 --- /dev/null +++ b/libslang/src/curses/tclock.c @@ -0,0 +1,177 @@ +#include +#include +#include +#include +#include +#include +#include + +/* + tclock - analog/digital clock for curses. + If it gives you joy, then + (a) I'm glad + (b) you need to get out more :-) + + This program is copyright Howard Jones, September 1994 + (ha.jones@ic.ac.uk). It may be freely distributed as + long as this copyright message remains intact, and any + modifications are clearly marked as such. [In fact, if + you modify it, I wouldn't mind the modifications back, + especially if they add any nice features. A good one + would be a precalc table for the 60 hand positions, so + that the floating point stuff can be ditched. As I said, + it was a 20 hackup minute job.] + + COMING SOON: tfishtank. Be the envy of your mac-owning + colleagues. +*/ + +/* To compile: cc -o tclock tclock.c -lcurses -lm */ + +#ifndef PI +#define PI 3.141592654 +#endif + +#define sign(_x) (_x<0?-1:1) + +/* Plot a point */ +static void +plot(int x,int y,char col) +{ + mvaddch(y,x,(chtype)col); +} + + +/* Draw a diagonal(arbitrary) line using Bresenham's alogrithm. */ +static void +dline(int from_x, int from_y, int x2, int y2, char ch) +{ + int dx,dy; + int ax,ay; + int sx,sy; + int x,y; + int d; + + dx=x2-from_x; + dy=y2-from_y; + + ax=abs(dx*2); + ay=abs(dy*2); + + sx=sign(dx); + sy=sign(dy); + + x=from_x; + y=from_y; + + if(ax>ay) + { + d=ay-(ax/2); + + while(1) + { + plot(x,y,ch); + if(x==x2) return; + + if(d>=0) + { + y+=sy; + d-=ax; + } + x+=sx; + d+=ay; + } + } + else + { + d=ax-(ay/2); + + while(1) + { + plot(x,y,ch); + if(y==y2) return; + + if(d>=0) + { + x+=sx; + d-=ay; + } + y+=sy; + d+=ax; + } + } +} + +int +main(int argc, char **argv) +{ + int i,cx,cy; + double mradius, hradius, mangle, hangle; + double sangle, sradius, hours; + int hdx, hdy; + int mdx, mdy; + int sdx, sdy; + time_t tim; + struct tm *t; + char szChar[10]; + + initscr(); + noecho(); + + cx=39; + cy=12; + mradius=9; + hradius=6; + sradius=8; + + for(i=0;i<12;i++) + { + sangle=(i+1)*(2.0*PI)/12.0; + sradius=10; + sdx=2.0*sradius*sin(sangle); + sdy=sradius*cos(sangle); + sprintf(szChar,"%d",i+1); + + mvaddstr((int)(cy-sdy),(int)(cx+sdx),szChar); + } + + mvaddstr(0,0,"ASCII Clock by Howard Jones (ha.jones@ic.ac.uk),1994"); + + sradius=8; + while(1) + { + sleep(1); + + tim=time(0); + t=localtime(&tim); + + hours=(t->tm_hour + (t->tm_min/60.0)); + if(hours>12.0) hours-=12.0; + + mangle=(t->tm_min)*(2*PI)/60.0; + mdx=2.0*mradius*sin(mangle); + mdy=mradius*cos(mangle); + + hangle=(hours)*(2.0*PI)/12.0; + hdx=2.0*hradius*sin(hangle); + hdy=hradius*cos(hangle); + + sangle=(t->tm_sec%60)*(2.0*PI)/60.0; + sdx=2.0*sradius*sin(sangle); + sdy=sradius*cos(sangle); + + plot(cx+sdx,cy-sdy,'O'); + dline(cx,cy,cx+hdx,cy-hdy,'.'); + dline(cx,cy,cx+mdx,cy-mdy,'#'); + + mvaddstr(23,0,ctime(&tim)); + + refresh(); + plot(cx+sdx,cy-sdy,' '); + dline(cx,cy,cx+hdx,cy-hdy,' '); + dline(cx,cy,cx+mdx,cy-mdy,' '); + + } + + return 0; +} diff --git a/libslang/src/curses/view.c b/libslang/src/curses/view.c new file mode 100644 index 0000000..8286dac --- /dev/null +++ b/libslang/src/curses/view.c @@ -0,0 +1,143 @@ +/* + * view.c -- a silly little viewer program + * + * written by Eric S. Raymond December 1994 + * to test the scrolling code in ncurses. + * + * Takes a filename argument. It's a simple file-viewer with various + * scroll-up and scroll-down commands. + * + * n -- scroll one line forward + * p -- scroll one line back + * + * Either command accepts a numeric prefix interpreted as a repeat count. + * Thus, typing `5n' should scroll forward 5 lines in the file. + * + * The way you can tell this is working OK is that, in the trace file, + * there should be one scroll operation plus a small number of line + * updates, as opposed to a whole-page update. This means the physical + * scroll operation worked, and the refresh() code only had to do a + * partial repaint. + */ +#include +#include +#include +#include +#include + +#define MAXLINES 256 /* most lines we can handle */ + +static void finish(int sig); + +static char *lines[MAXLINES]; + +int main(int argc, char *argv[]) +{ +FILE *fp; +char buf[BUFSIZ]; +int i; +char **lptr, **olptr; + +#ifdef TRACE + trace(TRACE_UPDATE); +#endif + + if (argc != 2) { + fprintf(stderr, "usage: view file\n"); + exit(1); + } else if ((fp = fopen(argv[1], "r")) == (FILE *)NULL) { + perror(argv[1]); + exit(1); + } + + (void) signal(SIGINT, finish); /* arrange interrupts to terminate */ + + (void) initscr(); /* initialize the curses library */ + keypad(stdscr, TRUE); /* enable keyboard mapping */ + (void) nonl(); /* tell curses not to do NL->CR/NL on output */ + (void) cbreak(); /* take input chars one at a time, no wait for \n */ + (void) noecho(); /* don't echo input */ + scrollok(stdscr, TRUE); + + /* slurp the file */ + for (lptr = &lines[0]; fgets(buf, BUFSIZ, fp) != (char *)NULL; lptr++) { + if (lptr - lines >= MAXLINES) { + endwin(); + (void) fprintf(stderr, "%s: %s is too large\n", argv[0], argv[1]); + exit(1); + } + + buf[strlen(buf) - 1] = '\0'; + *lptr = (char *)malloc((size_t)(COLS + 1)); + (void) strncpy(*lptr, buf, (size_t)COLS); + (*lptr)[COLS] = '\0'; + } + (void) fclose(fp); + + lptr = lines; + for (;;) { + int n, c; + bool explicit; + + for (i = 0; i < LINES; i++) { + move(i, 0); + clrtoeol(); + if (lptr[i]) + addstr(lptr[i]); + } + + explicit = FALSE; + n = 0; + for (;;) { + c = getch(); + if (isdigit(c)) + n = 10 * n + (c - '0'); + else + break; + } + if (!explicit && n == 0) + n = 1; + + switch(c) { + case KEY_DOWN: + case 'n': + olptr = lptr; + for (i = 0; i < n; i++) + if (lptr + LINES < lines + MAXLINES && lptr[LINES + 1]) + lptr++; + else + break; + wscrl(stdscr, lptr - olptr); + break; + + case KEY_UP: + case 'p': + olptr = lptr; + for (i = 0; i < n; i++) + if (lptr > lines) + lptr--; + else + break; + wscrl(stdscr, lptr - olptr); + break; + + default: + move (0,0); + clrtoeol (); + printw ("Invalid input: %c", c); + refresh (); + sleep (1); + } + } + + finish(0); /* we're done */ +} + +static void finish(int sig) +{ + endwin(); + exit(sig != 0); +} + +/* view.c ends here */ + diff --git a/libslang/src/curses/worm.c b/libslang/src/curses/worm.c new file mode 100644 index 0000000..2c4a390 --- /dev/null +++ b/libslang/src/curses/worm.c @@ -0,0 +1,361 @@ +/* + + @@@ @@@ @@@@@@@@@@ @@@@@@@@@@@ @@@@@@@@@@@@ + @@@ @@@ @@@@@@@@@@@@ @@@@@@@@@@@@ @@@@@@@@@@@@@ + @@@ @@@ @@@@ @@@@ @@@@ @@@@ @@@ @@@@ + @@@ @@ @@@ @@@ @@@ @@@ @@@ @@@ @@@ + @@@ @@@@ @@@ @@@ @@@ @@@ @@@ @@@ @@@ + @@@@ @@@@ @@@@ @@@ @@@ @@@ @@@ @@@ @@@ + @@@@@@@@@@@@ @@@@ @@@@ @@@ @@@ @@@ @@@ + @@@@ @@@@ @@@@@@@@@@@@ @@@ @@@ @@@ @@@ + @@ @@ @@@@@@@@@@ @@@ @@@ @@@ @@@ + + Eric P. Scott + Caltech High Energy Physics + October, 1980 + + Hacks to turn this into a test frame for cursor movement: + Eric S. Raymond + January, 1995 + + July 1995 (esr): worms is now in living color! :-) + +Options: + -f fill screen with copies of 'WORM' at start. + -l set worm length + -n set number of worms + -t make worms leave droppings + -T set trace interval + -S set single-stepping during trace interval + -N suppress cursor-movement optimization + + This program makes a good torture-test for the ncurses cursor-optimization + code. You can use -T to set the worm move interval over which movement + traces will be dumped. The program stops and waits for one character of + input at the beginning and end of the interval. +*/ + +#include +#include +#include + +#define cursor(col,row) move(row,col) + +short *ref[128]; +static chtype flavor[]={ + 'O' , '*', '#', '$', '%', '0', '@', +}; +#define MAXWORMS (sizeof(flavor)/sizeof(chtype)) +static short xinc[]={ + 1, 1, 1, 0, -1, -1, -1, 0 +}, yinc[]={ + -1, 0, 1, 1, 1, 0, -1, -1 +}; +static struct worm { + int orientation, head; + short *xpos, *ypos; +} worm[40]; + +static char *field; +static int length=16, number=3; +static chtype trail=' '; + +#ifdef TRACE +int generation, trace_start, trace_end, singlestep; +#endif /* TRACE */ +static struct options { + int nopts; + int opts[3]; +} normal[8]={ + { 3, { 7, 0, 1 } }, + { 3, { 0, 1, 2 } }, + { 3, { 1, 2, 3 } }, + { 3, { 2, 3, 4 } }, + { 3, { 3, 4, 5 } }, + { 3, { 4, 5, 6 } }, + { 3, { 5, 6, 7 } }, + { 3, { 6, 7, 0 } } +}, upper[8]={ + { 1, { 1, 0, 0 } }, + { 2, { 1, 2, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 2, { 4, 5, 0 } }, + { 1, { 5, 0, 0 } }, + { 2, { 1, 5, 0 } } +}, left[8]={ + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 2, { 2, 3, 0 } }, + { 1, { 3, 0, 0 } }, + { 2, { 3, 7, 0 } }, + { 1, { 7, 0, 0 } }, + { 2, { 7, 0, 0 } } +}, right[8]={ + { 1, { 7, 0, 0 } }, + { 2, { 3, 7, 0 } }, + { 1, { 3, 0, 0 } }, + { 2, { 3, 4, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 2, { 6, 7, 0 } } +}, lower[8]={ + { 0, { 0, 0, 0 } }, + { 2, { 0, 1, 0 } }, + { 1, { 1, 0, 0 } }, + { 2, { 1, 5, 0 } }, + { 1, { 5, 0, 0 } }, + { 2, { 5, 6, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } } +}, upleft[8]={ + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 1, { 3, 0, 0 } }, + { 2, { 1, 3, 0 } }, + { 1, { 1, 0, 0 } } +}, upright[8]={ + { 2, { 3, 5, 0 } }, + { 1, { 3, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 1, { 5, 0, 0 } } +}, lowleft[8]={ + { 3, { 7, 0, 1 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 1, { 1, 0, 0 } }, + { 2, { 1, 7, 0 } }, + { 1, { 7, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } } +}, lowright[8]={ + { 0, { 0, 0, 0 } }, + { 1, { 7, 0, 0 } }, + { 2, { 5, 7, 0 } }, + { 1, { 5, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } }, + { 0, { 0, 0, 0 } } +}; + +void onsig(int sig); +float ranf(void); + +int +main(int argc, char *argv[]) +{ +int x, y; +int n; +struct worm *w; +struct options *op; +int h; +short *ip; +int last, bottom; + + for (x=1;x1024) { + fprintf(stderr,"%s: Invalid length\n",*argv); + exit(1); + } + break; + case 'n': + if (++x==argc) goto usage; + if ((number=atoi(argv[x]))<1||number>40) { + fprintf(stderr,"%s: Invalid number of worms\n",*argv); + exit(1); + } + break; + case 't': + trail='.'; + break; +#ifdef TRACE + case 'S': + singlestep = TRUE; + break; + case 'T': + trace_start = atoi(argv[++x]); + trace_end = atoi(argv[++x]); + break; + case 'N': + no_optimize = TRUE; /* declared by ncurses */ + break; +#endif /* TRACE */ + default: + usage: + fprintf(stderr, "usage: %s [-field] [-length #] [-number #] [-trail]\n",*argv); + exit(1); + break; + } + } + + signal(SIGINT, onsig); + initscr(); +#ifdef TRACE + noecho(); + cbreak(); +#endif /* TRACE */ + nonl(); + bottom = LINES-1; + last = COLS-1; + +#ifdef A_COLOR + if (has_colors()) + { + start_color(); + + init_pair(COLOR_GREEN, COLOR_GREEN, COLOR_BLACK); + init_pair(COLOR_RED, COLOR_RED, COLOR_BLACK); + init_pair(COLOR_CYAN, COLOR_CYAN, COLOR_BLACK); + init_pair(COLOR_WHITE, COLOR_WHITE, COLOR_BLACK); + init_pair(COLOR_MAGENTA, COLOR_MAGENTA, COLOR_BLACK); + init_pair(COLOR_BLUE, COLOR_BLUE, COLOR_BLACK); + init_pair(COLOR_YELLOW, COLOR_YELLOW, COLOR_BLACK); + + flavor[0] |= COLOR_PAIR(COLOR_GREEN) | A_BOLD; + flavor[1] |= COLOR_PAIR(COLOR_RED) | A_BOLD; + flavor[2] |= COLOR_PAIR(COLOR_CYAN) | A_BOLD; + flavor[3] |= COLOR_PAIR(COLOR_WHITE) | A_BOLD; + flavor[4] |= COLOR_PAIR(COLOR_MAGENTA) | A_BOLD; + flavor[5] |= COLOR_PAIR(COLOR_BLUE) | A_BOLD; + flavor[6] |= COLOR_PAIR(COLOR_YELLOW) | A_BOLD; + } +#endif /* A_COLOR */ + + ip=(short *)malloc(LINES*COLS*sizeof (short)); + + for (n=0;n=0;) *ip++=0; + +#ifdef BADCORNER + /* if addressing the lower right corner doesn't work in your curses */ + ref[bottom][last]=1; +#endif /* BADCORNER */ + + for (n=number, w= &worm[0];--n>=0;w++) { + w->orientation=w->head=0; + if (!(ip=(short *)malloc((length+1)*sizeof (short)))) { + fprintf(stderr,"%s: out of memory\n",*argv); + exit(1); + } + w->xpos=ip; + for (x=length;--x>=0;) *ip++ = -1; + if (!(ip=(short *)malloc((length+1)*sizeof (short)))) { + fprintf(stderr,"%s: out of memory\n",*argv); + exit(1); + } + w->ypos=ip; + for (y=length;--y>=0;) *ip++ = -1; + } + if (field) { + register char *p; + p=field; + for (y=bottom;--y>=0;) { + for (x=COLS;--x>=0;) { + addch((chtype)(*p++)); + if (!*p) p=field; + } + addch('\n'); + } + } + refresh(); + napms(100); + + for (;;) { +#ifdef TRACE + if (trace_start || trace_end) { + if (generation == trace_start) { + trace(TRACE_CALLS); + getch(); + } else if (generation == trace_end) { + trace(0); + getch(); + } + + if (singlestep && generation > trace_start && generation < trace_end) + getch(); + + generation++; + } +#endif /* TRACE */ + + for (n=0,w= &worm[0];nxpos[h=w->head])<0) { + cursor(x=w->xpos[h]=0,y=w->ypos[h]=bottom); + addch(flavor[n % MAXWORMS]); + ref[y][x]++; + } + else y=w->ypos[h]; + if (++h==length) h=0; + if (w->xpos[w->head=h]>=0) { + register int x1, y1; + x1=w->xpos[h]; y1=w->ypos[h]; + if (--ref[y1][x1]==0) { + cursor(x1,y1); addch(trail); + } + } + op= &(x==0 ? (y==0 ? upleft : (y==bottom ? lowleft : left)) : + (x==last ? (y==0 ? upright : (y==bottom ? lowright : right)) : + (y==0 ? upper : (y==bottom ? lower : normal))))[w->orientation]; + switch (op->nopts) { + case 0: + refresh(); + endwin(); + exit(0); + case 1: + w->orientation=op->opts[0]; + break; + default: + w->orientation=op->opts[(int)(ranf()*(float)op->nopts)]; + } + cursor(x+=xinc[w->orientation], y+=yinc[w->orientation]); + + if (y < 0 ) y = 0; + addch(flavor[n % MAXWORMS]); + ref[w->ypos[h]=y][w->xpos[h]=x]++; + } + napms(100); + refresh(); + } +} + +void +onsig(int sig) +{ + standend(); + refresh(); + endwin(); + exit(sig); +} + +float +ranf(void) +{ +float rv; +long r = rand(); + + r &= 077777; + rv =((float)r/32767.); + return rv; +} diff --git a/libslang/src/jdmacros.h b/libslang/src/jdmacros.h new file mode 100644 index 0000000..70d491b --- /dev/null +++ b/libslang/src/jdmacros.h @@ -0,0 +1,53 @@ +#ifndef _JD_MACROS_H_ +#define _JD_MACROS_H_ + +#ifndef SLMEMSET +# ifdef HAVE_MEMSET +# define SLMEMSET memset +# else +# define SLMEMSET SLmemset +# endif +#endif + +#ifndef SLMEMCHR +# ifdef HAVE_MEMCHR +# define SLMEMCHR memchr +# else +# define SLMEMCHR SLmemchr +# endif +#endif + +#ifndef SLMEMCPY +# ifdef HAVE_MEMCPY +# define SLMEMCPY memcpy +# else +# define SLMEMCPY SLmemcpy +# endif +#endif + +/* Note: HAVE_MEMCMP requires an unsigned memory comparison!!! */ +#ifndef SLMEMCMP +# ifdef HAVE_MEMCMP +# define SLMEMCMP memcmp +# else +# define SLMEMCMP SLmemcmp +# endif +#endif + +#ifndef SLFREE +# define SLFREE free +#endif + +#ifndef SLMALLOC +# define SLMALLOC malloc +#endif + +#ifndef SLCALLOC +# define SLCALLOC calloc +#endif + +#ifndef SLREALLOC +# define SLREALLOC realloc +#endif + +#endif /* _JD_MACROS_H_ */ diff --git a/libslang/src/keywhash.c b/libslang/src/keywhash.c new file mode 100644 index 0000000..33166ef --- /dev/null +++ b/libslang/src/keywhash.c @@ -0,0 +1,190 @@ +/* Perfect hash generated by command line: + * ./a.out 1 + */ +#define MIN_HASH_VALUE 2 +#define MAX_HASH_VALUE 118 +#define MIN_KEYWORD_LEN 2 +#define MAX_KEYWORD_LEN 11 + +static SLCONST unsigned char Keyword_Hash_Table [256] = +{ + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 1, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 9, 7, 1, 8, 2, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 0, 0, 119, 0, 119, 119, 119, 7, 119, 0, 0, 119, 119, 0, + 119, 119, 0, 0, 0, 0, 119, 119, 0, 119, 119, 119, 119, 119, 119, 2, + 119, 41, 1, 1, 9, 0, 55, 8, 0, 0, 119, 0, 27, 0, 0, 0, + 7, 2, 0, 21, 0, 0, 0, 3, 2, 0, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119 +}; + +static unsigned char keyword_hash (char *s, unsigned int len) +{ + unsigned int sum; + + sum = len; + while (len) + { + len--; + sum += (unsigned int) Keyword_Hash_Table [(unsigned char)s[len]]; + } + return sum; +} + +typedef SLCONST struct +{ + char *name; + unsigned int type; +} +Keyword_Table_Type; + +static Keyword_Table_Type Keyword_Table [/* 117 */] = +{ + {"or", OR_TOKEN}, + {"not", NOT_TOKEN}, + {NULL,0}, + {"xor", BXOR_TOKEN}, + {"return", RETURN_TOKEN}, + {"exch", EXCH_TOKEN}, + {NULL,0}, + {"continue", CONT_TOKEN}, + {NULL,0}, + {"do", DO_TOKEN}, + {"mod", MOD_TOKEN}, + {"ERROR_BLOCK", ERRBLK_TOKEN}, + {"USER_BLOCK2", USRBLK2_TOKEN}, + {"USER_BLOCK4", USRBLK4_TOKEN}, + {"__tmp", TMP_TOKEN}, + {"pop", POP_TOKEN}, + {NULL,0}, + {"EXIT_BLOCK", EXITBLK_TOKEN}, + {"USER_BLOCK1", USRBLK1_TOKEN}, + {"USER_BLOCK3", USRBLK3_TOKEN}, + {"USER_BLOCK0", USRBLK0_TOKEN}, + {NULL,0}, + {"shr", SHR_TOKEN}, + {"chs", CHS_TOKEN}, + {"sqr", SQR_TOKEN}, + {NULL,0}, + {"struct", STRUCT_TOKEN}, + {NULL,0}, + {NULL,0}, + {"switch", SWITCH_TOKEN}, + {"mul2", MUL2_TOKEN}, + {"sign", SIGN_TOKEN}, + {"using", USING_TOKEN}, + {"while", WHILE_TOKEN}, + {NULL,0}, + {NULL,0}, + {"loop", LOOP_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"public", PUBLIC_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"break", BREAK_TOKEN}, + {NULL,0}, + {"do_while", DOWHILE_TOKEN}, + {NULL,0}, + {"shl", SHL_TOKEN}, + {"else", ELSE_TOKEN}, + {"and", AND_TOKEN}, + {"orelse", ORELSE_TOKEN}, + {"private", PRIVATE_TOKEN}, + {NULL,0}, + {"if", IF_TOKEN}, + {"for", FOR_TOKEN}, + {"!if", IFNOT_TOKEN}, + {NULL,0}, + {"_for", _FOR_TOKEN}, + {"forever", FOREVER_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"abs", ABS_TOKEN}, + {"case", CASE_TOKEN}, + {NULL,0}, + {"static", STATIC_TOKEN}, + {"define", DEFINE_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"typedef", TYPEDEF_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"foreach", FOREACH_TOKEN}, + {"andelse", ANDELSE_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"variable", VARIABLE_TOKEN}, +}; + +static Keyword_Table_Type *is_keyword (char *str, unsigned int len) +{ + unsigned int hash; + char *name; + Keyword_Table_Type *kw; + + if ((len < MIN_KEYWORD_LEN) + || (len > MAX_KEYWORD_LEN)) + return NULL; + + hash = keyword_hash (str, len); + if ((hash > MAX_HASH_VALUE) || (hash < MIN_HASH_VALUE)) + return NULL; + + kw = &Keyword_Table[hash - MIN_HASH_VALUE]; + if ((NULL != (name = kw->name)) + && (*str == *name) + && (0 == strcmp (str, name))) + return kw; + return NULL; +} diff --git a/libslang/src/mkfiles/README b/libslang/src/mkfiles/README new file mode 100644 index 0000000..59217e2 --- /dev/null +++ b/libslang/src/mkfiles/README @@ -0,0 +1,28 @@ +-*- text -*- +Due to various incompatibilities between various make programs for PC +systems as well as differing notions of what the path separator should +be, I have decided that the best and most maintainable approach is to +create a master makefile that that consists of system/compiler/make +sections from which the approriate makefile is constructed. The +easiest way to do this is to run the master makefile through a +preprocessor. To this end, I have created a master makefile for +DOS/OS2 systems called makefile.all. This makefile is processed by +the DOS executable mkmake.exe to produce various makefiles. For +example, + + mkmake BCC < makefile.all > makefile + +produces a makefile suitable for BCC, whereas + + mkmake OS2 EMX < makefile.all > makefile + +produces a makefile for OS2 assuming that EMX is the compiler. + +Use + + mkmake < makefile.all | more + +for more information. (Better yet, look at makefile.all; it is best +viewed with a folding editor). + +Note that the resulting makefile should be copied to the src directory. diff --git a/libslang/src/mkfiles/makefile.all b/libslang/src/mkfiles/makefile.all new file mode 100644 index 0000000..cd271a9 --- /dev/null +++ b/libslang/src/mkfiles/makefile.all @@ -0,0 +1,620 @@ +!ifndef MSDOS WIN16 WIN32 OS2 +# -*- mode: sh; mode: fold -*- +# This file has been folded. + +#{{{ MACRO descriptions + +This is a master makefile that from which DOS/Windows/OS2 makefiles +may be derived. A makefile for a particular system may be derived by +passing this through the standalone DOS executable 'mkmake' which +should be present in this directory. For example, to produce a makefile +suitable for OS2 using the EMX compiler use: + + mkmake OS2 EMX < makefile.all > Makefile + +Currently supported platforms include: + + MSDOS WIN16 WIN32 OS2 + +Currently supported compilers include: + + MSDOS - BCC, DJGPP + WIN16 - BCC + WIN32 - BCC, VC, CYGWIN32, MINGW32, WCC + OS2 - EMX, WCC, ICC + +More will be added in the future. + +For example to produce makefile for compiling for Win32 using +Visual C++ use: + + mkmake WIN32 VC < makefile.all > Makefile + +Similarly, + + mkmake WIN32 MINGW32 < makefile.all > Makefile + +will produce a makefile for the MINGW32 compiler. + + +Each compiler-dependent section of this master makefile must define +the following macros: + + CC : The C compiler + CFLAGS : Compiler flags + P : Path separator used by make/compiler + O : Object file extension + SRCDIR : SRC location (.) + OBJDIR : Directory where objects are placed + COMPILE_CMD : Command used to produce object from .c file + LIBDEPS : Other dependencies library depends upon + TARGET : Primary target name + COPY : copy command + +Other macros include: + + RSPFILE : Name of response file + RSP_PREFIX : Prefix for response file line (See its usage) + RSP_POSTFIX : Postfix for response file line (See its usage) + RM : What to use to delete a file + TOUCH : Touch program + +Special notes: + + The P macro could be problematic when its value is a backslash (\). Some + make programs may require it to be doubled, i.e., \\. Whatever its value is, + it should expand to something that does not include whitespace. Usually + this requires that it be followed by a '#' character; however, this may + result in the '#' character being quoted, or, escaped if the value of P is + a backslash. + +#}}} +!else #rest of file +# Note: +# This makefile was automatically generated from the master makefile.all. +# If you have problems with this file, edit the mkfiles/makefile.all. +# Also check slconfig.h to make sure that what is defined there is +# appropriate to your system. +# +! ifdef MSDOS +! ifdef DJGPP #{{{ +CC = gcc +CFLAGS = -O2 -fno-strength-reduce -Wall -W +P = /# path sep +O = o # Object extension +SRCDIR = .# Location of sources +OBJDIR = djgobjs# Location of objects +TARGET = $(OBJDIR)/libslang.a +RSPFILE = $(OBJDIR)/link.rsp +RSP_PREFIX = +RSP_POSTFIX = +COMPILE_CMD = $(CC) -c $(CFLAGS) -o # +LIBDEPS = $(RSPFILE) +RM = rm +TOUCH = touch +COPY = cp +#}}} +! elifdef BCC #{{{ +CC = bcc +CFLAGS = -G- -H -N -O1 -w -ml -Dmsdos +P = \\ +O = obj +SRCDIR = . +OBJDIR = bccobjs +TARGET = $(OBJDIR)\slang.lib +RSPFILE = $(OBJDIR)\link.rsp +RSP_PREFIX = +- +RSP_POSTFIX = & +COMPILE_CMD = $(CC) -c $(CFLAGS) -o# <-- no tailing space +LIBDEPS = $(RSPFILE) +TOUCH = touch +COPY = copy +#}}} BCC +! endif #ifdef BCC elifdef DJGPP +! endif #MSDOS +! ifdef WIN16 #{{{ +CC = bcc +CFLAGS = -G- -H -N -w -ml -Dmsdos -DMSWINDOWS -W +#CFLAGS = -N -v -H -w -ml -Dmsdos -DMSWINDOWS -WS +OBJDIR = mswobjs# Location of objects +O = obj # Object extension +P = \\ +SRCDIR = .# Location of sources +TARGET = $(OBJDIR)$(P)wslang.lib +RSPFILE = $(OBJDIR)$(P)mswin.rsp +RSP_PREFIX = +-# +RSP_POSTFIX = &# +COMPILE_CMD = $(CC) -c $(CFLAGS) -o# +LIBDEPS = $(RSPFILE) +TOUCH = touch +COPY = copy +! endif #}}} +! ifdef OS2 +! ifdef EMX #{{{ +CC = gcc -Zmtd -DEMX_VIDEO +CFLAGS = -DOS2 -D__os2__ +P = / +O = o # Object extension +SRCDIR = .# Location of sources +OBJDIR = emxobjs# Location of objects +TARGET = $(OBJDIR)/slang.a +COMPILE_CMD = $(CC) -c $(CFLAGS) -o # +LIBDEPS = +TOUCH = touch +COPY = cp +#}}} +! elifdef WCC #{{{ +CC = wcc386 +CFLAGS = -DOS2 -D__os2__ -bm -bt=os2 # +P = \# +O = obj # Object extension +SRCDIR = .# Location of sources +OBJDIR = wccobjs# Location of objects +TARGET = $(OBJDIR)\slang.lib +COMPILE_CMD = $(CC) $(CFLAGS) -fo=# +RSPFILE = +RSP_PREFIX = +- +RSP_POSTFIX = +LIBDEPS = $(RSPFILE) +TOUCH = wtouch +COPY = copy +RM = del +#}}} +! elifdef ICC #{{{ +CC = icc +CFLAGS = -Q+ -W3 -DOS2 -D__os2__ -Gm+ -Wcnd- +P = \# +O = obj +SRCDIR = . +OBJDIR = iccobjs +TARGET = $(OBJDIR)\slang.lib +COMPILE_CMD = $(CC) -c $(CFLAGS) -Fo# <-- no trailing space +LIBDEPS = $(RSPFILE) +RSPFILE = $(OBJDIR)\link.rsp +RSP_PREFIX = +TMP1=A +# Hack to get ^& +RSP_POSTFIX = $(TMP1:A=^^)& +COPY = copy +RM=del +TOUCH=echo +#}}} +! endif # ifdef EMX elifdef WCC +! endif #OS2 +! ifdef WIN32 +! ifdef VC #{{{ +# Makefile for slang as Win32 GUI using nmake under Visual C. +CC = cl +CFLAGS = +P = \\ +O = obj # Object extension +SRCDIR = .# Location of sources +OBJDIR = mw32objs# Location of objects +TARGET = $(OBJDIR)\wslang32.lib +RSPFILE = $(OBJDIR)\link.rsp +RSP_PREFIX = +RSP_POSTFIX = +COMPILE_CMD = $(CC) /c @$(OBJDIR)\comp.rsp /Fo # /Fo specifies object file name +LIBDEPS = $(RSPFILE) $(OBJDIR)\comp.rsp +# This needs changing for Windows NT on non-Intel processors +CPU = _X86_ +TOUCH = touch +COPY = copy +#}}} +! elifdef BCC #{{{ +CC = bcc32 +CFLAGS = -N -w -w-sig -w-stu -v -DWIN32 +# Location of sources +SRCDIR = . +# Location of objects +OBJDIR = bw32objs +# Object extension +O = obj +P = \\ +TARGET = $(OBJDIR)\wslang.lib +RSPFILE = $(OBJDIR)\link.rsp +RSP_PREFIX = +- +! if$OS Windows_NT +RSP_POSTFIX = ^^& +! else +RSP_POSTFIX = & +! endif +COMPILE_CMD = $(CC) -c $(CFLAGS) -o +LIBDEPS = $(RSPFILE) +TOUCH = touch +COPY = copy + +#}}} +! elifdef CYGWIN32 #{{{ +# This Makefile is for the CYGWIN32 environment +CC = gcc +CFLAGS = -DWIN32 -W -Wall -O2 -fno-strength-reduce +P = /# +O = o # Object extension +SRCDIR = .# Location of sources +OBJDIR = gw32objs# Location of objects +TARGET = $(OBJDIR)/libslang.a +COMPILE_CMD = $(CC) -c $(CFLAGS) -o # +LIBDEPS = +RM = rm +TOUCH = touch +COPY = cp + +#}}} +! elifdef MINGW32 #{{{ +# This Makefile is for the MINGW32 environment +CC = gcc +CFLAGS += -DWIN32 -W -Wall -O2 -fno-strength-reduce +P = /# +O = o # Object extension +SRCDIR = .# Location of sources +OBJDIR = gw32objs# Location of objects +TARGET = $(OBJDIR)/libslang.a +COMPILE_CMD = $(CC) -c $(CFLAGS) -o # +LIBDEPS = +RM = rm +TOUCH = touch +#COPY = cp +COPY = copy +#}}} +! elifdef WCC #{{{ +# Watcom makefile for slang + +CC = wcl386 +DEFINES = /DWIN32 /D__WIN32__ +CFLAGS = /bt=nt /ort /I. $(DEFINES) +P = \# +O = obj # Object extension + +.c.obj: .AUTODEPEND + $(CC) $(CFLAGS) /c $< /fo=$@ + +SRCDIR = .# Location of sources +OBJDIR = w32objs# Location of objects +TARGET = $(OBJDIR)\wslang32.lib +RSPFILE = $(OBJDIR)\link.rsp +RSP_PREFIX = -+ +RSP_POSTFIX = +COMPILE_CMD = $(CC) $(CFLAGS) /c /fo= +LIBDEPS = $(RSPFILE) +# This needs changing for Windows NT on non-Intel processors +CPU = _X86_ +TOUCH = wtouch +RM = del +COPY = copy +#}}} +! endif #ifdef VC elifdef BCC ... elifdef MINGW32 +! endif #WIN32 + + +# End of compiler specific section + +CONFIG_H = config.h +#{{{ OBJS = + +OBJS = $(OBJDIR)$(P)slang.$(O) \ + $(OBJDIR)$(P)slarray.$(O) \ + $(OBJDIR)$(P)slclass.$(O) \ + $(OBJDIR)$(P)slcmd.$(O) \ + $(OBJDIR)$(P)slerr.$(O) \ + $(OBJDIR)$(P)slgetkey.$(O) \ + $(OBJDIR)$(P)slkeymap.$(O) \ + $(OBJDIR)$(P)slmalloc.$(O) \ + $(OBJDIR)$(P)slmath.$(O) \ + $(OBJDIR)$(P)slarith.$(O) \ + $(OBJDIR)$(P)slassoc.$(O) \ + $(OBJDIR)$(P)slmemchr.$(O) \ + $(OBJDIR)$(P)slmemcmp.$(O) \ + $(OBJDIR)$(P)slmemcpy.$(O) \ + $(OBJDIR)$(P)slmemset.$(O) \ + $(OBJDIR)$(P)slmisc.$(O) \ + $(OBJDIR)$(P)slparse.$(O) \ + $(OBJDIR)$(P)slprepr.$(O) \ + $(OBJDIR)$(P)slregexp.$(O) \ + $(OBJDIR)$(P)slrline.$(O) \ + $(OBJDIR)$(P)slsearch.$(O) \ + $(OBJDIR)$(P)slsmg.$(O) \ + $(OBJDIR)$(P)slstd.$(O) \ + $(OBJDIR)$(P)sltoken.$(O) \ + $(OBJDIR)$(P)sltypes.$(O) \ + $(OBJDIR)$(P)slscroll.$(O) \ + $(OBJDIR)$(P)slsignal.$(O) \ + $(OBJDIR)$(P)slkeypad.$(O) \ + $(OBJDIR)$(P)slerrno.$(O) \ + $(OBJDIR)$(P)slstring.$(O) \ + $(OBJDIR)$(P)slstruct.$(O) \ + $(OBJDIR)$(P)slcmplex.$(O) \ + $(OBJDIR)$(P)slarrfun.$(O) \ + $(OBJDIR)$(P)slimport.$(O) \ + $(OBJDIR)$(P)slpath.$(O) \ + $(OBJDIR)$(P)slcompat.$(O) \ + $(OBJDIR)$(P)slposdir.$(O) \ + $(OBJDIR)$(P)slstdio.$(O) \ + $(OBJDIR)$(P)slproc.$(O) \ + $(OBJDIR)$(P)sltime.$(O) \ + $(OBJDIR)$(P)slstrops.$(O) \ + $(OBJDIR)$(P)slbstr.$(O) \ + $(OBJDIR)$(P)slpack.$(O) \ + $(OBJDIR)$(P)slintall.$(O) \ + $(OBJDIR)$(P)slistruc.$(O) \ + $(OBJDIR)$(P)slposio.$(O) \ + $(OBJDIR)$(P)slnspace.$(O) \ + $(OBJDIR)$(P)slarrmis.$(O) \ + $(OBJDIR)$(P)slospath.$(O) \ + $(OBJDIR)$(P)slscanf.$(O) \ +! ifndef WIN16 + $(OBJDIR)$(P)slvideo.$(O) \ +! endif +! ifdef MSDOS + $(OBJDIR)$(P)sldostty.$(O) \ +! endif +! ifdef WIN32 + $(OBJDIR)$(P)slw32tty.$(O) \ +! endif +! ifdef OS2 + $(OBJDIR)$(P)slos2tty.$(O) \ +! endif + $(OBJDIR)$(P)slxstrng.$(O) +#--------------------------------------------------------------------------- + +#}}} + +$(TARGET): $(OBJDIR) $(CONFIG_H) $(LIBDEPS) $(OBJS) +! ifdef DJGPP CYGWIN32 MINGW32 ICC + -$(RM) $(TARGET) +! endif +! ifdef DJGPP + ar -cr $(TARGET) @$(RSPFILE) + ranlib $(TARGET) +! elifdef BCC + tlib $(TARGET) /P32 /C @$(RSPFILE) +! elifdef EMX CYGWIN32 MINGW32 + ar crv $(TARGET) $(OBJS) +! elifdef VC + link -lib -out:$(TARGET) @$(RSPFILE) +! elifdef WCC + wlib $(TARGET) @$(RSPFILE) +# wlib $(TARGET) -+ $(OBJS) +! elifdef ICC + ilib $(TARGET) @$(RSPFILE); +# ilib $(TARGET) $(OBJS); +! endif + +$(OBJDIR) : + -mkdir $(OBJDIR) +$(CONFIG_H): slconfig.h + $(COPY) slconfig.h config.h + -$(TOUCH) config.h + +!ifndef EMX CYGWIN32 MINGW32 #ICC WCC +#{{{ Create Response File + +$(RSPFILE) : + @echo Creating response file $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slxstrng.$(O) $(RSP_POSTFIX) > $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)sltypes.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)sltoken.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slstd.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slsmg.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slsearch.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slrline.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slregexp.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slprepr.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slparse.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slmisc.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slmemset.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slmemcpy.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slmemcmp.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slmemchr.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slmath.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slarith.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slassoc.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slmalloc.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slkeymap.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slgetkey.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slerr.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slcmd.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slclass.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slarray.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slscroll.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slsignal.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slkeypad.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slerrno.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slstring.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slstruct.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slistruc.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slcmplex.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slarrfun.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slimport.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slpath.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slcompat.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slposdir.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slstdio.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slproc.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)sltime.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slstrops.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slbstr.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slpack.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slintall.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slposio.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slnspace.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slarrmis.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slospath.$(O) $(RSP_POSTFIX) >> $(RSPFILE) + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slscanf.$(O) $(RSP_POSTFIX) >> $(RSPFILE) +! ifndef WIN16 + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slvideo.$(O) $(RSP_POSTFIX) >> $(RSPFILE) +! endif +! ifdef MSDOS + @echo $(RSP_PREFIX)$(OBJDIR)$(P)sldostty.$(O) $(RSP_POSTFIX) >> $(RSPFILE) +! endif +! ifdef WIN32 + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slw32tty.$(O) $(RSP_POSTFIX) >> $(RSPFILE) +! endif +! ifdef OS2 + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slos2tty.$(O) $(RSP_POSTFIX) >> $(RSPFILE) +! endif + @echo $(RSP_PREFIX)$(OBJDIR)$(P)slang.$(O) >> $(RSPFILE) + +#}}} +!endif # NOT EMX, WCC, CYGWIN32, MINGW32 + +!ifdef VC +$(OBJDIR)\comp.rsp: + echo /nologo /W3 /YX /O2 /D "NDEBUG" /D $(CPU) > $(OBJDIR)\comp.rsp + echo /D "WIN32" /I "." /ML >> $(OBJDIR)\comp.rsp +!endif + +#--------------------------------------------------------------------------- + +# explicit rules follow below +$(OBJDIR)$(P)slxstrng.$(O) : $(SRCDIR)$(P)slxstrng.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slxstrng.$(O) $(SRCDIR)$(P)slxstrng.c + +$(OBJDIR)$(P)sltypes.$(O) : $(SRCDIR)$(P)sltypes.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)sltypes.$(O) $(SRCDIR)$(P)sltypes.c + +$(OBJDIR)$(P)sltoken.$(O) : $(SRCDIR)$(P)sltoken.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)sltoken.$(O) $(SRCDIR)$(P)sltoken.c + +$(OBJDIR)$(P)slstd.$(O) : $(SRCDIR)$(P)slstd.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slstd.$(O) $(SRCDIR)$(P)slstd.c + +$(OBJDIR)$(P)slsmg.$(O) : $(SRCDIR)$(P)slsmg.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slsmg.$(O) $(SRCDIR)$(P)slsmg.c + +$(OBJDIR)$(P)slsearch.$(O) : $(SRCDIR)$(P)slsearch.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slsearch.$(O) $(SRCDIR)$(P)slsearch.c + +$(OBJDIR)$(P)slrline.$(O) : $(SRCDIR)$(P)slrline.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slrline.$(O) $(SRCDIR)$(P)slrline.c + +$(OBJDIR)$(P)slregexp.$(O) : $(SRCDIR)$(P)slregexp.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slregexp.$(O) $(SRCDIR)$(P)slregexp.c + +$(OBJDIR)$(P)slprepr.$(O) : $(SRCDIR)$(P)slprepr.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slprepr.$(O) $(SRCDIR)$(P)slprepr.c + +$(OBJDIR)$(P)slparse.$(O) : $(SRCDIR)$(P)slparse.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slparse.$(O) $(SRCDIR)$(P)slparse.c + +$(OBJDIR)$(P)slmisc.$(O) : $(SRCDIR)$(P)slmisc.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slmisc.$(O) $(SRCDIR)$(P)slmisc.c + +$(OBJDIR)$(P)slmemset.$(O) : $(SRCDIR)$(P)slmemset.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slmemset.$(O) $(SRCDIR)$(P)slmemset.c + +$(OBJDIR)$(P)slmemcpy.$(O) : $(SRCDIR)$(P)slmemcpy.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slmemcpy.$(O) $(SRCDIR)$(P)slmemcpy.c + +$(OBJDIR)$(P)slmemcmp.$(O) : $(SRCDIR)$(P)slmemcmp.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slmemcmp.$(O) $(SRCDIR)$(P)slmemcmp.c + +$(OBJDIR)$(P)slmemchr.$(O) : $(SRCDIR)$(P)slmemchr.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slmemchr.$(O) $(SRCDIR)$(P)slmemchr.c + +$(OBJDIR)$(P)slmath.$(O) : $(SRCDIR)$(P)slmath.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slmath.$(O) $(SRCDIR)$(P)slmath.c + +$(OBJDIR)$(P)slarith.$(O) : $(SRCDIR)$(P)slarith.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slarith.$(O) $(SRCDIR)$(P)slarith.c + +$(OBJDIR)$(P)slassoc.$(O) : $(SRCDIR)$(P)slassoc.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slassoc.$(O) $(SRCDIR)$(P)slassoc.c + +$(OBJDIR)$(P)slmalloc.$(O) : $(SRCDIR)$(P)slmalloc.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slmalloc.$(O) $(SRCDIR)$(P)slmalloc.c + +$(OBJDIR)$(P)slkeymap.$(O) : $(SRCDIR)$(P)slkeymap.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slkeymap.$(O) $(SRCDIR)$(P)slkeymap.c + +$(OBJDIR)$(P)slgetkey.$(O) : $(SRCDIR)$(P)slgetkey.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slgetkey.$(O) $(SRCDIR)$(P)slgetkey.c + +$(OBJDIR)$(P)slerr.$(O) : $(SRCDIR)$(P)slerr.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slerr.$(O) $(SRCDIR)$(P)slerr.c + +$(OBJDIR)$(P)slcmd.$(O) : $(SRCDIR)$(P)slcmd.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slcmd.$(O) $(SRCDIR)$(P)slcmd.c + +$(OBJDIR)$(P)slclass.$(O) : $(SRCDIR)$(P)slclass.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slclass.$(O) $(SRCDIR)$(P)slclass.c + +$(OBJDIR)$(P)slarray.$(O) : $(SRCDIR)$(P)slarray.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slarray.$(O) $(SRCDIR)$(P)slarray.c + +$(OBJDIR)$(P)slscroll.$(O) : $(SRCDIR)$(P)slscroll.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slscroll.$(O) $(SRCDIR)$(P)slscroll.c + +$(OBJDIR)$(P)slsignal.$(O) : $(SRCDIR)$(P)slsignal.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slsignal.$(O) $(SRCDIR)$(P)slsignal.c + +$(OBJDIR)$(P)slkeypad.$(O) : $(SRCDIR)$(P)slkeypad.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slkeypad.$(O) $(SRCDIR)$(P)slkeypad.c + +$(OBJDIR)$(P)slerrno.$(O) : $(SRCDIR)$(P)slerrno.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slerrno.$(O) $(SRCDIR)$(P)slerrno.c + +$(OBJDIR)$(P)slang.$(O) : $(SRCDIR)$(P)slang.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slang.$(O) $(SRCDIR)$(P)slang.c + +$(OBJDIR)$(P)slstring.$(O) : $(SRCDIR)$(P)slstring.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slstring.$(O) $(SRCDIR)$(P)slstring.c +$(OBJDIR)$(P)slstruct.$(O) : $(SRCDIR)$(P)slstruct.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slstruct.$(O) $(SRCDIR)$(P)slstruct.c +$(OBJDIR)$(P)slistruc.$(O) : $(SRCDIR)$(P)slistruc.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slistruc.$(O) $(SRCDIR)$(P)slistruc.c +$(OBJDIR)$(P)slcmplex.$(O) : $(SRCDIR)$(P)slcmplex.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slcmplex.$(O) $(SRCDIR)$(P)slcmplex.c +$(OBJDIR)$(P)slarrfun.$(O) : $(SRCDIR)$(P)slarrfun.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slarrfun.$(O) $(SRCDIR)$(P)slarrfun.c +$(OBJDIR)$(P)slimport.$(O) : $(SRCDIR)$(P)slimport.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slimport.$(O) $(SRCDIR)$(P)slimport.c +$(OBJDIR)$(P)slpath.$(O) : $(SRCDIR)$(P)slpath.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slpath.$(O) $(SRCDIR)$(P)slpath.c +$(OBJDIR)$(P)slcompat.$(O) : $(SRCDIR)$(P)slcompat.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slcompat.$(O) $(SRCDIR)$(P)slcompat.c +$(OBJDIR)$(P)slposdir.$(O) : $(SRCDIR)$(P)slposdir.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slposdir.$(O) $(SRCDIR)$(P)slposdir.c +$(OBJDIR)$(P)slstdio.$(O) : $(SRCDIR)$(P)slstdio.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slstdio.$(O) $(SRCDIR)$(P)slstdio.c +$(OBJDIR)$(P)slproc.$(O) : $(SRCDIR)$(P)slproc.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slproc.$(O) $(SRCDIR)$(P)slproc.c +$(OBJDIR)$(P)sltime.$(O) : $(SRCDIR)$(P)sltime.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)sltime.$(O) $(SRCDIR)$(P)sltime.c +$(OBJDIR)$(P)slstrops.$(O) : $(SRCDIR)$(P)slstrops.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slstrops.$(O) $(SRCDIR)$(P)slstrops.c +$(OBJDIR)$(P)slbstr.$(O) : $(SRCDIR)$(P)slbstr.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slbstr.$(O) $(SRCDIR)$(P)slbstr.c +$(OBJDIR)$(P)slpack.$(O) : $(SRCDIR)$(P)slpack.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slpack.$(O) $(SRCDIR)$(P)slpack.c +$(OBJDIR)$(P)slintall.$(O) : $(SRCDIR)$(P)slintall.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slintall.$(O) $(SRCDIR)$(P)slintall.c +$(OBJDIR)$(P)slposio.$(O) : $(SRCDIR)$(P)slposio.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slposio.$(O) $(SRCDIR)$(P)slposio.c +$(OBJDIR)$(P)slnspace.$(O) : $(SRCDIR)$(P)slnspace.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slnspace.$(O) $(SRCDIR)$(P)slnspace.c +$(OBJDIR)$(P)slarrmis.$(O) : $(SRCDIR)$(P)slarrmis.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slarrmis.$(O) $(SRCDIR)$(P)slarrmis.c +$(OBJDIR)$(P)slospath.$(O) : $(SRCDIR)$(P)slospath.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slospath.$(O) $(SRCDIR)$(P)slospath.c +$(OBJDIR)$(P)slscanf.$(O) : $(SRCDIR)$(P)slscanf.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slscanf.$(O) $(SRCDIR)$(P)slscanf.c +# +!ifndef WIN16 +$(OBJDIR)$(P)slvideo.$(O) : $(SRCDIR)$(P)slvideo.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slvideo.$(O) $(SRCDIR)$(P)slvideo.c +!endif +!ifdef MSDOS +$(OBJDIR)$(P)sldostty.$(O) : $(SRCDIR)$(P)sldostty.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)sldostty.$(O) $(SRCDIR)$(P)sldostty.c +!endif +!ifdef OS2 +$(OBJDIR)$(P)slos2tty.$(O) : $(SRCDIR)$(P)slos2tty.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slos2tty.$(O) $(SRCDIR)$(P)slos2tty.c +!endif +!ifdef WIN32 +$(OBJDIR)$(P)slw32tty.$(O) : $(SRCDIR)$(P)slw32tty.c $(CONFIG_H) + $(COMPILE_CMD)$(OBJDIR)$(P)slw32tty.$(O) $(SRCDIR)$(P)slw32tty.c +!endif + +!endif #NOT HELP diff --git a/libslang/src/mkfiles/mkmake.c b/libslang/src/mkfiles/mkmake.c new file mode 100644 index 0000000..30abfb6 --- /dev/null +++ b/libslang/src/mkfiles/mkmake.c @@ -0,0 +1,41 @@ +#include +#include +#include + +static void usage (void) +{ + fprintf (stderr, "Usage: mkmake [DEF1 [DEF2 ...]]\n"); + exit (1); +} + + +int main (int argc, char **argv) +{ + char buf[1024]; + int i; + SLPreprocess_Type pt; + + if (isatty (0)) + usage (); + + SLprep_open_prep (&pt); + + pt.preprocess_char = '!'; + pt.comment_char = '#'; + pt.flags = SLPREP_BLANK_LINES_OK | SLPREP_COMMENT_LINES_OK; + + for (i = 1; i < argc; i++) + SLdefine_for_ifdef (argv[i]); + + while (NULL != fgets (buf, sizeof (buf) - 1, stdin)) + { + if (SLprep_line_ok (buf, &pt)) + { + fputs (buf, stdout); + } + } + + SLprep_close_prep (&pt); + return 0; +} + diff --git a/libslang/src/mkfiles/mkmake.exe b/libslang/src/mkfiles/mkmake.exe new file mode 100644 index 0000000..b8cc375 Binary files /dev/null and b/libslang/src/mkfiles/mkmake.exe differ diff --git a/libslang/src/modules.unx b/libslang/src/modules.unx new file mode 100644 index 0000000..0faf729 --- /dev/null +++ b/libslang/src/modules.unx @@ -0,0 +1,55 @@ +sltermin +sldisply +slutty +slang +slarray +slclass +slcmd +slerr +slgetkey +slkeymap +slmalloc +slmath +slmemchr +slmemcmp +slmemcpy +slmemset +slmisc +slparse +slprepr +slregexp +slrline +slsearch +slsmg +slstd +sltoken +sltypes +slxstrng +slcurses +slscroll +slsignal +slkeypad +slerrno +slstring +slstruct +slcmplex +slarrfun +slimport +slpath +slarith +slassoc +slcompat +slposdir +slstdio +slproc +sltime +slstrops +slbstr +slpack +slintall +slistruc +slposio +slnspace +slarrmis +slospath +slscanf diff --git a/libslang/src/pcconf.c b/libslang/src/pcconf.c new file mode 100644 index 0000000..2aa5247 --- /dev/null +++ b/libslang/src/pcconf.c @@ -0,0 +1,92 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +static void print (char *symbol, int is_defined) +{ + if (is_defined) + fprintf (stdout, "%s is defined\n", symbol); + else + fprintf (stdout, "%s is NOT defined\n", symbol); +} + +int main (int argc, char **argv) +{ + print ("__MSDOS__", +#ifdef __MSDOS__ + 1 +#else + 0 +#endif + ); + + print ("IBMPC_SYSTEM", +#ifdef IBMPC_SYSTEM + 1 +#else + 0 +#endif + ); + + print ("REAL_UNIX_SYSTEM", +#ifdef REAL_UNIX_SYSTEM + 1 +#else + 0 +#endif + ); + + print ("__os2__", +#ifdef __os2__ + 1 +#else + 0 +#endif + ); + + print ("__WIN32__", +#ifdef __WIN32__ + 1 +#else + 0 +#endif + ); + + print ("__unix__", +#ifdef __unix__ + 1 +#else + 0 +#endif + ); + + print ("__GO32__", +#ifdef __GO32__ + 1 +#else + 0 +#endif + ); + + print ("__DJGPP__", +#ifdef __DJGPP__ + 1 +#else + 0 +#endif + ); + + print ("__MSDOS_16BIT__", +#ifdef __MSDOS_16BIT__ + 1 +#else + 0 +#endif + ); + + return 0; +} diff --git a/libslang/src/sl-feat.h b/libslang/src/sl-feat.h new file mode 100644 index 0000000..1372cbb --- /dev/null +++ b/libslang/src/sl-feat.h @@ -0,0 +1,61 @@ +/* Setting this to 1 enables automatic support for associative arrays. + * If this is set to 0, an application must explicitly enable associative + * array support via SLang_init_slassoc. + */ +#define SLANG_HAS_ASSOC_ARRAYS 1 + +#define SLANG_HAS_COMPLEX 1 +#define SLANG_HAS_FLOAT 1 + +/* This is the old space-speed trade off. To reduce memory usage and code + * size, set this to zero. + */ +/*#define _SLANG_OPTIMIZE_FOR_SPEED 0 */ +#define _SLANG_OPTIMIZE_FOR_SPEED 2 + +#define _SLANG_USE_INLINE_CODE 1 + +/* This is experimental. It adds extra information for tracking down + * errors. + */ +#define _SLANG_HAS_DEBUG_CODE 1 + +/* Allow optimizations based upon the __tmp operator. */ +#define _SLANG_USE_TMP_OPTIMIZATION 1 + +/* Setting this to one will map 8 bit vtxxx terminals to 7 bit. Terminals + * such as the vt320 can be set up to output the two-character escape sequence + * encoded as 'ESC [' as single character. Setting this variable to 1 will + * insert code to map such characters to the 7 bit equivalent. + * This affects just input characters in the range 128-160 on non PC + * systems. + */ +#if defined(VMS) || defined(AMIGA) +# define _SLANG_MAP_VTXXX_8BIT 1 +#else +# define _SLANG_MAP_VTXXX_8BIT 0 +#endif + +/* Add support for color terminals that cannot do background color erases + * Such terminals are poorly designed and are slowly disappearing but they + * are still quite common. For example, screen is one of them! + * + * This is experimental. In particular, it is not known to work if + * KANJI suupport is enabled. + */ +#if !defined(IBMPC_SYSTEM) +# define SLTT_HAS_NON_BCE_SUPPORT 1 +#else +# define SLTT_HAS_NON_BCE_SUPPORT 0 +#endif + +/* If you want slang to assume that an xterm always has the background color + * erase feature, then set this to 1. Otherwise, it will check the terminfo + * database. This may or may not be a good idea since most good color xterms + * support bce but many terminfo systems do not support it. + */ +#define SLTT_XTERM_ALWAYS_BCE 0 + +/* Set this to 1 to enable Kanji support. See above comment. */ +#define SLANG_HAS_KANJI_SUPPORT 0 + diff --git a/libslang/src/slang.c b/libslang/src/slang.c new file mode 100644 index 0000000..90b6e40 --- /dev/null +++ b/libslang/src/slang.c @@ -0,0 +1,5998 @@ +/* -*- mode: C; mode: fold; -*- */ +/* slang.c --- guts of S-Lang interpreter */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if SLANG_HAS_FLOAT +# include +#endif + +#include "slang.h" +#include "_slang.h" + +#define USE_COMBINED_BYTECODES 1 + +struct _SLBlock_Type; + +typedef struct +{ + struct _SLBlock_Type *body; + unsigned int num_refs; +} +_SLBlock_Header_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + union + { + _SLBlock_Header_Type *header; /* body of function */ + char *autoload_filename; + } + v; +#if _SLANG_HAS_DEBUG_CODE + char *file; +#endif +#define SLANG_MAX_LOCAL_VARIABLES 254 +#define AUTOLOAD_NUM_LOCALS (SLANG_MAX_LOCAL_VARIABLES + 1) + unsigned char nlocals; /* number of local variables */ + unsigned char nargs; /* number of arguments */ +} +_SLang_Function_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + SLang_Object_Type obj; +} +SLang_Global_Var_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + int local_var_number; +} +SLang_Local_Var_Type; + +typedef struct _SLBlock_Type +{ + unsigned char bc_main_type; + unsigned char bc_sub_type; + union + { + struct _SLBlock_Type *blk; + int i_blk; + + SLang_Name_Type *nt_blk; + SLang_App_Unary_Type *nt_unary_blk; + SLang_Intrin_Var_Type *nt_ivar_blk; + SLang_Intrin_Fun_Type *nt_ifun_blk; + SLang_Global_Var_Type *nt_gvar_blk; + SLang_IConstant_Type *iconst_blk; + SLang_DConstant_Type *dconst_blk; + _SLang_Function_Type *nt_fun_blk; + + VOID_STAR ptr_blk; + char *s_blk; + SLang_BString_Type *bs_blk; + +#if SLANG_HAS_FLOAT + double *double_blk; /*literal double is a pointer */ +#endif + float float_blk; + long l_blk; + struct _SLang_Struct_Type *struct_blk; + int (*call_function)(void); + } + b; +} +SLBlock_Type; + +static SLBlock_Type SLShort_Blocks[6]; +/* These are initialized in add_table below. I cannot init a Union!! */ + +/* Do not change these. Odd values are for termination */ +#define SHORT_BLOCK_RETURN_INDX 0 +#define SHORT_BLOCK_BREAK_INDX 2 +#define SHORT_BLOCK_CONTINUE_INDX 4 + +/* Debugging and tracing variables */ + +void (*SLang_Enter_Function)(char *) = NULL; +void (*SLang_Exit_Function)(char *) = NULL; +/* If non null, these call C functions before and after a slang function. */ + +int _SLang_Trace = 0; +/* If _SLang_Trace = -1, do not trace intrinsics */ +static int Trace_Mode = 0; + +static char *Trace_Function; /* function to be traced */ +int SLang_Traceback = 0; +/* non zero means do traceback. If less than 0, do not show local variables */ + +/* These variables handle _NARGS processing by the parser */ +int SLang_Num_Function_Args; +static int *Num_Args_Stack; +static unsigned int Recursion_Depth; +static SLang_Object_Type *Frame_Pointer; +static int Next_Function_Num_Args; +static unsigned int Frame_Pointer_Depth; +static unsigned int *Frame_Pointer_Stack; + +static int Lang_Break_Condition = 0; +/* true if any one below is true. This keeps us from testing 3 variables. + * I know this can be perfomed with a bitmapped variable, but... + */ +static int Lang_Break = 0; +static int Lang_Return = 0; +/* static int Lang_Continue = 0; */ + +static SLang_Object_Type *_SLRun_Stack; +static SLang_Object_Type *_SLStack_Pointer; +static SLang_Object_Type *_SLStack_Pointer_Max; + +/* Might want to increase this. */ +static SLang_Object_Type Local_Variable_Stack[SLANG_MAX_LOCAL_STACK]; +static SLang_Object_Type *Local_Variable_Frame = Local_Variable_Stack; + +static void free_function_header (_SLBlock_Header_Type *); + +#if _SLANG_OPTIMIZE_FOR_SPEED +static SLtype Class_Type [256]; +#endif +/* If 0, not an arith type. Otherwise it is. Also, value implies precedence + * See slarith.c for how this is used. + */ +static unsigned char Is_Arith_Type [256]; + +void (*SLang_Dump_Routine)(char *); + +static void call_dump_routine (char *fmt, ...) +{ + char buf[1024]; + va_list ap; + + va_start (ap, fmt); + if (SLang_Dump_Routine != NULL) + { + (void) _SLvsnprintf (buf, sizeof (buf), fmt, ap); + (*SLang_Dump_Routine) (buf); + } + else + { + vfprintf (stderr, fmt, ap); + fflush (stderr); + } + va_end (ap); +} + +static void do_traceback (char *, unsigned int, char *); +static int init_interpreter (void); + +/*{{{ push/pop/etc stack manipulation functions */ + +/* This routine is assumed to work even in the presence of a SLang_Error. */ +_INLINE_ +int SLang_pop (SLang_Object_Type *x) +{ + register SLang_Object_Type *y; + + y = _SLStack_Pointer; + if (y == _SLRun_Stack) + { + if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW; + x->data_type = 0; + return -1; + } + y--; + *x = *y; + + _SLStack_Pointer = y; + return 0; +} + +_INLINE_ +int SLang_peek_at_stack (void) +{ + if (_SLStack_Pointer == _SLRun_Stack) + { + if (SLang_Error == 0) + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + + return (_SLStack_Pointer - 1)->data_type; +} + +static int pop_ctrl_integer (int *i) +{ + int type; + SLang_Class_Type *cl; +#if _SLANG_OPTIMIZE_FOR_SPEED + register SLang_Object_Type *y; + + /* Most of the time, either an integer or a char will be on the stack. + * Optimize these cases. + */ + y = _SLStack_Pointer; + if (y == _SLRun_Stack) + { + if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + y--; + + type = y->data_type; + if (type == SLANG_INT_TYPE) + { + _SLStack_Pointer = y; + *i = y->v.int_val; + return 0; + } + if (type == SLANG_CHAR_TYPE) + { + _SLStack_Pointer = y; + *i = y->v.char_val; + return 0; + } +#else + if (-1 == (type = SLang_peek_at_stack ())) + return -1; +#endif + + cl = _SLclass_get_class ((unsigned char) type); + if (cl->cl_to_bool == NULL) + { + SLang_verror (SL_TYPE_MISMATCH, + "%s cannot be used in a boolean context", + cl->cl_name); + return -1; + } + return cl->cl_to_bool ((unsigned char) type, i); +} + +int SLang_peek_at_stack1 (void) +{ + int type; + + type = SLang_peek_at_stack (); + if (type == SLANG_ARRAY_TYPE) + type = (_SLStack_Pointer - 1)->v.array_val->data_type; + + return type; +} + +_INLINE_ +void SLang_free_object (SLang_Object_Type *obj) +{ + unsigned char data_type; + SLang_Class_Type *cl; + + if (obj == NULL) return; + data_type = obj->data_type; +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == Class_Type [data_type]) + return; + if (data_type == SLANG_STRING_TYPE) + { + SLang_free_slstring (obj->v.s_val); + return; + } +#endif + cl = _SLclass_get_class (data_type); +#if !_SLANG_OPTIMIZE_FOR_SPEED + if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR) +#endif + (*cl->cl_destroy) (data_type, (VOID_STAR) &obj->v); +} + +_INLINE_ +int SLang_push (SLang_Object_Type *x) +{ + register SLang_Object_Type *y; + y = _SLStack_Pointer; + + /* if there is a SLang_Error, probably not much harm will be done + if it is ignored here */ + /* if (SLang_Error) return; */ + + /* flag it now */ + if (y >= _SLStack_Pointer_Max) + { + if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW; + return -1; + } + + *y = *x; + _SLStack_Pointer = y + 1; + return 0; +} + +/* _INLINE_ */ +int SLclass_push_ptr_obj (unsigned char type, VOID_STAR pval) +{ + register SLang_Object_Type *y; + y = _SLStack_Pointer; + + if (y >= _SLStack_Pointer_Max) + { + if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW; + return -1; + } + + y->data_type = type; + y->v.ptr_val = pval; + + _SLStack_Pointer = y + 1; + return 0; +} + +_INLINE_ +int SLclass_push_int_obj (unsigned char type, int x) +{ + register SLang_Object_Type *y; + y = _SLStack_Pointer; + + if (y >= _SLStack_Pointer_Max) + { + if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW; + return -1; + } + + y->data_type = type; + y->v.int_val = x; + + _SLStack_Pointer = y + 1; + return 0; +} + +#if SLANG_HAS_FLOAT +_INLINE_ +int SLclass_push_double_obj (unsigned char type, double x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.double_val = x; + return SLang_push (&obj); +} +#endif + +_INLINE_ +int _SLang_pop_object_of_type (unsigned char type, SLang_Object_Type *obj, + int allow_arrays) +{ + register SLang_Object_Type *y; + + y = _SLStack_Pointer; + if (y == _SLRun_Stack) + return SLang_pop (obj); + y--; + if (y->data_type != type) + { +#if _SLANG_OPTIMIZE_FOR_SPEED + /* This is an implicit typecast. We do not want to typecast + * floats to ints implicitly. + */ + if (Is_Arith_Type [type] + && Is_Arith_Type [y->data_type] + && (Is_Arith_Type [type] >= Is_Arith_Type[y->data_type])) + { + /* This should not fail */ + (void) _SLarith_typecast (y->data_type, (VOID_STAR)&y->v, 1, + type, (VOID_STAR)&obj->v); + obj->data_type = type; + _SLStack_Pointer = y; + return 0; + } +#endif + + if ((allow_arrays == 0) + || (y->data_type != SLANG_ARRAY_TYPE) + || (y->v.array_val->data_type != type)) + if (-1 == SLclass_typecast (type, 1, 0)) + return -1; + } + *obj = *y; + _SLStack_Pointer = y; + return 0; +} + +/* This function reverses the top n items on the stack and returns a + * an offset from the start of the stack to the last item. + */ +int SLreverse_stack (int n) +{ + SLang_Object_Type *otop, *obot, tmp; + + otop = _SLStack_Pointer; + if ((n > otop - _SLRun_Stack) || (n < 0)) + { + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + obot = otop - n; + otop--; + while (otop > obot) + { + tmp = *obot; + *obot = *otop; + *otop = tmp; + otop--; + obot++; + } + return (int) ((_SLStack_Pointer - n) - _SLRun_Stack); +} + +_INLINE_ +int SLroll_stack (int np) +{ + int n, i; + SLang_Object_Type *otop, *obot, tmp; + + if ((n = abs(np)) <= 1) return 0; /* identity */ + + obot = otop = _SLStack_Pointer; + i = n; + while (i != 0) + { + if (obot <= _SLRun_Stack) + { + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + obot--; + i--; + } + otop--; + + if (np > 0) + { + /* Put top on bottom and roll rest up. */ + tmp = *otop; + while (otop > obot) + { + *otop = *(otop - 1); + otop--; + } + *otop = tmp; + } + else + { + /* Put bottom on top and roll rest down. */ + tmp = *obot; + while (obot < otop) + { + *obot = *(obot + 1); + obot++; + } + *obot = tmp; + } + return 0; +} + +int _SLstack_depth (void) +{ + return (int) (_SLStack_Pointer - _SLRun_Stack); +} + +int SLdup_n (int n) +{ + SLang_Object_Type *bot, *top; + + if (n <= 0) + return 0; + + top = _SLStack_Pointer; + if (top < _SLRun_Stack + n) + { + if (SLang_Error == 0) + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + if (top + n > _SLStack_Pointer_Max) + { + if (SLang_Error == 0) + SLang_Error = SL_STACK_OVERFLOW; + return -1; + } + bot = top - n; + + while (bot < top) + { + SLang_Class_Type *cl; + unsigned char data_type = bot->data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == Class_Type [data_type]) + { + *_SLStack_Pointer++ = *bot++; + continue; + } +#endif + cl = _SLclass_get_class (data_type); + if (-1 == (*cl->cl_push) (data_type, (VOID_STAR) &bot->v)) + return -1; + bot++; + } + return 0; +} + +/*}}}*/ + +/*{{{ inner interpreter and support functions */ + +_INLINE_ +int _SL_increment_frame_pointer (void) +{ + if (Recursion_Depth >= SLANG_MAX_RECURSIVE_DEPTH) + { + SLang_verror (SL_STACK_OVERFLOW, "Num Args Stack Overflow"); + return -1; + } + Num_Args_Stack [Recursion_Depth] = SLang_Num_Function_Args; + + SLang_Num_Function_Args = Next_Function_Num_Args; + Next_Function_Num_Args = 0; + Recursion_Depth++; + return 0; +} + +_INLINE_ +int _SL_decrement_frame_pointer (void) +{ + if (Recursion_Depth == 0) + { + SLang_verror (SL_STACK_UNDERFLOW, "Num Args Stack Underflow"); + return -1; + } + + Recursion_Depth--; + if (Recursion_Depth < SLANG_MAX_RECURSIVE_DEPTH) + SLang_Num_Function_Args = Num_Args_Stack [Recursion_Depth]; + + return 0; +} + +_INLINE_ +int SLang_start_arg_list (void) +{ + if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH) + { + Frame_Pointer_Stack [Frame_Pointer_Depth] = (unsigned int) (Frame_Pointer - _SLRun_Stack); + Frame_Pointer = _SLStack_Pointer; + Frame_Pointer_Depth++; + Next_Function_Num_Args = 0; + return 0; + } + + SLang_verror (SL_STACK_OVERFLOW, "Frame Stack Overflow"); + return -1; +} + +_INLINE_ +int SLang_end_arg_list (void) +{ + if (Frame_Pointer_Depth == 0) + { + SLang_verror (SL_STACK_UNDERFLOW, "Frame Stack Underflow"); + return -1; + } + Frame_Pointer_Depth--; + if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH) + { + Next_Function_Num_Args = (int) (_SLStack_Pointer - Frame_Pointer); + Frame_Pointer = _SLRun_Stack + Frame_Pointer_Stack [Frame_Pointer_Depth]; + } + return 0; +} + +_INLINE_ +static int do_bc_call_direct_frame (int (*f)(void)) +{ + if ((0 == SLang_end_arg_list ()) + && (0 == _SL_increment_frame_pointer ())) + { + (void) (*f) (); + _SL_decrement_frame_pointer (); + } + if (SLang_Error) + return -1; + return 0; +} + +static int do_name_type_error (SLang_Name_Type *nt) +{ + char buf[256]; + if (nt != NULL) + { + (void) _SLsnprintf (buf, sizeof (buf), "(Error occurred processing %s)", nt->name); + do_traceback (buf, 0, NULL); + } + return -1; +} + +/* local and global variable assignments */ + +static int do_binary_ab (int op, SLang_Object_Type *obja, SLang_Object_Type *objb) +{ + SLang_Class_Type *a_cl, *b_cl, *c_cl; + unsigned char b_data_type, a_data_type, c_data_type; + int (*binary_fun) (int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR); + VOID_STAR pa; + VOID_STAR pb; + VOID_STAR pc; + int ret; + + b_data_type = objb->data_type; + a_data_type = obja->data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (Is_Arith_Type[a_data_type] + && Is_Arith_Type[b_data_type]) + { + int status; + status = _SLarith_bin_op (obja, objb, op); + if (status != 1) + return status; + /* drop and try it the hard way */ + } +#endif + + a_cl = _SLclass_get_class (a_data_type); + if (a_data_type == b_data_type) + b_cl = a_cl; + else + b_cl = _SLclass_get_class (b_data_type); + + if (NULL == (binary_fun = _SLclass_get_binary_fun (op, a_cl, b_cl, &c_cl, 1))) + return -1; + + c_data_type = c_cl->cl_data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == Class_Type [a_data_type]) + pa = (VOID_STAR) &obja->v; + else +#endif + pa = _SLclass_get_ptr_to_value (a_cl, obja); + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == Class_Type [b_data_type]) + pb = (VOID_STAR) &objb->v; + else +#endif + pb = _SLclass_get_ptr_to_value (b_cl, objb); + + pc = c_cl->cl_transfer_buf; + + if (1 != (*binary_fun) (op, + a_data_type, pa, 1, + b_data_type, pb, 1, + pc)) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Binary operation between %s and %s failed", + a_cl->cl_name, b_cl->cl_name); + + return -1; + } + + /* apush will create a copy, so make sure we free after the push */ + ret = (*c_cl->cl_apush)(c_data_type, pc); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [c_data_type]) +#endif + (*c_cl->cl_adestroy)(c_data_type, pc); + + return ret; +} + +_INLINE_ +static int do_binary_ab_inc_ref (int op, SLang_Object_Type *obja, SLang_Object_Type *objb) +{ + int ret; +#if _SLANG_USE_TMP_OPTIMIZATION + int inc = 0; + + if (obja->data_type == SLANG_ARRAY_TYPE) + { + inc |= 1; + obja->v.array_val->num_refs++; + } + if (objb->data_type == SLANG_ARRAY_TYPE) + { + inc |= 2; + objb->v.array_val->num_refs++; + } +#endif + ret = do_binary_ab (op, obja, objb); + +#if _SLANG_USE_TMP_OPTIMIZATION + if (inc & 1) obja->v.array_val->num_refs--; + if (inc & 2) objb->v.array_val->num_refs--; +#endif + + return ret; +} + +_INLINE_ +static void do_binary (int op) +{ + SLang_Object_Type obja, objb; + + if (SLang_pop (&objb)) return; + if (0 == SLang_pop (&obja)) + { + (void) do_binary_ab (op, &obja, &objb); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [obja.data_type]) +#endif + SLang_free_object (&obja); + } +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [objb.data_type]) +#endif + SLang_free_object (&objb); +} + +_INLINE_ +static void do_binary_b (int op, SLang_Object_Type *bp) +{ + SLang_Object_Type a; + + if (SLang_pop (&a)) return; + (void) do_binary_ab (op, &a, bp); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [a.data_type]) +#endif + SLang_free_object (&a); +} + +_INLINE_ +static void do_binary_b_inc_ref (int op, SLang_Object_Type *bp) +{ + SLang_Object_Type a; + + if (SLang_pop (&a)) return; +#if _SLANG_USE_TMP_OPTIMIZATION + if (bp->data_type == SLANG_ARRAY_TYPE) + { + bp->v.array_val->num_refs++; + (void) do_binary_ab (op, &a, bp); + bp->v.array_val->num_refs--; + } + else +#endif + (void) do_binary_ab (op, &a, bp); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [a.data_type]) +#endif + SLang_free_object (&a); +} + +static int do_unary_op (int op, SLang_Object_Type *obj, int unary_type) +{ + int (*f) (int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); + VOID_STAR pa; + VOID_STAR pb; + SLang_Class_Type *a_cl, *b_cl; + unsigned char a_type, b_type; + int ret; + + a_type = obj->data_type; + a_cl = _SLclass_get_class (a_type); + + if (NULL == (f = _SLclass_get_unary_fun (op, a_cl, &b_cl, unary_type))) + return -1; + + b_type = b_cl->cl_data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == Class_Type [a_type]) + pa = (VOID_STAR) &obj->v; + else +#endif + pa = _SLclass_get_ptr_to_value (a_cl, obj); + + pb = b_cl->cl_transfer_buf; + + if (1 != (*f) (op, a_type, pa, 1, pb)) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Unary operation for %s failed", a_cl->cl_name); + return -1; + } + + ret = (*b_cl->cl_apush)(b_type, pb); + /* cl_apush creates a copy, so make sure we call cl_adestroy */ +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [b_type]) +#endif + (*b_cl->cl_adestroy)(b_type, pb); + + return ret; +} + +_INLINE_ +static int do_unary (int op, int unary_type) +{ + SLang_Object_Type obj; + int ret; + + if (-1 == SLang_pop (&obj)) return -1; + ret = do_unary_op (op, &obj, unary_type); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [obj.data_type]) +#endif + SLang_free_object (&obj); + return ret; +} + +static int do_assignment_binary (int op, SLang_Object_Type *obja_ptr) +{ + SLang_Object_Type objb; + int ret; + + if (SLang_pop (&objb)) + return -1; + + ret = do_binary_ab (op, obja_ptr, &objb); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [objb.data_type]) +#endif + SLang_free_object (&objb); + return ret; +} + +/* The order of these is assumed to match the binary operators + * defined in slang.h + */ +static int +map_assignment_op_to_binary (unsigned char op_type, int *op, int *is_unary) +{ + *is_unary = 0; + switch (op_type) + { + case _SLANG_BCST_PLUSEQS: + case _SLANG_BCST_MINUSEQS: + case _SLANG_BCST_TIMESEQS: + case _SLANG_BCST_DIVEQS: + *op = SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS); + break; + + case _SLANG_BCST_BOREQS: + *op = SLANG_BOR; + break; + + case _SLANG_BCST_BANDEQS: + *op = SLANG_BAND; + break; + + case _SLANG_BCST_POST_MINUSMINUS: + case _SLANG_BCST_MINUSMINUS: + *op = SLANG_MINUS; + *is_unary = 1; + break; + + case _SLANG_BCST_PLUSPLUS: + case _SLANG_BCST_POST_PLUSPLUS: + *op = SLANG_PLUS; + *is_unary = 1; + break; + + default: + SLang_verror (SL_NOT_IMPLEMENTED, "Assignment operator not implemented"); + return -1; + } + return 0; +} + +static int +perform_lvalue_operation (unsigned char op_type, SLang_Object_Type *obja_ptr) +{ + switch (op_type) + { + case _SLANG_BCST_ASSIGN: + break; + + /* The order of these is assumed to match the binary operators + * defined in slang.h + */ + case _SLANG_BCST_PLUSEQS: + case _SLANG_BCST_MINUSEQS: + case _SLANG_BCST_TIMESEQS: + case _SLANG_BCST_DIVEQS: + if (-1 == do_assignment_binary (SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS), obja_ptr)) + return -1; + break; + + case _SLANG_BCST_BOREQS: + if (-1 == do_assignment_binary (SLANG_BOR, obja_ptr)) + return -1; + break; + + case _SLANG_BCST_BANDEQS: + if (-1 == do_assignment_binary (SLANG_BAND, obja_ptr)) + return -1; + break; + + case _SLANG_BCST_PLUSPLUS: + case _SLANG_BCST_POST_PLUSPLUS: +#if _SLANG_OPTIMIZE_FOR_SPEED + if (obja_ptr->data_type == SLANG_INT_TYPE) + return SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_val + 1); +#endif + if (-1 == do_unary_op (SLANG_PLUSPLUS, obja_ptr, _SLANG_BC_UNARY)) + return -1; + break; + + case _SLANG_BCST_MINUSMINUS: + case _SLANG_BCST_POST_MINUSMINUS: +#if _SLANG_OPTIMIZE_FOR_SPEED + if (obja_ptr->data_type == SLANG_INT_TYPE) + return SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_val - 1); +#endif + if (-1 == do_unary_op (SLANG_MINUSMINUS, obja_ptr, _SLANG_BC_UNARY)) + return -1; + break; + + default: + SLang_Error = SL_INTERNAL_ERROR; + return -1; + } + return 0; +} + +_INLINE_ +static int +set_lvalue_obj (unsigned char op_type, SLang_Object_Type *obja_ptr) +{ + if (op_type != _SLANG_BCST_ASSIGN) + { + if (-1 == perform_lvalue_operation (op_type, obja_ptr)) + return -1; + } +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [obja_ptr->data_type]) +#endif + SLang_free_object (obja_ptr); + + return SLang_pop(obja_ptr); +} + +static int +set_struct_lvalue (SLBlock_Type *bc_blk) +{ + int type; + SLang_Class_Type *cl; + char *name; + int op; + + if (-1 == (type = SLang_peek_at_stack ())) + return -1; + + cl = _SLclass_get_class (type); + if ((cl->cl_sput == NULL) + || (cl->cl_sget == NULL)) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "%s does not support structure access", + cl->cl_name); + SLdo_pop_n (2); /* object plus what was to be assigned */ + return -1; + } + name = bc_blk->b.s_blk; + op = bc_blk->bc_sub_type; + + if (op != _SLANG_BCST_ASSIGN) + { + /* We have something like (A.x += b) or (A.x++). In either case, + * we need A.x. + */ + SLang_Object_Type obj_A; + SLang_Object_Type obj; + + if (-1 == SLang_pop (&obj_A)) + return -1; + + if ((-1 == _SLpush_slang_obj (&obj_A)) + || (-1 == cl->cl_sget ((unsigned char) type, name)) + || (-1 == SLang_pop (&obj))) + { + SLang_free_object (&obj_A); + return -1; + } + /* Now the value of A.x is in obj. */ + if (-1 == perform_lvalue_operation (op, &obj)) + { + SLang_free_object (&obj); + SLang_free_object (&obj_A); + return -1; + } + SLang_free_object (&obj); + /* The result of the operation is now on the stack. + * Perform assignment */ + if (-1 == SLang_push (&obj_A)) + { + SLang_free_object (&obj_A); + return -1; + } + } + + return (*cl->cl_sput) ((unsigned char) type, name); +} + +static int make_unit_object (SLang_Object_Type *a, SLang_Object_Type *u) +{ + unsigned char type; + + type = a->data_type; + if (type == SLANG_ARRAY_TYPE) + type = a->v.array_val->data_type; + + u->data_type = type; + switch (type) + { + case SLANG_UCHAR_TYPE: + case SLANG_CHAR_TYPE: + u->v.char_val = 1; + break; + + case SLANG_SHORT_TYPE: + case SLANG_USHORT_TYPE: + u->v.short_val = 1; + break; + + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: + u->v.long_val = 1; + break; + +#if SLANG_HAS_FLOAT + case SLANG_FLOAT_TYPE: + u->v.float_val = 1; + break; + + case SLANG_COMPLEX_TYPE: + u->data_type = SLANG_DOUBLE_TYPE; + case SLANG_DOUBLE_TYPE: + u->v.double_val = 1; + break; +#endif + default: + u->data_type = SLANG_INT_TYPE; + u->v.int_val = 1; + } + return 0; +} + + +/* We want to convert 'A[i] op X' to 'A[i] = A[i] op X'. The code that + * has been generated is: X __args i A __aput-op + * where __aput-op represents this function. We need to generate: + * __args i A __eargs __aget X op __args i A __eargs __aput + * Here, __eargs implies a call to do_bc_call_direct_frame with either + * the aput or aget function. In addition, __args represents a call to + * SLang_start_arg_list. Of course, i represents a set of indices. + * + * Note: If op is an unary operation (e.g., ++ or --), then X will not + * b present an will have to be taken to be 1. + * + * Implementation note: For efficiency, calls to setup the frame, start + * arg list will be omitted and SLang_Num_Function_Args will be set. + * This is ugly but the alternative is much less efficient rendering these + * assignment operators useless. So, the plan is to roll the stack to get X, + * then duplicate the next N values, call __aget followed by op X, finally + * calling __aput. Hence, the sequence is: + * + * start: X i .. j A + * dupN: X i .. j A i .. j A + * __aget: X i .. j A Y + * roll: i .. j A Y X + * op: i .. j A Z + * roll: Z i .. j A + * __aput: + */ +static int +set_array_lvalue (int op) +{ + SLang_Object_Type x, y; + int num_args, is_unary; + + if (-1 == map_assignment_op_to_binary (op, &op, &is_unary)) + return -1; + + /* Grab the indices and the array. Do not start a new frame. */ + if (-1 == SLang_end_arg_list ()) + return -1; + num_args = Next_Function_Num_Args; + Next_Function_Num_Args = 0; + + if (-1 == SLdup_n (num_args)) + return -1; + + SLang_Num_Function_Args = num_args; + if (-1 == _SLarray_aget ()) + return -1; + + if (-1 == SLang_pop (&y)) + return -1; + + if (is_unary == 0) + { + if ((-1 == SLroll_stack (-(num_args + 1))) + || (-1 == SLang_pop (&x))) + { + SLang_free_object (&y); + return -1; + } + } + else if (-1 == make_unit_object (&y, &x)) + { + SLang_free_object (&y); + return -1; + } + + if (-1 == do_binary_ab (op, &y, &x)) + { + SLang_free_object (&y); + SLang_free_object (&x); + return -1; + } +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [y.data_type]) +#endif + SLang_free_object (&y); + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [x.data_type]) +#endif + SLang_free_object (&x); + + if (-1 == SLroll_stack (num_args + 1)) + return -1; + + SLang_Num_Function_Args = num_args; + return _SLarray_aput (); +} + + +static int +set_intrin_lvalue (SLBlock_Type *bc_blk) +{ + unsigned char op_type; + SLang_Object_Type obja; + SLang_Class_Type *cl; + SLang_Intrin_Var_Type *ivar; + VOID_STAR intrinsic_addr; + unsigned char intrinsic_type; + + ivar = bc_blk->b.nt_ivar_blk; + + intrinsic_type = ivar->type; + intrinsic_addr = ivar->addr; + + op_type = bc_blk->bc_sub_type; + + cl = _SLclass_get_class (intrinsic_type); + + if (op_type != _SLANG_BCST_ASSIGN) + { + /* We want to get the current value into obja. This is the + * easiest way. + */ + if ((-1 == (*cl->cl_push) (intrinsic_type, intrinsic_addr)) + || (-1 == SLang_pop (&obja))) + return -1; + + (void) perform_lvalue_operation (op_type, &obja); + SLang_free_object (&obja); + + if (SLang_Error) + return -1; + } + + return (*cl->cl_pop) (intrinsic_type, intrinsic_addr); +} + +int _SLang_deref_assign (SLang_Ref_Type *ref) +{ + SLang_Object_Type *objp; + SLang_Name_Type *nt; + SLBlock_Type blk; + + if (ref->is_global == 0) + { + objp = ref->v.local_obj; + if (objp > Local_Variable_Frame) + { + SLang_verror (SL_UNDEFINED_NAME, "Local variable reference is out of scope"); + return -1; + } + return set_lvalue_obj (_SLANG_BCST_ASSIGN, objp); + } + + nt = ref->v.nt; + switch (nt->name_type) + { + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + if (-1 == set_lvalue_obj (_SLANG_BCST_ASSIGN, + &((SLang_Global_Var_Type *)nt)->obj)) + { + do_name_type_error (nt); + return -1; + } + break; + + case SLANG_IVARIABLE: + blk.b.nt_blk = nt; + blk.bc_sub_type = _SLANG_BCST_ASSIGN; + if (-1 == set_intrin_lvalue (&blk)) + { + do_name_type_error (nt); + return -1; + } + break; + + case SLANG_LVARIABLE: + SLang_Error = SL_INTERNAL_ERROR; + /* set_intrin_lvalue (&blk); */ + return -1; + + case SLANG_RVARIABLE: + default: + SLang_verror (SL_READONLY_ERROR, "deref assignment to %s not allowed", nt->name); + return -1; + } + + return 0; +} + +static void set_deref_lvalue (SLBlock_Type *bc_blk) +{ + SLang_Object_Type *objp; + SLang_Ref_Type *ref; + + switch (bc_blk->bc_sub_type) + { + case SLANG_LVARIABLE: + objp = (Local_Variable_Frame - bc_blk->b.i_blk); + break; + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + objp = &bc_blk->b.nt_gvar_blk->obj; + break; + default: + SLang_Error = SL_INTERNAL_ERROR; + return; + } + + if (-1 == _SLpush_slang_obj (objp)) + return; + + if (-1 == SLang_pop_ref (&ref)) + return; + (void) _SLang_deref_assign (ref); + SLang_free_ref (ref); +} + +static int push_struct_field (char *name) +{ + int type; + SLang_Class_Type *cl; + + if (-1 == (type = SLang_peek_at_stack ())) + return -1; + + cl = _SLclass_get_class ((unsigned char) type); + if (cl->cl_sget == NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "%s does not permit structure access", + cl->cl_name); + SLdo_pop_n (2); + return -1; + } + + return (*cl->cl_sget) ((unsigned char) type, name); +} + +static void trace_dump (char *format, char *name, SLang_Object_Type *objs, int n, int dir) +{ + unsigned int len; + char prefix [52]; + + len = Trace_Mode - 1; + if (len + 2 >= sizeof (prefix)) + len = sizeof (prefix) - 2; + + SLMEMSET (prefix, ' ', len); + prefix[len] = 0; + + call_dump_routine (prefix); + call_dump_routine (format, name, n); + + if (n > 0) + { + prefix[len] = ' '; + len++; + prefix[len] = 0; + + _SLdump_objects (prefix, objs, n, dir); + } +} + +/* Pop a data item from the stack and return a pointer to it. + * Strings are not freed from stack so use another routine to do it. + */ +static VOID_STAR pop_pointer (SLang_Object_Type *obj, unsigned char type) +{ +#ifndef _SLANG_OPTIMIZE_FOR_SPEED + SLang_Class_Type *cl; +#endif + + SLang_Array_Type *at; + + /* Arrays are special. Allow scalars to automatically convert to arrays. + */ + if (type == SLANG_ARRAY_TYPE) + { + if (-1 == SLang_pop_array (&at, 1)) + return NULL; + obj->data_type = SLANG_ARRAY_TYPE; + return obj->v.ptr_val = (VOID_STAR) at; + } + + if (type == 0) + { + /* This happens when an intrinsic is declared without any information + * regarding parameter types. + */ + if (-1 == SLang_pop (obj)) + return NULL; + type = obj->data_type; + } + else if (-1 == _SLang_pop_object_of_type (type, obj, 0)) + return NULL; + +#if _SLANG_OPTIMIZE_FOR_SPEED + type = Class_Type [type]; +#else + type = _SLclass_get_class (type)->cl_class_type; +#endif + + if (type == SLANG_CLASS_TYPE_SCALAR) + return (VOID_STAR) &obj->v; + else if (type == SLANG_CLASS_TYPE_MMT) + return SLang_object_from_mmt (obj->v.ref); + else + return obj->v.ptr_val; +} + +/* This is ugly. Does anyone have a advice for a cleaner way of doing + * this?? + */ +typedef void (*VF0_Type)(void); +typedef void (*VF1_Type)(VOID_STAR); +typedef void (*VF2_Type)(VOID_STAR, VOID_STAR); +typedef void (*VF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR); +typedef void (*VF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef void (*VF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef void (*VF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef void (*VF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF0_Type)(void); +typedef long (*LF1_Type)(VOID_STAR); +typedef long (*LF2_Type)(VOID_STAR, VOID_STAR); +typedef long (*LF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +#if SLANG_HAS_FLOAT +typedef double (*FF0_Type)(void); +typedef double (*FF1_Type)(VOID_STAR); +typedef double (*FF2_Type)(VOID_STAR, VOID_STAR); +typedef double (*FF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR); +typedef double (*FF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef double (*FF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef double (*FF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef double (*FF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +#endif + +static int execute_intrinsic_fun (SLang_Intrin_Fun_Type *objf) +{ +#if SLANG_HAS_FLOAT + double xf; +#endif + VOID_STAR p[SLANG_MAX_INTRIN_ARGS]; + SLang_Object_Type objs[SLANG_MAX_INTRIN_ARGS]; + long ret; + unsigned char type; + unsigned int argc; + unsigned int i; + FVOID_STAR fptr; + unsigned char *arg_types; + int stk_depth; + + fptr = objf->i_fun; + argc = objf->num_args; + type = objf->return_type; + arg_types = objf->arg_types; + + if (argc > SLANG_MAX_INTRIN_ARGS) + { + SLang_verror(SL_APPLICATION_ERROR, + "Intrinsic function %s requires too many parameters", objf->name); + return -1; + } + + if (-1 == _SL_increment_frame_pointer ()) + return -1; + + stk_depth = -1; + if (Trace_Mode && (_SLang_Trace > 0)) + { + int nargs; + + stk_depth = _SLstack_depth (); + + nargs = SLang_Num_Function_Args; + if (nargs == 0) + nargs = (int)argc; + + stk_depth -= nargs; + + if (stk_depth >= 0) + trace_dump (">>%s (%d args)\n", + objf->name, + _SLStack_Pointer - nargs, + nargs, + 1); + } + + i = argc; + while (i != 0) + { + i--; + if (NULL == (p[i] = pop_pointer (objs + i, arg_types[i]))) + { + i++; + goto free_and_return; + } + } + + ret = 0; +#if SLANG_HAS_FLOAT + xf = 0.0; +#endif + + switch (argc) + { + case 0: + if (type == SLANG_VOID_TYPE) ((VF0_Type) fptr) (); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF0_Type) fptr)(); +#endif + else ret = ((LF0_Type) fptr)(); + break; + + case 1: + if (type == SLANG_VOID_TYPE) ((VF1_Type) fptr)(p[0]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF1_Type) fptr)(p[0]); +#endif + else ret = ((LF1_Type) fptr)(p[0]); + break; + + case 2: + if (type == SLANG_VOID_TYPE) ((VF2_Type) fptr)(p[0], p[1]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF2_Type) fptr)(p[0], p[1]); +#endif + else ret = ((LF2_Type) fptr)(p[0], p[1]); + break; + + case 3: + if (type == SLANG_VOID_TYPE) ((VF3_Type) fptr)(p[0], p[1], p[2]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF3_Type) fptr)(p[0], p[1], p[2]); +#endif + else ret = ((LF3_Type) fptr)(p[0], p[1], p[2]); + break; + + case 4: + if (type == SLANG_VOID_TYPE) ((VF4_Type) fptr)(p[0], p[1], p[2], p[3]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF4_Type) fptr)(p[0], p[1], p[2], p[3]); +#endif + else ret = ((LF4_Type) fptr)(p[0], p[1], p[2], p[3]); + break; + + case 5: + if (type == SLANG_VOID_TYPE) ((VF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]); +#endif + else ret = ((LF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]); + break; + + case 6: + if (type == SLANG_VOID_TYPE) ((VF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]); +#endif + else ret = ((LF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]); + break; + + case 7: + if (type == SLANG_VOID_TYPE) ((VF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]); +#endif + else ret = ((LF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]); + break; + } + + switch (type) + { + case SLANG_VOID_TYPE: + break; + +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + (void) SLclass_push_double_obj (SLANG_DOUBLE_TYPE, xf); + break; +#endif + case SLANG_UINT_TYPE: + case SLANG_INT_TYPE: (void) SLclass_push_int_obj (type, (int) ret); + break; + + case SLANG_CHAR_TYPE: + case SLANG_UCHAR_TYPE: (void) SLclass_push_char_obj (type, (char) ret); + break; + + case SLANG_SHORT_TYPE: + case SLANG_USHORT_TYPE: (void) SLclass_push_short_obj (type, (short) ret); + break; + + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: (void) SLclass_push_long_obj (type, ret); + break; + + case SLANG_STRING_TYPE: + if (NULL == (char *)ret) + { + if (SLang_Error == 0) SLang_Error = SL_INTRINSIC_ERROR; + } + else (void) SLang_push_string ((char *)ret); + break; + + default: + SLang_verror (SL_NOT_IMPLEMENTED, + "Support for intrinsic functions returning %s is not provided", + SLclass_get_datatype_name (type)); + } + + if (stk_depth >= 0) + { + stk_depth = _SLstack_depth () - stk_depth; + + trace_dump ("<<%s (returning %d values)\n", + objf->name, + _SLStack_Pointer - stk_depth, + stk_depth, + 1); + } + + free_and_return: + while (i < argc) + { + SLang_free_object (objs + i); + i++; + } + + return _SL_decrement_frame_pointer (); +} + +static int inner_interp(register SLBlock_Type *); + +/* Switch_Obj_Ptr points to the NEXT available free switch object */ +static SLang_Object_Type Switch_Objects[SLANG_MAX_NESTED_SWITCH]; +static SLang_Object_Type *Switch_Obj_Ptr = Switch_Objects; +static SLang_Object_Type *Switch_Obj_Max = Switch_Objects + SLANG_MAX_NESTED_SWITCH; + +static void +lang_do_loops (unsigned char stype, SLBlock_Type *block, unsigned int num_blocks) +{ + int i, ctrl; + int first, last; + SLBlock_Type *blks[4]; + char *loop_name; + SLang_Foreach_Context_Type *foreach_context; + SLang_Class_Type *cl; + int type; + unsigned int j; + + j = 0; + for (i = 0; i < (int) num_blocks; i++) + { + if (block[i].bc_main_type != _SLANG_BC_BLOCK) + { + if (block[i].bc_main_type == _SLANG_BC_LINE_NUM) + continue; + + SLang_verror (SL_SYNTAX_ERROR, "Bytecode is not a looping block"); + return; + } + blks[j] = block[i].b.blk; + j++; + } + + num_blocks = j; + block = blks[0]; + + switch (stype) + { + int next_fn_args; + + case _SLANG_BCST_FOREACH: + loop_name = "foreach"; + if (num_blocks != 1) + goto wrong_num_blocks_error; + + /* We should find Next_Function_Num_Args + 1 items on the stack. + * The first Next_Function_Num_Args items represent the arguments to + * to USING. The last item (deepest in stack) is the object to loop + * over. So, roll the stack up and grab it. + */ + next_fn_args = Next_Function_Num_Args; + Next_Function_Num_Args = 0; + if ((-1 == SLroll_stack (-(next_fn_args + 1))) + || (-1 == (type = SLang_peek_at_stack ()))) + goto return_error; + + cl = _SLclass_get_class ((unsigned char) type); + if ((cl->cl_foreach == NULL) + || (cl->cl_foreach_open == NULL) + || (cl->cl_foreach_close == NULL)) + { + SLang_verror (SL_NOT_IMPLEMENTED, "%s does not permit foreach", cl->cl_name); + SLdo_pop_n (next_fn_args + 1); + goto return_error; + } + + if (NULL == (foreach_context = (*cl->cl_foreach_open) ((unsigned char)type, next_fn_args))) + goto return_error; + + while (1) + { + int status; + + if (SLang_Error) + { + (*cl->cl_foreach_close) ((unsigned char) type, foreach_context); + goto return_error; + } + + status = (*cl->cl_foreach) ((unsigned char) type, foreach_context); + if (status <= 0) + { + if (status == 0) + break; + + (*cl->cl_foreach_close) ((unsigned char) type, foreach_context); + goto return_error; + } + + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + (*cl->cl_foreach_close) ((unsigned char) type, foreach_context); + break; + + case _SLANG_BCST_WHILE: + loop_name = "while"; + + if (num_blocks != 2) + goto wrong_num_blocks_error; + + type = blks[1]->bc_main_type; + while (1) + { + if (SLang_Error) + goto return_error; + + inner_interp (block); + if (Lang_Break) break; + + if (-1 == pop_ctrl_integer (&ctrl)) + goto return_error; + + if (ctrl == 0) break; + + if (type) + { + inner_interp (blks[1]); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + } + break; + + case _SLANG_BCST_DOWHILE: + loop_name = "do...while"; + + if (num_blocks != 2) + goto wrong_num_blocks_error; + + while (1) + { + if (SLang_Error) + goto return_error; + + Lang_Break_Condition = /* Lang_Continue = */ 0; + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + inner_interp (blks[1]); + if (-1 == pop_ctrl_integer (&ctrl)) + goto return_error; + + if (ctrl == 0) break; + } + break; + + case _SLANG_BCST_CFOR: + loop_name = "for"; + + /* we need 4 blocks: first 3 control, the last is code */ + if (num_blocks != 4) goto wrong_num_blocks_error; + + inner_interp (block); + while (1) + { + if (SLang_Error) + goto return_error; + + inner_interp(blks[1]); /* test */ + if (-1 == pop_ctrl_integer (&ctrl)) + goto return_error; + + if (ctrl == 0) break; + inner_interp(blks[3]); /* code */ + if (Lang_Break) break; + inner_interp(blks[2]); /* bump */ + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + break; + + case _SLANG_BCST_FOR: + loop_name = "_for"; + + if (num_blocks != 1) + goto wrong_num_blocks_error; + + /* 3 elements: first, last, step */ + if ((-1 == SLang_pop_integer (&ctrl)) + || (-1 == SLang_pop_integer (&last)) + || (-1 == SLang_pop_integer (&first))) + goto return_error; + + i = first; + while (1) + { + /* It is ugly to have this test here but I do not know of a + * simple way to do this without using two while loops. + */ + if (ctrl >= 0) + { + if (i > last) break; + } + else if (i < last) break; + + if (SLang_Error) goto return_error; + + SLclass_push_int_obj (SLANG_INT_TYPE, i); + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + + i += ctrl; + } + break; + + case _SLANG_BCST_LOOP: + loop_name = "loop"; + if (num_blocks != 1) + goto wrong_num_blocks_error; + + if (-1 == SLang_pop_integer (&ctrl)) + goto return_error; + while (ctrl > 0) + { + ctrl--; + + if (SLang_Error) + goto return_error; + + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + break; + + case _SLANG_BCST_FOREVER: + loop_name = "forever"; + + if (num_blocks != 1) + goto wrong_num_blocks_error; + + while (1) + { + if (SLang_Error) + goto return_error; + + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + break; + + default: SLang_verror(SL_INTERNAL_ERROR, "Unknown loop type"); + return; + } + Lang_Break = /* Lang_Continue = */ 0; + Lang_Break_Condition = Lang_Return; + return; + + wrong_num_blocks_error: + SLang_verror (SL_SYNTAX_ERROR, "Wrong number of blocks for '%s' construct", loop_name); + + /* drop */ + return_error: + do_traceback (loop_name, 0, NULL); +} + +static void lang_do_and_orelse (unsigned char stype, SLBlock_Type *addr, SLBlock_Type *addr_max) +{ + int test = 0; + int is_or; + + is_or = (stype == _SLANG_BCST_ORELSE); + + while (addr <= addr_max) + { + if (addr->bc_main_type == _SLANG_BC_LINE_NUM) + { + addr++; + continue; + } + + inner_interp (addr->b.blk); + if (SLang_Error + || Lang_Break_Condition + || (-1 == pop_ctrl_integer (&test))) + return; + + if (is_or == (test != 0)) + break; + + /* if (((stype == _SLANG_BCST_ANDELSE) && (test == 0)) + * || ((stype == _SLANG_BCST_ORELSE) && test)) + * break; + */ + + addr++; + } + SLclass_push_int_obj (SLANG_INT_TYPE, test); +} + +static void do_else_if (SLBlock_Type *zero_block, SLBlock_Type *non_zero_block) +{ + int test; + + if (-1 == pop_ctrl_integer (&test)) + return; + + if (test == 0) + non_zero_block = zero_block; + + if (non_zero_block != NULL) + inner_interp (non_zero_block->b.blk); +} + +int _SLang_trace_fun (char *f) +{ + if (NULL == (f = SLang_create_slstring (f))) + return -1; + + SLang_free_slstring (Trace_Function); + Trace_Function = f; + _SLang_Trace = 1; + return 0; +} + +int _SLdump_objects (char *prefix, SLang_Object_Type *x, unsigned int n, int dir) +{ + char *s; + SLang_Class_Type *cl; + + while (n) + { + cl = _SLclass_get_class (x->data_type); + + if (NULL == (s = _SLstringize_object (x))) + s = "??"; + + call_dump_routine ("%s[%s]:%s\n", prefix, cl->cl_name, s); + + SLang_free_slstring (s); + + x += dir; + n--; + } + return 0; +} + +static SLBlock_Type *Exit_Block_Ptr; +static SLBlock_Type *Global_User_Block[5]; +static SLBlock_Type **User_Block_Ptr = Global_User_Block; +static char *Current_Function_Name = NULL; + +static int execute_slang_fun (_SLang_Function_Type *fun) +{ + register unsigned int i; + register SLang_Object_Type *frame, *lvf; + register unsigned int n_locals; + _SLBlock_Header_Type *header; + /* SLBlock_Type *val; */ + SLBlock_Type *exit_block_save; + SLBlock_Type **user_block_save; + SLBlock_Type *user_blocks[5]; + char *save_fname; + + exit_block_save = Exit_Block_Ptr; + user_block_save = User_Block_Ptr; + User_Block_Ptr = user_blocks; + *(user_blocks) = NULL; + *(user_blocks + 1) = NULL; + *(user_blocks + 2) = NULL; + *(user_blocks + 3) = NULL; + *(user_blocks + 4) = NULL; + + Exit_Block_Ptr = NULL; + + save_fname = Current_Function_Name; + Current_Function_Name = fun->name; + + _SL_increment_frame_pointer (); + + /* need loaded? */ + if (fun->nlocals == AUTOLOAD_NUM_LOCALS) + { + /* header = NULL; */ + if (-1 == SLang_load_file(fun->v.autoload_filename)) + goto the_return; + + if (fun->nlocals == AUTOLOAD_NUM_LOCALS) + { + SLang_verror (SL_UNDEFINED_NAME, "%s: Function did not autoload", + Current_Function_Name); + goto the_return; + } + } + + n_locals = fun->nlocals; + + /* let the error propagate through since it will do no harm + and allow us to restore stack. */ + + /* set new stack frame */ + lvf = frame = Local_Variable_Frame; + i = n_locals; + if ((lvf + i) > Local_Variable_Stack + SLANG_MAX_LOCAL_STACK) + { + SLang_verror(SL_STACK_OVERFLOW, "%s: Local Variable Stack Overflow", + Current_Function_Name); + goto the_return; + } + + /* Make sure we do not allow this header to get destroyed by something + * like: define crash () { eval ("define crash ();") } + */ + header = fun->v.header; + header->num_refs++; + + while (i--) + { + lvf++; + lvf->data_type = SLANG_UNDEFINED_TYPE; + } + Local_Variable_Frame = lvf; + + /* read values of function arguments */ + i = fun->nargs; + while (i > 0) + { + i--; + (void) SLang_pop (Local_Variable_Frame - i); + } + + if (SLang_Enter_Function != NULL) (*SLang_Enter_Function)(Current_Function_Name); + + if (_SLang_Trace) + { + int stack_depth; + + stack_depth = _SLstack_depth (); + + if ((Trace_Function != NULL) + && (0 == strcmp (Trace_Function, Current_Function_Name)) + && (Trace_Mode == 0)) + Trace_Mode = 1; + + if (Trace_Mode) + { + /* The local variable frame grows backwards */ + trace_dump (">>%s (%d args)\n", + Current_Function_Name, + Local_Variable_Frame, + (int) fun->nargs, + -1); + Trace_Mode++; + } + + inner_interp (header->body); + Lang_Break_Condition = Lang_Return = Lang_Break = 0; + if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr); + + if (Trace_Mode) + { + Trace_Mode--; + stack_depth = _SLstack_depth () - stack_depth; + + trace_dump ("<<%s (returning %d values)\n", + Current_Function_Name, + _SLStack_Pointer - stack_depth, + stack_depth, + 1); + + if (Trace_Mode == 1) + Trace_Mode = 0; + } + } + else + { + inner_interp (header->body); + Lang_Break_Condition = Lang_Return = Lang_Break = 0; + if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr); + } + + if (SLang_Exit_Function != NULL) (*SLang_Exit_Function)(Current_Function_Name); + + if (SLang_Error) + do_traceback(fun->name, n_locals, +#if _SLANG_HAS_DEBUG_CODE + fun->file +#else + NULL +#endif + ); + + /* free local variables.... */ + lvf = Local_Variable_Frame; + while (lvf > frame) + { +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != Class_Type [lvf->data_type]) +#endif + SLang_free_object (lvf); + lvf--; + } + Local_Variable_Frame = lvf; + + if (header->num_refs == 1) + free_function_header (header); + else + header->num_refs--; + + the_return: + + Lang_Break_Condition = Lang_Return = Lang_Break = 0; + Exit_Block_Ptr = exit_block_save; + User_Block_Ptr = user_block_save; + Current_Function_Name = save_fname; + _SL_decrement_frame_pointer (); + + if (SLang_Error) + return -1; + + return 0; +} + +static void do_traceback (char *name, unsigned int locals, char *file) +{ + char *s; + unsigned int i; + SLang_Object_Type *objp; + unsigned short stype; + + /* FIXME: Priority=low + * I need to make this configurable!!! That is, let the + * application decide whether or not a usage error should result in a + * traceback. + */ + if (SLang_Error == SL_USAGE_ERROR) + return; + + if (SLang_Traceback == 0) + return; + + call_dump_routine ("S-Lang Traceback: %s\n", name); + if (SLang_Traceback < 0) + return; + + if (file != NULL) + call_dump_routine ("File: %s\n", file); + + if (locals == 0) + return; + + call_dump_routine (" Local Variables:\n"); + + for (i = 0; i < locals; i++) + { + SLang_Class_Type *cl; + char *class_name; + + objp = Local_Variable_Frame - i; + stype = objp->data_type; + + s = _SLstringize_object (objp); + cl = _SLclass_get_class (stype); + class_name = cl->cl_name; + + call_dump_routine ("\t$%d: Type: %s,\tValue:\t", i, class_name); + + if (s == NULL) call_dump_routine("??\n"); + else + { + char *q = ""; +#ifndef HAVE_VSNPRINTF + char buf[256]; + if (strlen (s) >= sizeof (buf)) + { + strncpy (buf, s, sizeof(buf)); + s = buf; + s[sizeof(buf) - 1] = 0; + } +#endif + if (SLANG_STRING_TYPE == stype) q = "\""; + call_dump_routine ("%s%s%s\n", q, s, q); + } + } +} + +static void do_app_unary (SLang_App_Unary_Type *nt) +{ + if (-1 == do_unary (nt->unary_op, nt->name_type)) + do_traceback (nt->name, 0, NULL); +} + +static int inner_interp_nametype (SLang_Name_Type *nt) +{ + SLBlock_Type bc_blks[2]; + + bc_blks[0].b.nt_blk = nt; + bc_blks[0].bc_main_type = nt->name_type; + bc_blks[1].bc_main_type = 0; + return inner_interp(bc_blks); +} + +int _SLang_dereference_ref (SLang_Ref_Type *ref) +{ + if (ref == NULL) + { + SLang_Error = SL_INTERNAL_ERROR; + return -1; + } + + if (ref->is_global == 0) + { + SLang_Object_Type *obj = ref->v.local_obj; + if (obj > Local_Variable_Frame) + { + SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope"); + return -1; + } + return _SLpush_slang_obj (ref->v.local_obj); + } + + (void) inner_interp_nametype (ref->v.nt); + return 0; +} + +int _SLang_is_ref_initialized (SLang_Ref_Type *ref) +{ + unsigned char type; + + if (ref == NULL) + { + SLang_Error = SL_INTERNAL_ERROR; + return -1; + } + + if (ref->is_global == 0) + { + SLang_Object_Type *obj = ref->v.local_obj; + if (obj > Local_Variable_Frame) + { + SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope"); + return -1; + } + type = ref->v.local_obj->data_type; + } + else + { + SLang_Name_Type *nt = ref->v.nt; + if ((nt->name_type != SLANG_GVARIABLE) + && (nt->name_type != SLANG_PVARIABLE)) + return 1; + type = ((SLang_Global_Var_Type *)nt)->obj.data_type; + } + return type != SLANG_UNDEFINED_TYPE; +} + +int _SLang_uninitialize_ref (SLang_Ref_Type *ref) +{ + SLang_Object_Type *obj; + + if (ref == NULL) + { + SLang_Error = SL_INTERNAL_ERROR; + return -1; + } + + if (ref->is_global == 0) + { + obj = ref->v.local_obj; + if (obj > Local_Variable_Frame) + { + SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope"); + return -1; + } + obj = ref->v.local_obj; + } + else + { + SLang_Name_Type *nt = ref->v.nt; + if ((nt->name_type != SLANG_GVARIABLE) + && (nt->name_type != SLANG_PVARIABLE)) + return -1; + obj = &((SLang_Global_Var_Type *)nt)->obj; + } + SLang_free_object (obj); + obj->data_type = SLANG_UNDEFINED_TYPE; + obj->v.ptr_val = NULL; + return 0; +} + +void (*SLang_Interrupt)(void); +static int Last_Error; +void (*SLang_User_Clear_Error)(void); +void _SLang_clear_error (void) +{ + if (Last_Error <= 0) + { + Last_Error = 0; + return; + } + Last_Error--; + if (SLang_User_Clear_Error != NULL) (*SLang_User_Clear_Error)(); +} + +int _SLpush_slang_obj (SLang_Object_Type *obj) +{ + unsigned char subtype; + SLang_Class_Type *cl; + + if (obj == NULL) return SLang_push_null (); + + subtype = obj->data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == Class_Type[subtype]) + return SLang_push (obj); +#endif + + cl = _SLclass_get_class (subtype); + return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v); +} + +_INLINE_ +static int push_local_variable (int i) +{ + SLang_Class_Type *cl; + SLang_Object_Type *obj; + unsigned char subtype; + + obj = Local_Variable_Frame - i; + subtype = obj->data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == Class_Type[subtype]) + return SLang_push (obj); + if (subtype == SLANG_STRING_TYPE) + return _SLang_dup_and_push_slstring (obj->v.s_val); +#endif + + cl = _SLclass_get_class (subtype); + return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v); +} + +static int push_intrinsic_variable (SLang_Intrin_Var_Type *ivar) +{ + SLang_Class_Type *cl; + unsigned char stype; + + stype = ivar->type; + cl = _SLclass_get_class (stype); + + if (-1 == (*cl->cl_push_intrinsic) (stype, ivar->addr)) + { + do_name_type_error ((SLang_Name_Type *) ivar); + return -1; + } + return 0; +} + +static int dereference_object (void) +{ + SLang_Object_Type obj; + SLang_Class_Type *cl; + unsigned char type; + int ret; + + if (-1 == SLang_pop (&obj)) + return -1; + + type = obj.data_type; + + cl = _SLclass_get_class (type); + ret = (*cl->cl_dereference)(type, (VOID_STAR) &obj.v); + + SLang_free_object (&obj); + return ret; +} + +static int case_function (void) +{ + unsigned char type; + SLang_Object_Type obj; + SLang_Object_Type *swobjptr; + + swobjptr = Switch_Obj_Ptr - 1; + + if ((swobjptr < Switch_Objects) + || (0 == (type = swobjptr->data_type))) + { + SLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case' keyword"); + return -1; + } + + if (-1 == SLang_pop (&obj)) + return -1; + + if (obj.data_type != type) + { + SLang_Class_Type *a_cl, *b_cl; + + a_cl = _SLclass_get_class (obj.data_type); + b_cl = _SLclass_get_class (type); + + if (NULL == _SLclass_get_binary_fun (SLANG_EQ, a_cl, b_cl, &a_cl, 0)) + { + (void) SLclass_push_int_obj (SLANG_INT_TYPE, 0); + SLang_free_object (&obj); + return 0; + } + } + + (void) do_binary_ab (SLANG_EQ, swobjptr, &obj); + SLang_free_object (&obj); + return 0; +} + +static void tmp_variable_function (SLBlock_Type *addr) +{ + SLang_Object_Type *obj; + + switch (addr->bc_sub_type) + { + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + obj = &addr->b.nt_gvar_blk->obj; + break; + + case SLANG_LVARIABLE: + obj = Local_Variable_Frame - addr->b.i_blk; + break; + + default: + SLang_Error = SL_INTERNAL_ERROR; + return; + } + + /* There is no need to go through higher level routines since we are + * not creating or destroying extra copies. + */ + if (-1 == SLang_push (obj)) + return; + + obj->data_type = SLANG_UNDEFINED_TYPE; + obj->v.ptr_val = NULL; +} + + +static int +do_inner_interp_error (SLBlock_Type *err_block, + SLBlock_Type *addr_start, + SLBlock_Type *addr) +{ + int save_err, slerr; + + /* Someday I can use the these variable to provide extra information + * about what went wrong. + */ + (void) addr_start; + (void) addr; + + if (err_block == NULL) + goto return_error; + + if (SLang_Error < 0) /* errors less than 0 are severe */ + goto return_error; + + save_err = Last_Error++; + slerr = SLang_Error; + SLang_Error = 0; + inner_interp (err_block->b.blk); + + if (Last_Error <= save_err) + { + /* Caught error and cleared it */ + Last_Error = save_err; + if ((Lang_Break_Condition == 0) + /* An error may have cleared the error and then caused the + * function to return. We will allow that but let's not allow + * 'break' nor 'continue' statements until later. + */ + || Lang_Return) + return 0; + + /* drop--- either a break or continue was called */ + } + + Last_Error = save_err; + SLang_Error = slerr; + + return_error: +#if _SLANG_HAS_DEBUG_CODE + while (addr >= addr_start) + { + if (addr->bc_main_type == _SLANG_BC_LINE_NUM) + { + char buf[256]; + sprintf (buf, "(Error occurred on line %lu)", addr->b.l_blk); + do_traceback (buf, 0, NULL); + break; + } + /* Special hack for 16 bit systems to prevent pointer wrapping. */ +#if defined(__16_BIT_SYSTEM__) + if (addr == addr_start) + break; +#endif + addr--; + } +#endif + return -1; +} + + +#define GATHER_STATISTICS 0 +#if GATHER_STATISTICS +static unsigned int Bytecodes[0xFFFF]; + +static void print_stats (void) +{ + unsigned int i; + unsigned long total; + FILE *fp = fopen ("stats.txt", "w"); + if (fp == NULL) + return; + + total = 0; + for (i = 0; i < 0xFFFF; i++) + total += Bytecodes[i]; + + if (total == 0) + total = 1; + + for (i = 0; i < 0xFFFF; i++) + { + if (Bytecodes[i]) + fprintf (fp, "0x%04X %9u %e\n", i, Bytecodes[i], Bytecodes[i]/(double) total); + } + fclose (fp); +} + +static void add_to_statistics (SLBlock_Type *b) +{ + unsigned short x, y; + + x = b->bc_main_type; + if (x == 0) + { + Bytecodes[0] += 1; + return; + } + b++; + y = b->bc_main_type; + + Bytecodes[(x << 8) | y] += 1; +} + +#endif + +/* inner interpreter */ +/* The return value from this function is only meaningful when it is used + * to process blocks for the switch statement. If it returns 0, the calling + * routine should pass the next block to it. Otherwise it will + * return non-zero, with or without error. + */ +static int inner_interp (SLBlock_Type *addr_start) +{ + SLBlock_Type *block, *err_block, *addr; +#if GATHER_STATISTICS + static int inited = 0; + + if (inited == 0) + { + (void) SLang_add_cleanup_function (print_stats); + inited = 1; + } +#endif + + /* for systems that have no real interrupt facility (e.g. go32 on dos) */ + if (SLang_Interrupt != NULL) (*SLang_Interrupt)(); + + block = err_block = NULL; + addr = addr_start; + +#if GATHER_STATISTICS + add_to_statistics (addr); +#endif + while (1) + { + switch (addr->bc_main_type) + { + case 0: + return 1; + case _SLANG_BC_LVARIABLE: + push_local_variable (addr->b.i_blk); + break; + case _SLANG_BC_GVARIABLE: + if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj)) + do_name_type_error (addr->b.nt_blk); + break; + + case _SLANG_BC_IVARIABLE: + case _SLANG_BC_RVARIABLE: + push_intrinsic_variable (addr->b.nt_ivar_blk); + break; + + case _SLANG_BC_INTRINSIC: + execute_intrinsic_fun (addr->b.nt_ifun_blk); + if (SLang_Error) + do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); + break; + + case _SLANG_BC_FUNCTION: + execute_slang_fun (addr->b.nt_fun_blk); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_MATH_UNARY: + case _SLANG_BC_APP_UNARY: + /* Make sure we treat these like function calls since the + * parser took sin(x) to be a function call. + */ + if (0 == _SL_increment_frame_pointer ()) + { + do_app_unary (addr->b.nt_unary_blk); + (void) _SL_decrement_frame_pointer (); + } + break; + + case _SLANG_BC_ICONST: + SLclass_push_int_obj (SLANG_INT_TYPE, addr->b.iconst_blk->i); + break; + +#if SLANG_HAS_FLOAT + case _SLANG_BC_DCONST: + SLclass_push_double_obj (SLANG_DOUBLE_TYPE, addr->b.dconst_blk->d); + break; +#endif + + case _SLANG_BC_PVARIABLE: + if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj)) + do_name_type_error (addr->b.nt_blk); + break; + + case _SLANG_BC_PFUNCTION: + execute_slang_fun (addr->b.nt_fun_blk); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_BINARY: + do_binary (addr->b.i_blk); + break; + + case _SLANG_BC_LITERAL: +#if !_SLANG_OPTIMIZE_FOR_SPEED + case _SLANG_BC_LITERAL_INT: + case _SLANG_BC_LITERAL_STR: + case _SLANG_BC_LITERAL_DBL: +#endif + { + SLang_Class_Type *cl = _SLclass_get_class (addr->bc_sub_type); + (*cl->cl_push_literal) (addr->bc_sub_type, (VOID_STAR) &addr->b.ptr_blk); + } + break; +#if _SLANG_OPTIMIZE_FOR_SPEED + case _SLANG_BC_LITERAL_INT: + SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk); + break; +#if SLANG_HAS_FLOAT + case _SLANG_BC_LITERAL_DBL: + SLclass_push_double_obj (addr->bc_sub_type, *addr->b.double_blk); + break; +#endif + case _SLANG_BC_LITERAL_STR: + _SLang_dup_and_push_slstring (addr->b.s_blk); + break; +#endif + case _SLANG_BC_BLOCK: + switch (addr->bc_sub_type) + { + case _SLANG_BCST_ERROR_BLOCK: + err_block = addr; + break; + + case _SLANG_BCST_EXIT_BLOCK: + Exit_Block_Ptr = addr->b.blk; + break; + + case _SLANG_BCST_USER_BLOCK0: + case _SLANG_BCST_USER_BLOCK1: + case _SLANG_BCST_USER_BLOCK2: + case _SLANG_BCST_USER_BLOCK3: + case _SLANG_BCST_USER_BLOCK4: + User_Block_Ptr[addr->bc_sub_type - _SLANG_BCST_USER_BLOCK0] = addr->b.blk; + break; + + case _SLANG_BCST_LOOP: + case _SLANG_BCST_WHILE: + case _SLANG_BCST_FOR: + case _SLANG_BCST_FOREVER: + case _SLANG_BCST_CFOR: + case _SLANG_BCST_DOWHILE: + case _SLANG_BCST_FOREACH: + if (block == NULL) block = addr; + lang_do_loops(addr->bc_sub_type, block, 1 + (unsigned int) (addr - block)); + block = NULL; + break; + + case _SLANG_BCST_IFNOT: +#if _SLANG_OPTIMIZE_FOR_SPEED + { + int i; + + if ((0 == pop_ctrl_integer (&i)) && (i == 0)) + inner_interp (addr->b.blk); + } +#else + do_else_if (addr, NULL); +#endif + break; + + case _SLANG_BCST_IF: +#if _SLANG_OPTIMIZE_FOR_SPEED + { + int i; + + if ((0 == pop_ctrl_integer (&i)) && i) + inner_interp (addr->b.blk); + } +#else + do_else_if (NULL, addr); +#endif + break; + + case _SLANG_BCST_NOTELSE: + do_else_if (block, addr); + block = NULL; + break; + + case _SLANG_BCST_ELSE: + do_else_if (addr, block); + block = NULL; + break; + + case _SLANG_BCST_SWITCH: + if (Switch_Obj_Ptr == Switch_Obj_Max) + { + SLang_doerror("switch nesting too deep"); + break; + } + (void) SLang_pop (Switch_Obj_Ptr); + Switch_Obj_Ptr++; + + if (block == NULL) block = addr; + while ((SLang_Error == 0) + && (block <= addr) + && (Lang_Break_Condition == 0) + && (0 == inner_interp (block->b.blk))) + block++; + Switch_Obj_Ptr--; + SLang_free_object (Switch_Obj_Ptr); + Switch_Obj_Ptr->data_type = 0; + block = NULL; + break; + + case _SLANG_BCST_ANDELSE: + case _SLANG_BCST_ORELSE: + if (block == NULL) block = addr; + lang_do_and_orelse (addr->bc_sub_type, block, addr); + block = NULL; + break; + + default: + if (block == NULL) block = addr; + break; + } + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_RETURN: + Lang_Break_Condition = Lang_Return = Lang_Break = 1; return 1; + case _SLANG_BC_BREAK: + Lang_Break_Condition = Lang_Break = 1; return 1; + case _SLANG_BC_CONTINUE: + Lang_Break_Condition = /* Lang_Continue = */ 1; return 1; + + case _SLANG_BC_EXCH: + (void) SLreverse_stack (2); + break; + + case _SLANG_BC_LABEL: + { + int test; + if ((0 == SLang_pop_integer (&test)) + && (test == 0)) + return 0; + } + break; + + case _SLANG_BC_LOBJPTR: + (void)_SLang_push_ref (0, (VOID_STAR)(Local_Variable_Frame - addr->b.i_blk)); + break; + + case _SLANG_BC_GOBJPTR: + (void)_SLang_push_ref (1, (VOID_STAR)addr->b.nt_blk); + break; + + case _SLANG_BC_X_ERROR: + if (err_block != NULL) + { + inner_interp(err_block->b.blk); + if (SLang_Error) err_block = NULL; + } + else SLang_verror(SL_SYNTAX_ERROR, "No ERROR_BLOCK"); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_X_USER0: + case _SLANG_BC_X_USER1: + case _SLANG_BC_X_USER2: + case _SLANG_BC_X_USER3: + case _SLANG_BC_X_USER4: + if (User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0] != NULL) + { + inner_interp(User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0]); + } + else SLang_verror(SL_SYNTAX_ERROR, "No block for X_USERBLOCK"); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_CALL_DIRECT: + (*addr->b.call_function) (); + break; + + case _SLANG_BC_CALL_DIRECT_FRAME: + do_bc_call_direct_frame (addr->b.call_function); + break; + + case _SLANG_BC_UNARY: + do_unary (addr->b.i_blk, _SLANG_BC_UNARY); + break; + + case _SLANG_BC_UNARY_FUNC: + /* Make sure we treat these like function calls since the + * parser took abs(x) to be a function call. + */ + if (0 == _SL_increment_frame_pointer ()) + { + do_unary (addr->b.i_blk, _SLANG_BC_UNARY); + (void) _SL_decrement_frame_pointer (); + } + break; + + case _SLANG_BC_DEREF_ASSIGN: + set_deref_lvalue (addr); + break; + case _SLANG_BC_SET_LOCAL_LVALUE: + set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk); + break; + case _SLANG_BC_SET_GLOBAL_LVALUE: + if (-1 == set_lvalue_obj (addr->bc_sub_type, &addr->b.nt_gvar_blk->obj)) + do_name_type_error (addr->b.nt_blk); + break; + case _SLANG_BC_SET_INTRIN_LVALUE: + set_intrin_lvalue (addr); + break; + case _SLANG_BC_SET_STRUCT_LVALUE: + set_struct_lvalue (addr); + break; + + case _SLANG_BC_FIELD: + (void) push_struct_field (addr->b.s_blk); + break; + + case _SLANG_BC_SET_ARRAY_LVALUE: + set_array_lvalue (addr->bc_sub_type); + break; + +#if _SLANG_HAS_DEBUG_CODE + case _SLANG_BC_LINE_NUM: + break; +#endif + + case _SLANG_BC_TMP: + tmp_variable_function (addr); + break; + +#if _SLANG_OPTIMIZE_FOR_SPEED + case _SLANG_BC_LVARIABLE_AGET: + if (0 == push_local_variable (addr->b.i_blk)) + do_bc_call_direct_frame (_SLarray_aget); + break; + + case _SLANG_BC_LVARIABLE_APUT: + if (0 == push_local_variable (addr->b.i_blk)) + do_bc_call_direct_frame (_SLarray_aput); + break; + case _SLANG_BC_INTEGER_PLUS: + if (0 == SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk)) + do_binary (SLANG_PLUS); + break; + + case _SLANG_BC_INTEGER_MINUS: + if (0 == SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk)) + do_binary (SLANG_MINUS); + break; +#endif +#if 0 + case _SLANG_BC_ARG_LVARIABLE: + (void) SLang_start_arg_list (); + push_local_variable (addr->b.i_blk); + break; +#endif + case _SLANG_BC_EARG_LVARIABLE: + push_local_variable (addr->b.i_blk); + (void) SLang_end_arg_list (); + break; + +#if USE_COMBINED_BYTECODES + case _SLANG_BC_CALL_DIRECT_INTRINSIC: + (*addr->b.call_function) (); + addr++; + execute_intrinsic_fun (addr->b.nt_ifun_blk); + if (SLang_Error) + do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); + break; + + case _SLANG_BC_INTRINSIC_CALL_DIRECT: + execute_intrinsic_fun (addr->b.nt_ifun_blk); + if (SLang_Error) + { + do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); + break; + } + addr++; + (*addr->b.call_function) (); + break; + + case _SLANG_BC_CALL_DIRECT_LSTR: + (*addr->b.call_function) (); + addr++; + _SLang_dup_and_push_slstring (addr->b.s_blk); + break; + + case _SLANG_BC_CALL_DIRECT_SLFUN: + (*addr->b.call_function) (); + addr++; + execute_slang_fun (addr->b.nt_fun_blk); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_CALL_DIRECT_INTRSTOP: + (*addr->b.call_function) (); + addr++; + /* drop */ + case _SLANG_BC_INTRINSIC_STOP: + execute_intrinsic_fun (addr->b.nt_ifun_blk); + if (SLang_Error == 0) + return 1; + do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); + break; + + case _SLANG_BC_CALL_DIRECT_EARG_LVAR: + (*addr->b.call_function) (); + addr++; + push_local_variable (addr->b.i_blk); + (void) SLang_end_arg_list (); + break; + + case _SLANG_BC_CALL_DIRECT_LINT: + (*addr->b.call_function) (); + addr++; + SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk); + break; + + case _SLANG_BC_CALL_DIRECT_LVAR: + (*addr->b.call_function) (); + addr++; + push_local_variable (addr->b.i_blk); + break; + + case _SLANG_BC_LLVARIABLE_BINARY: + do_binary_ab_inc_ref (addr->b.i_blk, + Local_Variable_Frame - (addr+1)->b.i_blk, + Local_Variable_Frame - (addr+2)->b.i_blk); + addr += 2; + break; + case _SLANG_BC_LGVARIABLE_BINARY: + do_binary_ab_inc_ref (addr->b.i_blk, + Local_Variable_Frame - (addr+1)->b.i_blk, + &(addr+2)->b.nt_gvar_blk->obj); + addr += 2; + break; + + case _SLANG_BC_GLVARIABLE_BINARY: + do_binary_ab_inc_ref (addr->b.i_blk, + &(addr+1)->b.nt_gvar_blk->obj, + Local_Variable_Frame - (addr+2)->b.i_blk); + addr += 2; + break; + case _SLANG_BC_GGVARIABLE_BINARY: + do_binary_ab_inc_ref (addr->b.i_blk, + &(addr+1)->b.nt_gvar_blk->obj, + &(addr+2)->b.nt_gvar_blk->obj); + addr += 2; + break; + + case _SLANG_BC_LIVARIABLE_BINARY: + { + SLang_Object_Type o; + o.data_type = SLANG_INT_TYPE; + o.v.int_val = (int) (addr+2)->b.l_blk; + + do_binary_ab_inc_ref (addr->b.i_blk, + Local_Variable_Frame - (addr+1)->b.i_blk, + &o); + } + addr += 2; + break; +#if SLANG_HAS_FLOAT + case _SLANG_BC_LDVARIABLE_BINARY: + { + SLang_Object_Type o; + o.data_type = SLANG_DOUBLE_TYPE; + o.v.double_val = *(addr+2)->b.double_blk; + + do_binary_ab_inc_ref (addr->b.i_blk, + Local_Variable_Frame - (addr+1)->b.i_blk, + &o); + } + addr += 2; + break; +#endif + case _SLANG_BC_ILVARIABLE_BINARY: + { + SLang_Object_Type o; + o.data_type = SLANG_INT_TYPE; + o.v.int_val = (int) (addr+1)->b.l_blk; + + do_binary_ab_inc_ref (addr->b.i_blk, + &o, + Local_Variable_Frame - (addr+2)->b.i_blk); + } + addr += 2; + break; +#if SLANG_HAS_FLOAT + case _SLANG_BC_DLVARIABLE_BINARY: + { + SLang_Object_Type o; + o.data_type = SLANG_DOUBLE_TYPE; + o.v.double_val = *(addr+1)->b.double_blk; + + do_binary_ab_inc_ref (addr->b.i_blk, + &o, + Local_Variable_Frame - (addr+2)->b.i_blk); + } + addr += 2; + break; +#endif + case _SLANG_BC_LVARIABLE_BINARY: + do_binary_b_inc_ref (addr->b.i_blk, + Local_Variable_Frame - (addr+1)->b.i_blk); + addr++; + break; + + case _SLANG_BC_GVARIABLE_BINARY: + do_binary_b_inc_ref (addr->b.i_blk, + &(addr+1)->b.nt_gvar_blk->obj); + addr++; + break; + + case _SLANG_BC_LITERAL_INT_BINARY: + { + SLang_Object_Type o; + o.data_type = SLANG_INT_TYPE; + o.v.int_val = (int) (addr+1)->b.l_blk; + do_binary_b (addr->b.i_blk, &o); + } + addr++; + break; +#if SLANG_HAS_FLOAT + case _SLANG_BC_LITERAL_DBL_BINARY: + { + SLang_Object_Type o; + o.data_type = SLANG_DOUBLE_TYPE; + o.v.double_val = *(addr+1)->b.double_blk; + do_binary_b (addr->b.i_blk, &o); + } + addr++; + break; +#endif +#endif /* USE_COMBINED_BYTECODES */ + default: + SLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type); + } + + /* Someday I plan to add a 'signal' intrinsic function. Then when a + * signal is caught, a variable will be set to one and that value of + * that variable will need to be monitored here, e.g., + * if (Handle_Signal) handle_signal (); + * It would be nice to check only one variable instead of Handle_Signal + * and SLang_Error. Perhaps I should phase out SLang_Error = xxx + * and used something like: SLang_set_error (code); Then, I could + * use: + * if (Handle_Condition) + * { + * Handle_Condition = 0; + * if (SLang_Error) .... + * else if (Handle_Signal) handle_signal (); + * else.... + * } + */ + if (SLang_Error) + { + if (-1 == do_inner_interp_error (err_block, addr_start, addr)) + return 1; + if (SLang_Error) + return 1; + + /* Otherwise, error cleared. Continue onto next bytecode. + * Someday I need to add something to indicate where the + * next statement begins since continuing on the next + * bytecode is not really what is desired. + */ + if (Lang_Break_Condition) goto handle_break_condition; + } + addr++; + } + + handle_break_condition: + /* Get here if Lang_Break_Condition != 0, which implies that either + * Lang_Return, Lang_Break, or Lang_Continue is non zero + */ + if (Lang_Return) + Lang_Break = 1; + + return 1; +} + +/*}}}*/ + +/* The functions below this point are used to implement the parsed token + * to byte-compiled code. + */ +/* static SLang_Name_Type **Static_Hash_Table; */ + +static SLang_Name_Type **Locals_Hash_Table; +static int Local_Variable_Number; +static unsigned int Function_Args_Number; +int _SLang_Auto_Declare_Globals = 0; +int (*SLang_Auto_Declare_Var_Hook) (char *); + +static SLang_NameSpace_Type *This_Static_NameSpace; +static SLang_NameSpace_Type *Global_NameSpace; + +#if _SLANG_HAS_DEBUG_CODE +static char *This_Compile_Filename; +#endif + +static int Lang_Defining_Function; +static void (*Default_Variable_Mode) (_SLang_Token_Type *); +static void (*Default_Define_Function) (char *, unsigned long); +static int setup_default_compile_linkage (int); + +static int push_compile_context (char *); +static int pop_compile_context (void); + +typedef struct +{ + int block_type; + SLBlock_Type *block; /* beginning of block definition */ + SLBlock_Type *block_ptr; /* current location */ + SLBlock_Type *block_max; /* end of definition */ + SLang_NameSpace_Type *static_namespace; +} +Block_Context_Type; + +static Block_Context_Type Block_Context_Stack [SLANG_MAX_BLOCK_STACK_LEN]; +static unsigned int Block_Context_Stack_Len; + +static SLBlock_Type *Compile_ByteCode_Ptr; +static SLBlock_Type *This_Compile_Block; +static SLBlock_Type *This_Compile_Block_Max; +static int This_Compile_Block_Type; +#define COMPILE_BLOCK_TYPE_FUNCTION 1 +#define COMPILE_BLOCK_TYPE_BLOCK 2 +#define COMPILE_BLOCK_TYPE_TOP_LEVEL 3 + +/* If it returns 0, DO NOT FREE p */ +static int lang_free_branch (SLBlock_Type *p) +{ + /* Note: we look at 0,2,4, since these blocks are 0 terminated */ + if ((p == SLShort_Blocks) + || (p == SLShort_Blocks + 2) + || (p == SLShort_Blocks + 4) + ) + return 0; + + while (1) + { + SLang_Class_Type *cl; + + switch (p->bc_main_type) + { + case _SLANG_BC_BLOCK: + if (lang_free_branch(p->b.blk)) + SLfree((char *)p->b.blk); + break; + + case _SLANG_BC_LITERAL: + case _SLANG_BC_LITERAL_STR: + case _SLANG_BC_LITERAL_DBL: + case _SLANG_BC_LITERAL_COMBINED: + /* No user types should be here. */ + cl = _SLclass_get_class (p->bc_sub_type); + (*cl->cl_byte_code_destroy) (p->bc_sub_type, (VOID_STAR) &p->b.ptr_blk); + break; + + case _SLANG_BC_FIELD: + case _SLANG_BC_SET_STRUCT_LVALUE: + SLang_free_slstring (p->b.s_blk); + break; + + default: + break; + + case 0: + return 1; + } + p++; + } +} + +static void free_function_header (_SLBlock_Header_Type *h) +{ + if (h->num_refs > 1) + { + h->num_refs--; + return; + } + + if (h->body != NULL) + { + if (lang_free_branch (h->body)) + SLfree ((char *) h->body); + } + + SLfree ((char *) h); +} + +static int push_block_context (int type) +{ + Block_Context_Type *c; + unsigned int num; + SLBlock_Type *b; + + if (Block_Context_Stack_Len == SLANG_MAX_BLOCK_STACK_LEN) + { + SLang_verror (SL_STACK_OVERFLOW, "Block stack overflow"); + return -1; + } + + num = 5; /* 40 bytes */ + if (NULL == (b = (SLBlock_Type *) SLcalloc (num, sizeof (SLBlock_Type)))) + return -1; + + c = Block_Context_Stack + Block_Context_Stack_Len; + c->block = This_Compile_Block; + c->block_ptr = Compile_ByteCode_Ptr; + c->block_max = This_Compile_Block_Max; + c->block_type = This_Compile_Block_Type; + c->static_namespace = This_Static_NameSpace; + + Compile_ByteCode_Ptr = This_Compile_Block = b; + This_Compile_Block_Max = b + num; + This_Compile_Block_Type = type; + + Block_Context_Stack_Len += 1; + return 0; +} + +static int pop_block_context (void) +{ + Block_Context_Type *c; + + if (Block_Context_Stack_Len == 0) + return -1; + + Block_Context_Stack_Len -= 1; + c = Block_Context_Stack + Block_Context_Stack_Len; + + This_Compile_Block = c->block; + This_Compile_Block_Max = c->block_max; + This_Compile_Block_Type = c->block_type; + Compile_ByteCode_Ptr = c->block_ptr; + This_Static_NameSpace = c->static_namespace; + + return 0; +} + +static int implements_ns (char *name) +{ + SLang_NameSpace_Type *ns; + + ns = This_Static_NameSpace; + if (ns == NULL) + { + /* This error should never happen */ + SLang_verror (SL_INTRINSIC_ERROR, "No namespace available"); + return -1; + } + + if (ns->namespace_name != NULL) + { + /* create a new namespace and use it */ + ns = _SLns_allocate_namespace (NULL, SLSTATIC_HASH_TABLE_SIZE); + if (ns == NULL) + return -1; + } + + if (-1 == _SLns_set_namespace_name (ns, name)) + return -1; + + This_Static_NameSpace = ns; + (void) setup_default_compile_linkage (0); + return 0; +} + +int _SLcompile_push_context (SLang_Load_Type *load_object) +{ + char *ns_name; + SLang_NameSpace_Type *ns; + + if (-1 == push_compile_context (load_object->name)) + return -1; + + ns_name = load_object->namespace_name; + + if ((ns_name != NULL) + && (NULL != (ns = _SLns_find_namespace (ns_name)))) + { + This_Static_NameSpace = ns; + setup_default_compile_linkage (ns == Global_NameSpace); + } + else + { + ns = _SLns_allocate_namespace (load_object->name, SLSTATIC_HASH_TABLE_SIZE); + if (ns == NULL) + { + pop_compile_context (); + return -1; + } + + This_Static_NameSpace = ns; + if ((ns_name != NULL) + && (-1 == implements_ns (ns_name))) + { + pop_compile_context (); + return -1; + } + } + + if (-1 == push_block_context (COMPILE_BLOCK_TYPE_TOP_LEVEL)) + { + pop_compile_context (); + return -1; + } + + return 0; +} + +int _SLcompile_pop_context (void) +{ + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + Compile_ByteCode_Ptr->bc_main_type = 0; + if (lang_free_branch (This_Compile_Block)) + SLfree ((char *) This_Compile_Block); + } + + (void) pop_block_context (); + (void) pop_compile_context (); + + if (This_Compile_Block == NULL) + return 0; + +#if 0 + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_INTERNAL_ERROR, "Not at top-level"); + return -1; + } +#endif + + return 0; +} + +/*{{{ Hash and Name Table Functions */ + +static SLang_Name_Type *locate_name_in_table (char *name, unsigned long hash, + SLang_Name_Type **table, unsigned int table_size) +{ + SLang_Name_Type *t; + char ch; + + t = table [(unsigned int) (hash % table_size)]; + ch = *name++; + + while (t != NULL) + { + if ((ch == t->name[0]) + && (0 == strcmp (t->name + 1, name))) + break; + + t = t->next; + } + + return t; +} + +static SLang_Name_Type *locate_namespace_encoded_name (char *name, int err_on_bad_ns) +{ + char *ns, *ns1; + SLang_NameSpace_Type *table; + SLang_Name_Type *nt; + + ns = name; + name = strchr (name, '-'); + if ((name == NULL) || (name [1] != '>')) + name = ns; + + ns1 = SLang_create_nslstring (ns, (unsigned int) (name - ns)); + if (ns1 == NULL) + return NULL; + if (ns != name) + name += 2; + ns = ns1; + + if (*ns == 0) + { + /* Use Global Namespace */ + SLang_free_slstring (ns); + return locate_name_in_table (name, _SLcompute_string_hash (name), + Global_NameSpace->table, Global_NameSpace->table_size); + } + + if (NULL == (table = _SLns_find_namespace (ns))) + { + if (err_on_bad_ns) + SLang_verror (SL_SYNTAX_ERROR, "Unable to find namespace called %s", ns); + SLang_free_slstring (ns); + return NULL; + } + SLang_free_slstring (ns); + + /* FIXME: the hash table size should be stored in the hash table itself */ + nt = locate_name_in_table (name, _SLcompute_string_hash (name), + table->table, table->table_size); + if (nt == NULL) + return NULL; + + switch (nt->name_type) + { + /* These are private and cannot be accessed through the namespace. */ + case SLANG_PVARIABLE: + case SLANG_PFUNCTION: + return NULL; + } + return nt; +} + +static SLang_Name_Type *locate_hashed_name (char *name, unsigned long hash) +{ + SLang_Name_Type *t; + + if (Lang_Defining_Function) + { + t = locate_name_in_table (name, hash, Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE); + if (t != NULL) + return t; + } + + if ((This_Static_NameSpace != NULL) + && (NULL != (t = locate_name_in_table (name, hash, This_Static_NameSpace->table, This_Static_NameSpace->table_size)))) + return t; + + t = locate_name_in_table (name, hash, Global_NameSpace->table, Global_NameSpace->table_size); + if (NULL != t) + return t; + + return locate_namespace_encoded_name (name, 1); +} + +SLang_Name_Type *_SLlocate_name (char *name) +{ + return locate_hashed_name (name, _SLcompute_string_hash (name)); +} + +static SLang_Name_Type * +add_name_to_hash_table (char *name, unsigned long hash, + unsigned int sizeof_obj, unsigned char name_type, + SLang_Name_Type **table, unsigned int table_size, + int check_existing) +{ + SLang_Name_Type *t; + + if (check_existing) + { + t = locate_name_in_table (name, hash, table, table_size); + if (t != NULL) + return t; + } + + if (-1 == _SLcheck_identifier_syntax (name)) + return NULL; + + t = (SLang_Name_Type *) SLmalloc (sizeof_obj); + if (t == NULL) + return t; + + memset ((char *) t, 0, sizeof_obj); + if (NULL == (t->name = _SLstring_dup_hashed_string (name, hash))) + { + SLfree ((char *) t); + return NULL; + } + t->name_type = name_type; + + hash = hash % table_size; + t->next = table [(unsigned int)hash]; + table [(unsigned int) hash] = t; + + return t; +} + +static SLang_Name_Type * +add_global_name (char *name, unsigned long hash, + unsigned char name_type, unsigned int sizeof_obj, + SLang_NameSpace_Type *ns) +{ + SLang_Name_Type *nt; + SLang_Name_Type **table; + unsigned int table_size; + + table = ns->table; + table_size = ns->table_size; + + nt = locate_name_in_table (name, hash, table, table_size); + if (nt != NULL) + { + if (nt->name_type == name_type) + return nt; + + SLang_verror (SL_DUPLICATE_DEFINITION, "%s cannot be re-defined", name); + return NULL; + } + + return add_name_to_hash_table (name, hash, sizeof_obj, name_type, + table, table_size, 0); +} + +static int add_intrinsic_function (SLang_NameSpace_Type *ns, + char *name, FVOID_STAR addr, unsigned char ret_type, + unsigned int nargs, va_list ap) +{ + SLang_Intrin_Fun_Type *f; + unsigned int i; + + if (-1 == init_interpreter ()) + return -1; + + if (ns == NULL) ns = Global_NameSpace; + + if (nargs > SLANG_MAX_INTRIN_ARGS) + { + SLang_verror (SL_APPLICATION_ERROR, "Function %s requires too many arguments", name); + return -1; + } + + if (ret_type == SLANG_FLOAT_TYPE) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Function %s is not permitted to return float", name); + return -1; + } + + f = (SLang_Intrin_Fun_Type *) add_global_name (name, _SLcompute_string_hash (name), + SLANG_INTRINSIC, sizeof (SLang_Intrin_Fun_Type), + ns); + + if (f == NULL) + return -1; + + f->i_fun = addr; + f->num_args = nargs; + f->return_type = ret_type; + + for (i = 0; i < nargs; i++) + f->arg_types [i] = va_arg (ap, unsigned int); + + return 0; +} + +int SLadd_intrinsic_function (char *name, FVOID_STAR addr, unsigned char ret_type, + unsigned int nargs, ...) +{ + va_list ap; + int status; + + va_start (ap, nargs); + status = add_intrinsic_function (NULL, name, addr, ret_type, nargs, ap); + va_end (ap); + + return status; +} + +int SLns_add_intrinsic_function (SLang_NameSpace_Type *ns, + char *name, FVOID_STAR addr, unsigned char ret_type, + unsigned int nargs, ...) +{ + va_list ap; + int status; + + va_start (ap, nargs); + status = add_intrinsic_function (ns, name, addr, ret_type, nargs, ap); + va_end (ap); + + return status; +} + +int SLns_add_intrinsic_variable (SLang_NameSpace_Type *ns, + char *name, VOID_STAR addr, unsigned char data_type, int ro) +{ + SLang_Intrin_Var_Type *v; + + if (-1 == init_interpreter ()) + return -1; + + if (ns == NULL) ns = Global_NameSpace; + + v = (SLang_Intrin_Var_Type *)add_global_name (name, + _SLcompute_string_hash (name), + (ro ? SLANG_RVARIABLE : SLANG_IVARIABLE), + sizeof (SLang_Intrin_Var_Type), + ns); + if (v == NULL) + return -1; + + v->addr = addr; + v->type = data_type; + return 0; +} + +int SLadd_intrinsic_variable (char *name, VOID_STAR addr, unsigned char data_type, int ro) +{ + return SLns_add_intrinsic_variable (NULL, name, addr, data_type, ro); +} + +static int +add_slang_function (char *name, unsigned char type, unsigned long hash, + unsigned int num_args, unsigned int num_locals, +#if _SLANG_HAS_DEBUG_CODE + char *file, +#endif + _SLBlock_Header_Type *h, + SLang_NameSpace_Type *ns) +{ + _SLang_Function_Type *f; + +#if _SLANG_HAS_DEBUG_CODE + if ((file != NULL) + && (NULL == (file = SLang_create_slstring (file)))) + return -1; +#endif + + f = (_SLang_Function_Type *)add_global_name (name, hash, + type, + sizeof (_SLang_Function_Type), + ns); + if (f == NULL) + { +#if _SLANG_HAS_DEBUG_CODE + SLang_free_slstring (file); /* NULL ok */ +#endif + return -1; + } + + if (f->v.header != NULL) + { + if (f->nlocals == AUTOLOAD_NUM_LOCALS) + SLang_free_slstring ((char *)f->v.autoload_filename); /* autoloaded filename */ + else + free_function_header (f->v.header); + } + +#if _SLANG_HAS_DEBUG_CODE + if (f->file != NULL) SLang_free_slstring (f->file); + f->file = file; +#endif + f->v.header = h; + f->nlocals = num_locals; + f->nargs = num_args; + + return 0; +} + +int SLang_autoload (char *name, char *file) +{ + _SLang_Function_Type *f; + unsigned long hash; + + hash = _SLcompute_string_hash (name); + f = (_SLang_Function_Type *)locate_name_in_table (name, hash, Global_NameSpace->table, Global_NameSpace->table_size); + + if ((f != NULL) + && (f->name_type == SLANG_FUNCTION) + && (f->v.header != NULL) + && (f->nlocals != AUTOLOAD_NUM_LOCALS)) + { + /* already loaded */ + return 0; + } + + file = SLang_create_slstring (file); + if (-1 == add_slang_function (name, SLANG_FUNCTION, hash, 0, AUTOLOAD_NUM_LOCALS, +#if _SLANG_HAS_DEBUG_CODE + file, +#endif + (_SLBlock_Header_Type *) file, + Global_NameSpace)) + { + SLang_free_slstring (file); + return -1; + } + + return 0; +} + +SLang_Name_Type *_SLlocate_global_name (char *name) +{ + unsigned long hash; + + hash = _SLcompute_string_hash (name); + return locate_name_in_table (name, hash, Global_NameSpace->table, + Global_NameSpace->table_size); +} + +/*}}}*/ + +static void free_local_variable_table (void) +{ + unsigned int i; + SLang_Name_Type *t, *t1; + + for (i = 0; i < SLLOCALS_HASH_TABLE_SIZE; i++) + { + t = Locals_Hash_Table [i]; + while (t != NULL) + { + SLang_free_slstring (t->name); + t1 = t->next; + SLfree ((char *) t); + t = t1; + } + Locals_Hash_Table [i] = NULL; + } + Local_Variable_Number = 0; +} + +/* call inner interpreter or return for more */ +static void lang_try_now(void) +{ + Compile_ByteCode_Ptr++; + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + return; + + Compile_ByteCode_Ptr->bc_main_type = 0; /* so next command stops after this */ + + /* now do it */ + inner_interp (This_Compile_Block); + (void) lang_free_branch (This_Compile_Block); + Compile_ByteCode_Ptr = This_Compile_Block; +} + +SLang_Name_Type *SLang_get_fun_from_ref (SLang_Ref_Type *ref) +{ + if (ref->is_global) + { + SLang_Name_Type *nt = ref->v.nt; + + switch (nt->name_type) + { + case SLANG_PFUNCTION: + case SLANG_FUNCTION: + case SLANG_INTRINSIC: + case SLANG_MATH_UNARY: + case SLANG_APP_UNARY: + return nt; + } + SLang_verror (SL_TYPE_MISMATCH, + "Reference to a function expected. Found &%s", + nt->name); + } + + SLang_verror (SL_TYPE_MISMATCH, + "Reference to a function expected"); + return NULL; +} + +int SLexecute_function (SLang_Name_Type *nt) +{ + unsigned char type; + char *name; + + if (SLang_Error) + return -1; + + type = nt->name_type; + name = nt->name; + + switch (type) + { + case SLANG_PFUNCTION: + case SLANG_FUNCTION: + execute_slang_fun ((_SLang_Function_Type *) nt); + break; + + case SLANG_INTRINSIC: + execute_intrinsic_fun ((SLang_Intrin_Fun_Type *) nt); + break; + + case SLANG_MATH_UNARY: + case SLANG_APP_UNARY: + inner_interp_nametype (nt); + break; + + default: + SLang_verror (SL_TYPE_MISMATCH, "%s is not a function", name); + return -1; + } + + if (SLang_Error) + { + SLang_verror (SLang_Error, "Error while executing %s", name); + return -1; + } + + return 1; +} + +int SLang_execute_function (char *name) +{ + SLang_Name_Type *entry; + + if (NULL == (entry = SLang_get_function (name))) + return 0; + + return SLexecute_function (entry); +} + +/* return S-Lang function or NULL */ +SLang_Name_Type *SLang_get_function (char *name) +{ + SLang_Name_Type *entry; + + if (NULL == (entry = locate_namespace_encoded_name (name, 0))) + return NULL; + + if ((entry->name_type == SLANG_FUNCTION) + || (entry->name_type == SLANG_INTRINSIC)) + return entry; + + return NULL; +} + +static void lang_begin_function (void) +{ + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_SYNTAX_ERROR, "Function nesting is illegal"); + return; + } + Lang_Defining_Function = 1; + (void) push_block_context (COMPILE_BLOCK_TYPE_FUNCTION); +} + +#if USE_COMBINED_BYTECODES +static void rearrange_optimized_binary (SLBlock_Type *b, unsigned char t1, unsigned char t2, unsigned char t3) +{ + SLBlock_Type tmp; + + b->bc_main_type = t1; + (b-1)->bc_main_type = t3; + (b-2)->bc_main_type = t2; + + tmp = *b; + *b = *(b-1); + *(b-1) = *(b-2); + *(b-2) = tmp; +} + +static void rearrange_optimized_unary (SLBlock_Type *b, unsigned char t1, unsigned char t2) +{ + SLBlock_Type tmp; + + b->bc_main_type = t1; + (b-1)->bc_main_type = t2; + + tmp = *b; + *b = *(b-1); + *(b-1) = tmp; +} + +static void optimize_block (SLBlock_Type *b) +{ + SLBlock_Type *bstart, *b1, *b2; + SLtype b2_main_type; + + + bstart = b; + while (1) + { + switch (b->bc_main_type) + { + case 0: + return; + + default: + b++; + break; + + case _SLANG_BC_BINARY: + if (bstart + 2 > b) + { + b++; + break; + } + b2 = b-1; + b1 = b2-1; + b2_main_type = b2->bc_main_type; + + switch (b1->bc_main_type) + { + case SLANG_LVARIABLE: + if (b2_main_type == SLANG_LVARIABLE) + rearrange_optimized_binary (b, + _SLANG_BC_LLVARIABLE_BINARY, + _SLANG_BC_LVARIABLE_COMBINED, + _SLANG_BC_LVARIABLE_COMBINED); + else if (b2_main_type == SLANG_GVARIABLE) + rearrange_optimized_binary (b, + _SLANG_BC_LGVARIABLE_BINARY, + _SLANG_BC_LVARIABLE_COMBINED, + _SLANG_BC_GVARIABLE_COMBINED); + else if (b2_main_type == _SLANG_BC_LITERAL_INT) + rearrange_optimized_binary (b, + _SLANG_BC_LIVARIABLE_BINARY, + _SLANG_BC_LVARIABLE_COMBINED, + _SLANG_BC_LITERAL_COMBINED); + else if (b2_main_type == _SLANG_BC_LITERAL_DBL) + rearrange_optimized_binary (b, + _SLANG_BC_LDVARIABLE_BINARY, + _SLANG_BC_LVARIABLE_COMBINED, + _SLANG_BC_LITERAL_COMBINED); + break; + + case SLANG_GVARIABLE: + if (b2_main_type == SLANG_LVARIABLE) + rearrange_optimized_binary (b, + _SLANG_BC_GLVARIABLE_BINARY, + _SLANG_BC_GVARIABLE_COMBINED, + _SLANG_BC_LVARIABLE_COMBINED); + else if (b2_main_type == SLANG_GVARIABLE) + rearrange_optimized_binary (b, + _SLANG_BC_GGVARIABLE_BINARY, + _SLANG_BC_GVARIABLE_COMBINED, + _SLANG_BC_GVARIABLE_COMBINED); + break; + + case _SLANG_BC_LITERAL_INT: + if (b2_main_type == SLANG_LVARIABLE) + rearrange_optimized_binary (b, + _SLANG_BC_ILVARIABLE_BINARY, + _SLANG_BC_LITERAL_COMBINED, + _SLANG_BC_LVARIABLE_COMBINED); + break; + + case _SLANG_BC_LITERAL_DBL: + if (b2_main_type == SLANG_LVARIABLE) + rearrange_optimized_binary (b, + _SLANG_BC_DLVARIABLE_BINARY, + _SLANG_BC_LITERAL_COMBINED, + _SLANG_BC_LVARIABLE_COMBINED); + break; + + default: + if (b2_main_type == SLANG_LVARIABLE) + rearrange_optimized_unary (b, + _SLANG_BC_LVARIABLE_BINARY, + _SLANG_BC_LVARIABLE_COMBINED); + else if (b2_main_type == SLANG_GVARIABLE) + rearrange_optimized_unary (b, + _SLANG_BC_GVARIABLE_BINARY, + _SLANG_BC_GVARIABLE_COMBINED); + else if (b2_main_type == _SLANG_BC_LITERAL_INT) + rearrange_optimized_unary (b, + _SLANG_BC_LITERAL_INT_BINARY, + _SLANG_BC_LITERAL_COMBINED); + else if (b2_main_type == _SLANG_BC_LITERAL_DBL) + rearrange_optimized_unary (b, + _SLANG_BC_LITERAL_DBL_BINARY, + _SLANG_BC_LITERAL_COMBINED); + } + b++; + break; + + case _SLANG_BC_CALL_DIRECT: + b++; + switch (b->bc_main_type) + { + case 0: + return; + case _SLANG_BC_INTRINSIC: + if ((b+1)->bc_main_type == 0) + { + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_INTRSTOP; + return; + } + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_INTRINSIC; + b++; + break; + case _SLANG_BC_LITERAL_STR: + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LSTR; + b++; + break; + case _SLANG_BC_FUNCTION: + case _SLANG_BC_PFUNCTION: + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_SLFUN; + b++; + break; + case _SLANG_BC_EARG_LVARIABLE: + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_EARG_LVAR; + b++; + break; + case _SLANG_BC_LITERAL_INT: + b->bc_main_type = _SLANG_BC_LITERAL_COMBINED; + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LINT; + b++; + break; + case _SLANG_BC_LVARIABLE: + b->bc_main_type = _SLANG_BC_LVARIABLE_COMBINED; + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LVAR; + b++; + break; + } + break; + + case _SLANG_BC_INTRINSIC: + b++; + switch (b->bc_main_type) + { + case _SLANG_BC_CALL_DIRECT: + (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_CALL_DIRECT; + b++; + break; +#if 0 + case _SLANG_BC_BLOCK: + (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_BLOCK; + b++; + break; +#endif + + case 0: + (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_STOP; + return; + } + break; + } + } +} + +#endif + + +/* name will be NULL if the object is to simply terminate the function + * definition. See SLang_restart. + */ +static int lang_define_function (char *name, unsigned char type, unsigned long hash, + SLang_NameSpace_Type *ns) +{ + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_FUNCTION) + { + SLang_verror (SL_SYNTAX_ERROR, "Premature end of function"); + return -1; + } + + /* terminate function */ + Compile_ByteCode_Ptr->bc_main_type = 0; + + if (name != NULL) + { + _SLBlock_Header_Type *h; + + h = (_SLBlock_Header_Type *)SLmalloc (sizeof (_SLBlock_Header_Type)); + if (h != NULL) + { + h->num_refs = 1; + h->body = This_Compile_Block; + +#if USE_COMBINED_BYTECODES + optimize_block (h->body); +#endif + + if (-1 == add_slang_function (name, type, hash, + Function_Args_Number, + Local_Variable_Number, +#if _SLANG_HAS_DEBUG_CODE + This_Compile_Filename, +#endif + h, ns)) + SLfree ((char *) h); + } + /* Drop through for clean-up */ + } + + free_local_variable_table (); + + Function_Args_Number = 0; + Lang_Defining_Function = 0; + + if (SLang_Error) return -1; + /* SLang_restart will finish this if there is a slang error. */ + + pop_block_context (); + + /* A function is only defined at top-level */ + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_INTERNAL_ERROR, "Not at top-level"); + return -1; + } + Compile_ByteCode_Ptr = This_Compile_Block; + return 0; +} + +static void define_static_function (char *name, unsigned long hash) +{ + (void) lang_define_function (name, SLANG_FUNCTION, hash, This_Static_NameSpace); +} + +static void define_private_function (char *name, unsigned long hash) +{ + (void) lang_define_function (name, SLANG_PFUNCTION, hash, This_Static_NameSpace); +} + +static void define_public_function (char *name, unsigned long hash) +{ + (void) lang_define_function (name, SLANG_FUNCTION, hash, Global_NameSpace); +} + +static void lang_end_block (void) +{ + SLBlock_Type *node, *branch; + unsigned char mtype; + + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK) + { + SLang_verror (SL_SYNTAX_ERROR, "Not defining a block"); + return; + } + + /* terminate the block */ + Compile_ByteCode_Ptr->bc_main_type = 0; + branch = This_Compile_Block; + + /* Try to save some space by using the cached blocks. */ + if (Compile_ByteCode_Ptr == branch + 1) + { + mtype = branch->bc_main_type; + if (((mtype == _SLANG_BC_BREAK) + || (mtype == _SLANG_BC_CONTINUE) + || (mtype == _SLANG_BC_RETURN)) + && (SLang_Error == 0)) + { + SLfree ((char *)branch); + branch = SLShort_Blocks + 2 * (int) (mtype - _SLANG_BC_RETURN); + } + } + +#if USE_COMBINED_BYTECODES + optimize_block (branch); +#endif + + pop_block_context (); + node = Compile_ByteCode_Ptr++; + + node->bc_main_type = _SLANG_BC_BLOCK; + node->bc_sub_type = 0; + node->b.blk = branch; +} + +static int lang_begin_block (void) +{ + return push_block_context (COMPILE_BLOCK_TYPE_BLOCK); +} + +static int lang_check_space (void) +{ + unsigned int n; + SLBlock_Type *p; + + if (NULL == (p = This_Compile_Block)) + { + SLang_verror (SL_INTERNAL_ERROR, "Top-level block not present"); + return -1; + } + + /* Allow 1 extra for terminator */ + if (Compile_ByteCode_Ptr + 1 < This_Compile_Block_Max) + return 0; + + n = (unsigned int) (This_Compile_Block_Max - p); + + /* enlarge the space by 2 objects */ + n += 2; + + if (NULL == (p = (SLBlock_Type *) SLrealloc((char *)p, n * sizeof(SLBlock_Type)))) + return -1; + + This_Compile_Block_Max = p + n; + n = (unsigned int) (Compile_ByteCode_Ptr - This_Compile_Block); + This_Compile_Block = p; + Compile_ByteCode_Ptr = p + n; + + return 0; +} + +/* returns positive number if name is a function or negative number if it + is a variable. If it is intrinsic, it returns magnitude of 1, else 2 */ +int SLang_is_defined(char *name) +{ + SLang_Name_Type *t; + + if (-1 == init_interpreter ()) + return -1; + + t = locate_namespace_encoded_name (name, 0); + if (t == NULL) + return 0; + + switch (t->name_type) + { + case SLANG_FUNCTION: + /* case SLANG_PFUNCTION: */ + return 2; + case SLANG_GVARIABLE: + /* case SLANG_PVARIABLE: */ + return -2; + + case SLANG_ICONSTANT: + case SLANG_DCONSTANT: + case SLANG_RVARIABLE: + case SLANG_IVARIABLE: + return -1; + + case SLANG_INTRINSIC: + default: + return 1; + } +} + +static int add_global_variable (char *name, char name_type, unsigned long hash, + SLang_NameSpace_Type *ns) +{ + SLang_Name_Type *g; + + /* Note the importance of checking if it is already defined or not. For example, + * suppose X is defined as an intrinsic variable. Then S-Lang code like: + * !if (is_defined("X")) { variable X; } + * will not result in a global variable X. On the other hand, this would + * not be an issue if 'variable' statements always were not processed + * immediately. That is, as it is now, 'if (0) {variable ZZZZ;}' will result + * in the variable ZZZZ being defined because of the immediate processing. + * The current solution is to do: if (0) { eval("variable ZZZZ;"); } + */ + /* hash = _SLcompute_string_hash (name); */ + g = locate_name_in_table (name, hash, ns->table, ns->table_size); + + if (g != NULL) + { + if (g->name_type == name_type) + return 0; + } + + if (NULL == add_global_name (name, hash, name_type, + sizeof (SLang_Global_Var_Type), ns)) + return -1; + + return 0; +} + +int SLadd_global_variable (char *name) +{ + if (-1 == init_interpreter ()) + return -1; + + return add_global_variable (name, SLANG_GVARIABLE, + _SLcompute_string_hash (name), + Global_NameSpace); +} + +static int add_local_variable (char *name, unsigned long hash) +{ + SLang_Local_Var_Type *t; + + /* local variable */ + if (Local_Variable_Number >= SLANG_MAX_LOCAL_VARIABLES) + { + SLang_verror (SL_SYNTAX_ERROR, "Too many local variables"); + return -1; + } + + if (NULL != locate_name_in_table (name, hash, Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE)) + { + SLang_verror (SL_SYNTAX_ERROR, "Local variable %s has already been defined", name); + return -1; + } + + t = (SLang_Local_Var_Type *) + add_name_to_hash_table (name, hash, + sizeof (SLang_Local_Var_Type), SLANG_LVARIABLE, + Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE, 0); + if (t == NULL) + return -1; + + t->local_var_number = Local_Variable_Number; + Local_Variable_Number++; + return 0; +} + +static void (*Compile_Mode_Function) (_SLang_Token_Type *); +static void compile_basic_token_mode (_SLang_Token_Type *); + +/* if an error occurs, discard current object, block, function, etc... */ +void SLang_restart (int localv) +{ + int save = SLang_Error; + + SLang_Error = SL_UNKNOWN_ERROR; + + _SLcompile_ptr = _SLcompile; + Compile_Mode_Function = compile_basic_token_mode; + + Lang_Break = /* Lang_Continue = */ Lang_Return = 0; + Trace_Mode = 0; + + while (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK) + lang_end_block(); + + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_FUNCTION) + { + /* Terminate function definition and free variables */ + lang_define_function (NULL, SLANG_FUNCTION, 0, Global_NameSpace); + if (lang_free_branch (This_Compile_Block)) + SLfree((char *)This_Compile_Block); + } + Lang_Defining_Function = 0; + + SLang_Error = save; + + if (SLang_Error == SL_STACK_OVERFLOW) + { + /* This loop guarantees that the stack is properly cleaned. */ + while (_SLStack_Pointer != _SLRun_Stack) + { + SLdo_pop (); + } + } + + while ((This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + && (0 == pop_block_context ())) + ; + + if (localv) + { + Next_Function_Num_Args = SLang_Num_Function_Args = 0; + Local_Variable_Frame = Local_Variable_Stack; + Recursion_Depth = 0; + Frame_Pointer = _SLStack_Pointer; + Frame_Pointer_Depth = 0; + Switch_Obj_Ptr = Switch_Objects; + while (Switch_Obj_Ptr < Switch_Obj_Max) + { + SLang_free_object (Switch_Obj_Ptr); + Switch_Obj_Ptr++; + } + Switch_Obj_Ptr = Switch_Objects; + } +} + +static void compile_directive (unsigned char sub_type) +{ + /* This function is called only from compile_directive_mode which is + * only possible when a block is available. + */ + + /* use BLOCK */ + Compile_ByteCode_Ptr--; + Compile_ByteCode_Ptr->bc_sub_type = sub_type; + + lang_try_now (); +} + +static void compile_unary (int op, unsigned char mt) +{ + Compile_ByteCode_Ptr->bc_main_type = mt; + Compile_ByteCode_Ptr->b.i_blk = op; + Compile_ByteCode_Ptr->bc_sub_type = 0; + + lang_try_now (); +} + + +static void compile_binary (int op) +{ + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_BINARY; + Compile_ByteCode_Ptr->b.i_blk = op; + Compile_ByteCode_Ptr->bc_sub_type = 0; + + lang_try_now (); +} + +#if _SLANG_OPTIMIZE_FOR_SPEED +static int try_compressed_bytecode (unsigned char last_bc, unsigned char bc) +{ + if (Compile_ByteCode_Ptr != This_Compile_Block) + { + SLBlock_Type *b; + b = Compile_ByteCode_Ptr - 1; + if (b->bc_main_type == last_bc) + { + Compile_ByteCode_Ptr = b; + b->bc_main_type = bc; + lang_try_now (); + return 0; + } + } + return -1; +} +#endif + +static void compile_fast_binary (int op, unsigned char bc) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED +# if 0 + if (0 == try_compressed_bytecode (_SLANG_BC_LITERAL_INT, bc)) + return; +# endif +#else +#endif + (void) bc; + compile_binary (op); +} + +/* This is a hack */ +typedef struct _Special_NameTable_Type +{ + char *name; + int (*fun) (struct _Special_NameTable_Type *, _SLang_Token_Type *); + VOID_STAR blk_data; + unsigned char main_type; +} +Special_NameTable_Type; + +static int handle_special (Special_NameTable_Type *nt, _SLang_Token_Type *tok) +{ + (void) tok; + Compile_ByteCode_Ptr->bc_main_type = nt->main_type; + Compile_ByteCode_Ptr->b.ptr_blk = nt->blk_data; + return 0; +} + +static int handle_special_file (Special_NameTable_Type *nt, _SLang_Token_Type *tok) +{ + char *name; + + (void) nt; (void) tok; + + if (This_Static_NameSpace == NULL) name = "***Unknown***"; + else + name = This_Static_NameSpace->name; + + name = SLang_create_slstring (name); + if (name == NULL) + return -1; + + Compile_ByteCode_Ptr->b.s_blk = name; + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL_STR; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE; + return 0; +} + +static int handle_special_line (Special_NameTable_Type *nt, _SLang_Token_Type *tok) +{ + (void) nt; + +#if _SLANG_HAS_DEBUG_CODE + Compile_ByteCode_Ptr->b.l_blk = (long) tok->line_number; +#endif + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_UINT_TYPE; + + return 0; +} + +static Special_NameTable_Type Special_Name_Table [] = +{ + {"EXECUTE_ERROR_BLOCK", handle_special, NULL, _SLANG_BC_X_ERROR}, + {"X_USER_BLOCK0", handle_special, NULL, _SLANG_BC_X_USER0}, + {"X_USER_BLOCK1", handle_special, NULL, _SLANG_BC_X_USER1}, + {"X_USER_BLOCK2", handle_special, NULL, _SLANG_BC_X_USER2}, + {"X_USER_BLOCK3", handle_special, NULL, _SLANG_BC_X_USER3}, + {"X_USER_BLOCK4", handle_special, NULL, _SLANG_BC_X_USER4}, + {"__FILE__", handle_special_file, NULL, 0}, + {"__LINE__", handle_special_line, NULL, 0}, +#if 0 + {"__NAMESPACE__", handle_special_namespace, NULL, 0}, +#endif + {NULL, NULL, NULL, 0} +}; + +static void compile_hashed_identifier (char *name, unsigned long hash, _SLang_Token_Type *tok) +{ + SLang_Name_Type *entry; + unsigned char name_type; + + entry = locate_hashed_name (name, hash); + + if (entry == NULL) + { + Special_NameTable_Type *nt = Special_Name_Table; + + while (nt->name != NULL) + { + if (strcmp (name, nt->name)) + { + nt++; + continue; + } + + if (0 == (*nt->fun)(nt, tok)) + lang_try_now (); + return; + } + + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + + name_type = entry->name_type; + Compile_ByteCode_Ptr->bc_main_type = name_type; + + if (name_type == SLANG_LVARIABLE) /* == _SLANG_BC_LVARIABLE */ + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number; + else + Compile_ByteCode_Ptr->b.nt_blk = entry; + + lang_try_now (); +} + +static void compile_tmp_variable (char *name, unsigned long hash) +{ + SLang_Name_Type *entry; + unsigned char name_type; + + if (NULL == (entry = locate_hashed_name (name, hash))) + { + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + + name_type = entry->name_type; + switch (name_type) + { + case SLANG_LVARIABLE: + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number; + break; + + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + Compile_ByteCode_Ptr->b.nt_blk = entry; + break; + + default: + SLang_verror (SL_SYNTAX_ERROR, "__tmp(%s) does not specifiy a variable", name); + return; + } + + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_TMP; + Compile_ByteCode_Ptr->bc_sub_type = name_type; + + lang_try_now (); +} + +static void compile_simple (unsigned char main_type) +{ + Compile_ByteCode_Ptr->bc_main_type = main_type; + Compile_ByteCode_Ptr->bc_sub_type = 0; + Compile_ByteCode_Ptr->b.blk = NULL; + lang_try_now (); +} + +static void compile_identifier (char *name, _SLang_Token_Type *tok) +{ + compile_hashed_identifier (name, _SLcompute_string_hash (name), tok); +} + +static void compile_call_direct (int (*f) (void), unsigned char byte_code) +{ + Compile_ByteCode_Ptr->b.call_function = f; + Compile_ByteCode_Ptr->bc_main_type = byte_code; + Compile_ByteCode_Ptr->bc_sub_type = 0; + lang_try_now (); +} + +static void compile_lvar_call_direct (int (*f)(void), unsigned char bc, + unsigned char frame_op) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + if (0 == try_compressed_bytecode (_SLANG_BC_LVARIABLE, bc)) + return; +#else + (void) bc; +#endif + + compile_call_direct (f, frame_op); +} + +static void compile_integer (long i, unsigned char bc_main_type, unsigned char bc_sub_type) +{ + Compile_ByteCode_Ptr->b.l_blk = i; + Compile_ByteCode_Ptr->bc_main_type = bc_main_type; + Compile_ByteCode_Ptr->bc_sub_type = bc_sub_type; + + lang_try_now (); +} + +#if SLANG_HAS_FLOAT +static void compile_double (char *str, unsigned char main_type, SLtype type) +{ + double d; + unsigned int factor = 1; + double *ptr; + +#if 1 + d = _SLang_atof (str); +#else + if (1 != sscanf (str, "%lf", &d)) + { + SLang_verror (SL_SYNTAX_ERROR, "Unable to convert %s to double", str); + return; + } +#endif + +#if SLANG_HAS_COMPLEX + if (type == SLANG_COMPLEX_TYPE) factor = 2; +#endif + if (NULL == (ptr = (double *) SLmalloc(factor * sizeof(double)))) + return; + + Compile_ByteCode_Ptr->b.double_blk = ptr; +#if SLANG_HAS_COMPLEX + if (type == SLANG_COMPLEX_TYPE) + *ptr++ = 0; +#endif + *ptr = d; + + Compile_ByteCode_Ptr->bc_main_type = main_type; + Compile_ByteCode_Ptr->bc_sub_type = type; + lang_try_now (); +} + +static void compile_float (char *s) +{ + float x; + +#if 1 + x = (float) _SLang_atof (s); +#else + if (1 != sscanf (s, "%f", &x)) + { + SLang_verror (SL_SYNTAX_ERROR, "Unable to convert %s to float", s); + return; + } +#endif + Compile_ByteCode_Ptr->b.float_blk = x; + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_FLOAT_TYPE; + lang_try_now (); +} + +#endif + +static void compile_string (char *s, unsigned long hash) +{ + if (NULL == (Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string (s, hash))) + return; + + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL_STR; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE; + + lang_try_now (); +} + +static void compile_bstring (SLang_BString_Type *s) +{ + if (NULL == (Compile_ByteCode_Ptr->b.bs_blk = SLbstring_dup (s))) + return; + + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_BSTRING_TYPE; + + lang_try_now (); +} + +/* assign_type is one of _SLANG_BCST_ASSIGN, ... values */ +static void compile_assign (unsigned char assign_type, + char *name, unsigned long hash) +{ + SLang_Name_Type *v; + unsigned char main_type; + SLang_Class_Type *cl; + + v = locate_hashed_name (name, hash); + if (v == NULL) + { + if ((_SLang_Auto_Declare_Globals == 0) + || (NULL != strchr (name, '-')) /* namespace->name form */ + || Lang_Defining_Function + || (assign_type != _SLANG_BCST_ASSIGN) + || (This_Static_NameSpace == NULL)) + { + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + /* Note that function local variables are not at top level */ + + /* Variables that are automatically declared are given static + * scope. + */ + if ((NULL != SLang_Auto_Declare_Var_Hook) + && (-1 == (*SLang_Auto_Declare_Var_Hook) (name))) + return; + + if ((-1 == add_global_variable (name, SLANG_GVARIABLE, hash, This_Static_NameSpace)) + || (NULL == (v = locate_hashed_name (name, hash)))) + return; + } + + switch (v->name_type) + { + case SLANG_LVARIABLE: + main_type = _SLANG_BC_SET_LOCAL_LVALUE; + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number; + break; + + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + main_type = _SLANG_BC_SET_GLOBAL_LVALUE; + Compile_ByteCode_Ptr->b.nt_blk = v; + break; + + case SLANG_IVARIABLE: + cl = _SLclass_get_class (((SLang_Intrin_Var_Type *)v)->type); + if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR) + { + SLang_verror (SL_SYNTAX_ERROR, "Assignment to %s is not allowed", name); + return; + } + main_type = _SLANG_BC_SET_INTRIN_LVALUE; + Compile_ByteCode_Ptr->b.nt_blk = v; + break; + + case SLANG_RVARIABLE: + SLang_verror (SL_READONLY_ERROR, "%s is read-only", name); + return; + + default: + SLang_verror (SL_DUPLICATE_DEFINITION, "%s may not be used as an lvalue", name); + return; + } + + Compile_ByteCode_Ptr->bc_sub_type = assign_type; + Compile_ByteCode_Ptr->bc_main_type = main_type; + + lang_try_now (); +} + +static void compile_deref_assign (char *name, unsigned long hash) +{ + SLang_Name_Type *v; + + v = locate_hashed_name (name, hash); + + if (v == NULL) + { + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + + switch (v->name_type) + { + case SLANG_LVARIABLE: + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number; + break; + + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + Compile_ByteCode_Ptr->b.nt_blk = v; + break; + + default: + /* FIXME: Priority=low + * This could be made to work. It is not a priority because + * I cannot imagine application intrinsics which are references. + */ + SLang_verror (SL_NOT_IMPLEMENTED, "Deref assignment to %s is not allowed", name); + return; + } + + Compile_ByteCode_Ptr->bc_sub_type = v->name_type; + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_DEREF_ASSIGN; + + lang_try_now (); +} + +static void +compile_struct_assign (_SLang_Token_Type *t) +{ + Compile_ByteCode_Ptr->bc_sub_type = _SLANG_BCST_ASSIGN + (t->type - _STRUCT_ASSIGN_TOKEN); + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_SET_STRUCT_LVALUE; + Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string (t->v.s_val, t->hash); + lang_try_now (); +} + +static void +compile_array_assign (_SLang_Token_Type *t) +{ + Compile_ByteCode_Ptr->bc_sub_type = _SLANG_BCST_ASSIGN + (t->type - _ARRAY_ASSIGN_TOKEN); + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_SET_ARRAY_LVALUE; + Compile_ByteCode_Ptr->b.s_blk = NULL; + lang_try_now (); +} + +static void compile_dot(_SLang_Token_Type *t) +{ + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_FIELD; + Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string(t->v.s_val, t->hash); + lang_try_now (); +} + +static void compile_ref (char *name, unsigned long hash) +{ + SLang_Name_Type *entry; + unsigned char main_type; + + if (NULL == (entry = locate_hashed_name (name, hash))) + { + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + + main_type = entry->name_type; + + if (main_type == SLANG_LVARIABLE) + { + main_type = _SLANG_BC_LOBJPTR; + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *)entry)->local_var_number; + } + else + { + main_type = _SLANG_BC_GOBJPTR; + Compile_ByteCode_Ptr->b.nt_blk = entry; + } + + Compile_ByteCode_Ptr->bc_main_type = main_type; + lang_try_now (); +} + +static void compile_break (unsigned char break_type, + int requires_block, int requires_fun, + char *str) +{ + if ((requires_fun + && (Lang_Defining_Function == 0)) + || (requires_block + && (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK))) + { + SLang_verror (SL_SYNTAX_ERROR, "misplaced %s", str); + return; + } + + Compile_ByteCode_Ptr->bc_main_type = break_type; + Compile_ByteCode_Ptr->bc_sub_type = 0; + + lang_try_now (); +} + +static void compile_public_variable_mode (_SLang_Token_Type *t) +{ + if (t->type == IDENT_TOKEN) + { + /* If the variable is already defined in the static hash table, + * generate an error. + */ + if ((This_Static_NameSpace != NULL) + && (NULL != locate_name_in_table (t->v.s_val, t->hash, This_Static_NameSpace->table, This_Static_NameSpace->table_size))) + { + SLang_verror (SL_DUPLICATE_DEFINITION, + "%s already has static or private linkage in this unit", + t->v.s_val); + return; + } + add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, Global_NameSpace); + } + else if (t->type == CBRACKET_TOKEN) + Compile_Mode_Function = compile_basic_token_mode; + else + SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); +} + +static void compile_local_variable_mode (_SLang_Token_Type *t) +{ + if (t->type == IDENT_TOKEN) + add_local_variable (t->v.s_val, t->hash); + else if (t->type == CBRACKET_TOKEN) + Compile_Mode_Function = compile_basic_token_mode; + else + SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); +} + +static void compile_static_variable_mode (_SLang_Token_Type *t) +{ + if (t->type == IDENT_TOKEN) + add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, This_Static_NameSpace); + else if (t->type == CBRACKET_TOKEN) + Compile_Mode_Function = compile_basic_token_mode; + else + SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); +} + +static void compile_private_variable_mode (_SLang_Token_Type *t) +{ + if (t->type == IDENT_TOKEN) + add_global_variable (t->v.s_val, SLANG_PVARIABLE, t->hash, This_Static_NameSpace); + else if (t->type == CBRACKET_TOKEN) + Compile_Mode_Function = compile_basic_token_mode; + else + SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); +} + +static void compile_function_mode (_SLang_Token_Type *t) +{ + if (-1 == lang_check_space ()) + return; + + if (t->type != IDENT_TOKEN) + SLang_verror (SL_SYNTAX_ERROR, "Expecting function name"); + else + lang_define_function (t->v.s_val, SLANG_FUNCTION, t->hash, Global_NameSpace); + + Compile_Mode_Function = compile_basic_token_mode; +} + +/* An error block is not permitted to contain continue or break statements. + * This restriction may be removed later but for now reject them. + */ +static int check_error_block (void) +{ + SLBlock_Type *p; + unsigned char t; + + /* Back up to the block and then scan it. */ + p = (Compile_ByteCode_Ptr - 1)->b.blk; + + while (0 != (t = p->bc_main_type)) + { + if ((t == _SLANG_BC_BREAK) + || (t == _SLANG_BC_CONTINUE)) + { + SLang_verror (SL_SYNTAX_ERROR, + "An ERROR_BLOCK is not permitted to contain continue or break statements"); + return -1; + } + p++; + } + return 0; +} + +/* The only allowed tokens are the directives and another block start. + * The mode is only active if a block is available. The inner_interp routine + * expects such safety checks. + */ +static void compile_directive_mode (_SLang_Token_Type *t) +{ + int bc_sub_type; + + if (-1 == lang_check_space ()) + return; + + bc_sub_type = -1; + + switch (t->type) + { + case FOREVER_TOKEN: + bc_sub_type = _SLANG_BCST_FOREVER; + break; + + case IFNOT_TOKEN: + bc_sub_type = _SLANG_BCST_IFNOT; + break; + + case IF_TOKEN: + bc_sub_type = _SLANG_BCST_IF; + break; + + case ANDELSE_TOKEN: + bc_sub_type = _SLANG_BCST_ANDELSE; + break; + + case SWITCH_TOKEN: + bc_sub_type = _SLANG_BCST_SWITCH; + break; + + case EXITBLK_TOKEN: + if (Lang_Defining_Function == 0) + { + SLang_verror (SL_SYNTAX_ERROR, "misplaced EXIT_BLOCK"); + break; + } + bc_sub_type = _SLANG_BCST_EXIT_BLOCK; + break; + + case ERRBLK_TOKEN: + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_SYNTAX_ERROR, "misplaced ERROR_BLOCK"); + break; + } + if (0 == check_error_block ()) + bc_sub_type = _SLANG_BCST_ERROR_BLOCK; + break; + + case USRBLK0_TOKEN: + case USRBLK1_TOKEN: + case USRBLK2_TOKEN: + case USRBLK3_TOKEN: + case USRBLK4_TOKEN: + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_SYNTAX_ERROR, "misplaced USER_BLOCK"); + break; + } + bc_sub_type = _SLANG_BCST_USER_BLOCK0 + (t->type - USRBLK0_TOKEN); + break; + + case NOTELSE_TOKEN: + bc_sub_type = _SLANG_BCST_NOTELSE; + break; + + case ELSE_TOKEN: + bc_sub_type = _SLANG_BCST_ELSE; + break; + + case LOOP_TOKEN: + bc_sub_type = _SLANG_BCST_LOOP; + break; + + case DOWHILE_TOKEN: + bc_sub_type = _SLANG_BCST_DOWHILE; + break; + + case WHILE_TOKEN: + bc_sub_type = _SLANG_BCST_WHILE; + break; + + case ORELSE_TOKEN: + bc_sub_type = _SLANG_BCST_ORELSE; + break; + + case _FOR_TOKEN: + bc_sub_type = _SLANG_BCST_FOR; + break; + + case FOR_TOKEN: + bc_sub_type = _SLANG_BCST_CFOR; + break; + + case FOREACH_TOKEN: + bc_sub_type = _SLANG_BCST_FOREACH; + break; + + case OBRACE_TOKEN: + lang_begin_block (); + break; + + default: + SLang_verror (SL_SYNTAX_ERROR, "Expecting directive token. Found 0x%X", t->type); + break; + } + + /* Reset this pointer first because compile_directive may cause a + * file to be loaded. + */ + Compile_Mode_Function = compile_basic_token_mode; + + if (bc_sub_type != -1) + compile_directive (bc_sub_type); +} + +static unsigned int Assign_Mode_Type; +static void compile_assign_mode (_SLang_Token_Type *t) +{ + if (t->type != IDENT_TOKEN) + { + SLang_verror (SL_SYNTAX_ERROR, "Expecting identifier for assignment"); + return; + } + + compile_assign (Assign_Mode_Type, t->v.s_val, t->hash); + Compile_Mode_Function = compile_basic_token_mode; +} + +static void compile_basic_token_mode (_SLang_Token_Type *t) +{ + if (-1 == lang_check_space ()) + return; + + switch (t->type) + { + case PUSH_TOKEN: + case NOP_TOKEN: + case EOF_TOKEN: + case READONLY_TOKEN: + case DO_TOKEN: + case VARIABLE_TOKEN: + case SEMICOLON_TOKEN: + default: + SLang_verror (SL_SYNTAX_ERROR, "Unknown or unsupported token type 0x%X", t->type); + break; + + case DEREF_TOKEN: + compile_call_direct (dereference_object, _SLANG_BC_CALL_DIRECT); + break; + + case STRUCT_TOKEN: + compile_call_direct (_SLstruct_define_struct, _SLANG_BC_CALL_DIRECT); + break; + + case TYPEDEF_TOKEN: + compile_call_direct (_SLstruct_define_typedef, _SLANG_BC_CALL_DIRECT); + break; + + case TMP_TOKEN: + compile_tmp_variable (t->v.s_val, t->hash); + break; + + case DOT_TOKEN: /* X . field */ + compile_dot (t); + break; + + case COMMA_TOKEN: + break; /* do nothing */ + + case IDENT_TOKEN: + compile_hashed_identifier (t->v.s_val, t->hash, t); + break; + + case _REF_TOKEN: + compile_ref (t->v.s_val, t->hash); + break; + + case ARG_TOKEN: + compile_call_direct (SLang_start_arg_list, _SLANG_BC_CALL_DIRECT); + break; + + case EARG_TOKEN: + compile_lvar_call_direct (SLang_end_arg_list, _SLANG_BC_EARG_LVARIABLE, _SLANG_BC_CALL_DIRECT); + break; + + case COLON_TOKEN: + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK) + compile_simple (_SLANG_BC_LABEL); + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case POP_TOKEN: + compile_call_direct (SLdo_pop, _SLANG_BC_CALL_DIRECT); + break; + + case CASE_TOKEN: + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK) + SLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case'"); + else + compile_call_direct (case_function, _SLANG_BC_CALL_DIRECT); + break; + + case CHAR_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_CHAR_TYPE); + break; + case SHORT_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_SHORT_TYPE); + break; + case INT_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL_INT, SLANG_INT_TYPE); + break; + case UCHAR_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_UCHAR_TYPE); + break; + case USHORT_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_USHORT_TYPE); + break; + case UINT_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL_INT, SLANG_UINT_TYPE); + break; + case LONG_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_LONG_TYPE); + break; + case ULONG_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_ULONG_TYPE); + break; + +#if SLANG_HAS_FLOAT + case FLOAT_TOKEN: + compile_float (t->v.s_val); + break; + + case DOUBLE_TOKEN: + compile_double (t->v.s_val, _SLANG_BC_LITERAL_DBL, SLANG_DOUBLE_TYPE); + break; +#endif +#if SLANG_HAS_COMPLEX + case COMPLEX_TOKEN: + compile_double (t->v.s_val, _SLANG_BC_LITERAL, SLANG_COMPLEX_TYPE); + break; +#endif + + case STRING_TOKEN: + compile_string (t->v.s_val, t->hash); + break; + + case _BSTRING_TOKEN: + compile_bstring (SLbstring_create ((unsigned char *)t->v.s_val, (unsigned int) t->hash)); + break; + + case BSTRING_TOKEN: + compile_bstring (t->v.b_val); + break; + + case _NULL_TOKEN: + compile_identifier ("NULL", t); + break; + + case _INLINE_WILDCARD_ARRAY_TOKEN: + compile_call_direct (_SLarray_wildcard_array, _SLANG_BC_CALL_DIRECT); + break; + + case _INLINE_ARRAY_TOKEN: + compile_call_direct (_SLarray_inline_array, _SLANG_BC_CALL_DIRECT_FRAME); + break; + + case _INLINE_IMPLICIT_ARRAY_TOKEN: + compile_call_direct (_SLarray_inline_implicit_array, _SLANG_BC_CALL_DIRECT_FRAME); + break; + + case ARRAY_TOKEN: + compile_lvar_call_direct (_SLarray_aget, _SLANG_BC_LVARIABLE_AGET, _SLANG_BC_CALL_DIRECT_FRAME); + break; + + /* Note: I need to add the other _ARRAY assign tokens. */ + case _ARRAY_PLUSEQS_TOKEN: + case _ARRAY_MINUSEQS_TOKEN: + case _ARRAY_TIMESEQS_TOKEN: + case _ARRAY_DIVEQS_TOKEN: + case _ARRAY_BOREQS_TOKEN: + case _ARRAY_BANDEQS_TOKEN: + case _ARRAY_POST_MINUSMINUS_TOKEN: + case _ARRAY_MINUSMINUS_TOKEN: + case _ARRAY_POST_PLUSPLUS_TOKEN: + case _ARRAY_PLUSPLUS_TOKEN: + compile_array_assign (t); + break; + + case _ARRAY_ASSIGN_TOKEN: + compile_lvar_call_direct (_SLarray_aput, _SLANG_BC_LVARIABLE_APUT, _SLANG_BC_CALL_DIRECT_FRAME); + break; + + case _STRUCT_ASSIGN_TOKEN: + case _STRUCT_PLUSEQS_TOKEN: + case _STRUCT_MINUSEQS_TOKEN: + case _STRUCT_TIMESEQS_TOKEN: + case _STRUCT_DIVEQS_TOKEN: + case _STRUCT_BOREQS_TOKEN: + case _STRUCT_BANDEQS_TOKEN: + case _STRUCT_POST_MINUSMINUS_TOKEN: + case _STRUCT_MINUSMINUS_TOKEN: + case _STRUCT_POST_PLUSPLUS_TOKEN: + case _STRUCT_PLUSPLUS_TOKEN: + compile_struct_assign (t); + break; + + case _SCALAR_ASSIGN_TOKEN: + case _SCALAR_PLUSEQS_TOKEN: + case _SCALAR_MINUSEQS_TOKEN: + case _SCALAR_TIMESEQS_TOKEN: + case _SCALAR_DIVEQS_TOKEN: + case _SCALAR_BOREQS_TOKEN: + case _SCALAR_BANDEQS_TOKEN: + case _SCALAR_POST_MINUSMINUS_TOKEN: + case _SCALAR_MINUSMINUS_TOKEN: + case _SCALAR_POST_PLUSPLUS_TOKEN: + case _SCALAR_PLUSPLUS_TOKEN: + compile_assign (_SLANG_BCST_ASSIGN + (t->type - _SCALAR_ASSIGN_TOKEN), + t->v.s_val, t->hash); + break; + + case _DEREF_ASSIGN_TOKEN: + compile_deref_assign (t->v.s_val, t->hash); + break; + + /* For processing RPN tokens */ + case ASSIGN_TOKEN: + case PLUSEQS_TOKEN: + case MINUSEQS_TOKEN: + case TIMESEQS_TOKEN: + case DIVEQS_TOKEN: + case BOREQS_TOKEN: + case BANDEQS_TOKEN: + case POST_MINUSMINUS_TOKEN: + case MINUSMINUS_TOKEN: + case POST_PLUSPLUS_TOKEN: + case PLUSPLUS_TOKEN: + Compile_Mode_Function = compile_assign_mode; + Assign_Mode_Type = _SLANG_BCST_ASSIGN + (t->type - ASSIGN_TOKEN); + break; + + case LT_TOKEN: + compile_binary (SLANG_LT); + break; + + case LE_TOKEN: + compile_binary (SLANG_LE); + break; + + case GT_TOKEN: + compile_binary (SLANG_GT); + break; + + case GE_TOKEN: + compile_binary (SLANG_GE); + break; + + case EQ_TOKEN: + compile_binary (SLANG_EQ); + break; + + case NE_TOKEN: + compile_binary (SLANG_NE); + break; + + case AND_TOKEN: + compile_binary (SLANG_AND); + break; + + case ADD_TOKEN: + compile_fast_binary (SLANG_PLUS, _SLANG_BC_INTEGER_PLUS); + break; + + case SUB_TOKEN: + compile_fast_binary (SLANG_MINUS, _SLANG_BC_INTEGER_MINUS); + break; + + case TIMES_TOKEN: + compile_binary (SLANG_TIMES); + break; + + case DIV_TOKEN: + compile_binary (SLANG_DIVIDE); + break; + + case POW_TOKEN: + compile_binary (SLANG_POW); + break; + + case BXOR_TOKEN: + compile_binary (SLANG_BXOR); + break; + + case BAND_TOKEN: + compile_binary (SLANG_BAND); + break; + + case BOR_TOKEN: + compile_binary (SLANG_BOR); + break; + + case SHR_TOKEN: + compile_binary (SLANG_SHR); + break; + + case SHL_TOKEN: + compile_binary (SLANG_SHL); + break; + + case MOD_TOKEN: + compile_binary (SLANG_MOD); + break; + + case OR_TOKEN: + compile_binary (SLANG_OR); + break; + + case NOT_TOKEN: + compile_unary (SLANG_NOT, _SLANG_BC_UNARY); + break; + + case BNOT_TOKEN: + compile_unary (SLANG_BNOT, _SLANG_BC_UNARY); + break; + + case MUL2_TOKEN: + compile_unary (SLANG_MUL2, _SLANG_BC_UNARY_FUNC); + break; + + case CHS_TOKEN: + compile_unary (SLANG_CHS, _SLANG_BC_UNARY_FUNC); + break; + + case ABS_TOKEN: + compile_unary (SLANG_ABS, _SLANG_BC_UNARY_FUNC); + break; + + case SQR_TOKEN: + compile_unary (SLANG_SQR, _SLANG_BC_UNARY_FUNC); + break; + + case SIGN_TOKEN: + compile_unary (SLANG_SIGN, _SLANG_BC_UNARY_FUNC); + break; + + case BREAK_TOKEN: + compile_break (_SLANG_BC_BREAK, 1, 0, "break"); + break; + + case RETURN_TOKEN: + compile_break (_SLANG_BC_RETURN, 0, 1, "return"); + break; + + case CONT_TOKEN: + compile_break (_SLANG_BC_CONTINUE, 1, 0, "continue"); + break; + + case EXCH_TOKEN: + compile_break (_SLANG_BC_EXCH, 0, 0, ""); /* FIXME: Priority=low */ + break; + + case STATIC_TOKEN: + if (Lang_Defining_Function == 0) + Compile_Mode_Function = compile_static_variable_mode; + else + SLang_verror (SL_NOT_IMPLEMENTED, "static variables not permitted in functions"); + break; + + case PRIVATE_TOKEN: + if (Lang_Defining_Function == 0) + Compile_Mode_Function = compile_private_variable_mode; + else + SLang_verror (SL_NOT_IMPLEMENTED, "private variables not permitted in functions"); + break; + + case PUBLIC_TOKEN: + if (Lang_Defining_Function == 0) + Compile_Mode_Function = compile_public_variable_mode; + else + SLang_verror (SL_NOT_IMPLEMENTED, "public variables not permitted in functions"); + break; + + case OBRACKET_TOKEN: + if (Lang_Defining_Function == 0) + Compile_Mode_Function = Default_Variable_Mode; + else + Compile_Mode_Function = compile_local_variable_mode; + break; + + case OPAREN_TOKEN: + lang_begin_function (); + break; + + case DEFINE_STATIC_TOKEN: + if (Lang_Defining_Function) + define_static_function (t->v.s_val, t->hash); + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case DEFINE_PRIVATE_TOKEN: + if (Lang_Defining_Function) + define_private_function (t->v.s_val, t->hash); + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case DEFINE_PUBLIC_TOKEN: + if (Lang_Defining_Function) + define_public_function (t->v.s_val, t->hash); + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case DEFINE_TOKEN: + if (Lang_Defining_Function) + (*Default_Define_Function) (t->v.s_val, t->hash); + else + SLang_Error = SL_SYNTAX_ERROR; + break; + + case CPAREN_TOKEN: + if (Lang_Defining_Function) + Compile_Mode_Function = compile_function_mode; + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case CBRACE_TOKEN: + lang_end_block (); + Compile_Mode_Function = compile_directive_mode; + break; + + case OBRACE_TOKEN: + lang_begin_block (); + break; + + case FARG_TOKEN: + Function_Args_Number = Local_Variable_Number; + break; + +#if _SLANG_HAS_DEBUG_CODE + case LINE_NUM_TOKEN: + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LINE_NUM; + Compile_ByteCode_Ptr->b.l_blk = t->v.long_val; + lang_try_now (); + break; +#endif + case POUND_TOKEN: + compile_call_direct (_SLarray_matrix_multiply, _SLANG_BC_CALL_DIRECT); + break; + } +} + +void _SLcompile (_SLang_Token_Type *t) +{ + if (SLang_Error == 0) + { + if (Compile_Mode_Function != compile_basic_token_mode) + { + if (Compile_Mode_Function == NULL) + Compile_Mode_Function = compile_basic_token_mode; +#if _SLANG_HAS_DEBUG_CODE + if (t->type == LINE_NUM_TOKEN) + { + compile_basic_token_mode (t); + return; + } +#endif + } + + (*Compile_Mode_Function) (t); + } + + if (SLang_Error) + { + Compile_Mode_Function = compile_basic_token_mode; + SLang_restart (0); + } +} + +void (*_SLcompile_ptr)(_SLang_Token_Type *) = _SLcompile; + +typedef struct _Compile_Context_Type +{ + struct _Compile_Context_Type *next; + SLang_NameSpace_Type *static_namespace; + void (*compile_variable_mode) (_SLang_Token_Type *); + void (*define_function) (char *, unsigned long); + int lang_defining_function; + int local_variable_number; + unsigned int function_args_number; + SLang_Name_Type **locals_hash_table; + void (*compile_mode_function)(_SLang_Token_Type *); +#if _SLANG_HAS_DEBUG_CODE + char *compile_filename; +#endif +} +Compile_Context_Type; + +static Compile_Context_Type *Compile_Context_Stack; + +/* The only way the push/pop_context functions can get called is via + * an eval type function. That can only happen when executed from a + * top level block. This means that Compile_ByteCode_Ptr can always be + * rest back to the beginning of a block. + */ + +static int pop_compile_context (void) +{ + Compile_Context_Type *cc; + + if (NULL == (cc = Compile_Context_Stack)) + return -1; + + This_Static_NameSpace = cc->static_namespace; + Compile_Context_Stack = cc->next; + Default_Variable_Mode = cc->compile_variable_mode; + Default_Define_Function = cc->define_function; + Compile_Mode_Function = cc->compile_mode_function; + + Lang_Defining_Function = cc->lang_defining_function; + Local_Variable_Number = cc->local_variable_number; + Function_Args_Number = cc->function_args_number; + +#if _SLANG_HAS_DEBUG_CODE + SLang_free_slstring (This_Compile_Filename); + This_Compile_Filename = cc->compile_filename; +#endif + + SLfree ((char *) Locals_Hash_Table); + Locals_Hash_Table = cc->locals_hash_table; + + SLfree ((char *) cc); + + return 0; +} + +static int push_compile_context (char *name) +{ + Compile_Context_Type *cc; + SLang_Name_Type **lns; + + cc = (Compile_Context_Type *)SLmalloc (sizeof (Compile_Context_Type)); + if (cc == NULL) + return -1; + memset ((char *) cc, 0, sizeof (Compile_Context_Type)); + + lns = (SLang_Name_Type **) SLcalloc (sizeof (SLang_Name_Type *), SLLOCALS_HASH_TABLE_SIZE); + if (lns == NULL) + { + SLfree ((char *) cc); + return -1; + } + +#if _SLANG_HAS_DEBUG_CODE + if ((name != NULL) + && (NULL == (name = SLang_create_slstring (name)))) + { + SLfree ((char *) cc); + SLfree ((char *) lns); + return -1; + } + + cc->compile_filename = This_Compile_Filename; + This_Compile_Filename = name; +#endif + + cc->static_namespace = This_Static_NameSpace; + cc->compile_variable_mode = Default_Variable_Mode; + cc->define_function = Default_Define_Function; + cc->locals_hash_table = Locals_Hash_Table; + + cc->lang_defining_function = Lang_Defining_Function; + cc->local_variable_number = Local_Variable_Number; + cc->function_args_number = Function_Args_Number; + cc->locals_hash_table = Locals_Hash_Table; + cc->compile_mode_function = Compile_Mode_Function; + + cc->next = Compile_Context_Stack; + Compile_Context_Stack = cc; + + Compile_Mode_Function = compile_basic_token_mode; + Default_Variable_Mode = compile_public_variable_mode; + Default_Define_Function = define_public_function; + Lang_Defining_Function = 0; + Local_Variable_Number = 0; + Function_Args_Number = 0; + Locals_Hash_Table = lns; + return 0; +} + +static int init_interpreter (void) +{ + SLang_NameSpace_Type *ns; + + if (Global_NameSpace != NULL) + return 0; + + if (NULL == (ns = _SLns_allocate_namespace ("***GLOBAL***", SLGLOBALS_HASH_TABLE_SIZE))) + return -1; + if (-1 == _SLns_set_namespace_name (ns, "Global")) + return -1; + Global_NameSpace = ns; + + _SLRun_Stack = (SLang_Object_Type *) SLcalloc (SLANG_MAX_STACK_LEN, + sizeof (SLang_Object_Type)); + if (_SLRun_Stack == NULL) + return -1; + + _SLStack_Pointer = _SLRun_Stack; + _SLStack_Pointer_Max = _SLRun_Stack + SLANG_MAX_STACK_LEN; + + SLShort_Blocks[SHORT_BLOCK_RETURN_INDX].bc_main_type = _SLANG_BC_RETURN; + SLShort_Blocks[SHORT_BLOCK_BREAK_INDX].bc_main_type = _SLANG_BC_BREAK; + SLShort_Blocks[SHORT_BLOCK_CONTINUE_INDX].bc_main_type = _SLANG_BC_CONTINUE; + + Num_Args_Stack = (int *) SLmalloc (sizeof (int) * SLANG_MAX_RECURSIVE_DEPTH); + if (Num_Args_Stack == NULL) + { + SLfree ((char *) _SLRun_Stack); + return -1; + } + Recursion_Depth = 0; + Frame_Pointer_Stack = (unsigned int *) SLmalloc (sizeof (unsigned int) * SLANG_MAX_RECURSIVE_DEPTH); + if (Frame_Pointer_Stack == NULL) + { + SLfree ((char *) _SLRun_Stack); + SLfree ((char *)Num_Args_Stack); + return -1; + } + Frame_Pointer_Depth = 0; + Frame_Pointer = _SLRun_Stack; + + (void) setup_default_compile_linkage (1); + return 0; +} + +static int add_generic_table (SLang_NameSpace_Type *ns, + SLang_Name_Type *table, char *pp_name, + unsigned int entry_len) +{ + SLang_Name_Type *t, **ns_table; + char *name; + unsigned int table_size; + + if (-1 == init_interpreter ()) + return -1; + + if (ns == NULL) + ns = Global_NameSpace; + + ns_table = ns->table; + table_size = ns->table_size; + + if ((pp_name != NULL) + && (-1 == SLdefine_for_ifdef (pp_name))) + return -1; + + t = table; + while (NULL != (name = t->name)) + { + unsigned long hash; + + /* Backward compatibility: '.' WAS used as hash marker */ + if (*name == '.') + { + name++; + t->name = name; + } + + if (NULL == (name = SLang_create_slstring (name))) + return -1; + + t->name = name; + + hash = _SLcompute_string_hash (name); + hash = hash % table_size; + + /* First time. Make sure this has not already been added */ + if (t == table) + { + SLang_Name_Type *tt = ns_table[(unsigned int) hash]; + while (tt != NULL) + { + if (tt == t) + { + SLang_verror (SL_APPLICATION_ERROR, + "An intrinsic symbol table may not be added twice. [%s]", + pp_name == NULL ? "" : pp_name); + return -1; + } + tt = tt->next; + } + } + + t->next = ns_table [(unsigned int) hash]; + ns_table [(unsigned int) hash] = t; + + t = (SLang_Name_Type *) ((char *)t + entry_len); + } + + return 0; +} + +int SLadd_intrin_fun_table (SLang_Intrin_Fun_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type)); +} + +int SLadd_intrin_var_table (SLang_Intrin_Var_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type)); +} + +int SLadd_app_unary_table (SLang_App_Unary_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type)); +} + +int SLadd_math_unary_table (SLang_Math_Unary_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type)); +} + +int SLadd_iconstant_table (SLang_IConstant_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type)); +} + +#if SLANG_HAS_FLOAT +int SLadd_dconstant_table (SLang_DConstant_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type)); +} +#endif + +/* ----------- */ +int SLns_add_intrin_fun_table (SLang_NameSpace_Type *ns, SLang_Intrin_Fun_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type)); +} + +int SLns_add_intrin_var_table (SLang_NameSpace_Type *ns, SLang_Intrin_Var_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type)); +} + +int SLns_add_app_unary_table (SLang_NameSpace_Type *ns, SLang_App_Unary_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type)); +} + +int SLns_add_math_unary_table (SLang_NameSpace_Type *ns, SLang_Math_Unary_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type)); +} + +int SLns_add_iconstant_table (SLang_NameSpace_Type *ns, SLang_IConstant_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type)); +} + +#if SLANG_HAS_FLOAT +int SLns_add_dconstant_table (SLang_NameSpace_Type *ns, SLang_DConstant_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type)); +} +#endif + +static int setup_default_compile_linkage (int is_public) +{ + if (is_public) + { + Default_Define_Function = define_public_function; + Default_Variable_Mode = compile_public_variable_mode; + } + else + { + Default_Define_Function = define_static_function; + Default_Variable_Mode = compile_static_variable_mode; + } + + return 0; +} + +/* what is a bitmapped value: + * 1 intrin fun + * 2 user fun + * 4 intrin var + * 8 user defined var + */ +SLang_Array_Type *_SLang_apropos (char *namespace_name, char *pat, unsigned int what) +{ + SLang_NameSpace_Type *ns; + + if (namespace_name == NULL) + namespace_name = "Global"; + + if (*namespace_name == 0) + ns = This_Static_NameSpace; + else ns = _SLns_find_namespace (namespace_name); + + return _SLnspace_apropos (ns, pat, what); +} + + +void _SLang_implements_intrinsic (char *name) +{ + (void) implements_ns (name); +} + + +void _SLang_use_namespace_intrinsic (char *name) +{ + SLang_NameSpace_Type *ns; + + if (NULL == (ns = _SLns_find_namespace (name))) + { + SLang_verror (SL_INTRINSIC_ERROR, "Namespace %s does not exist", name); + return; + } + This_Static_NameSpace = ns; + (void) setup_default_compile_linkage (ns == Global_NameSpace); +} + + +char *_SLang_cur_namespace_intrinsic (void) +{ + if (This_Static_NameSpace == NULL) + return "Global"; + + if (This_Static_NameSpace->namespace_name == NULL) + return ""; + + return This_Static_NameSpace->namespace_name; +} + +char *_SLang_current_function_name (void) +{ + return Current_Function_Name; +} + +SLang_Object_Type *_SLang_get_run_stack_pointer (void) +{ + return _SLStack_Pointer; +} + +SLang_Object_Type *_SLang_get_run_stack_base (void) +{ + return _SLRun_Stack; +} + + +int _SLang_dump_stack (void) /*{{{*/ +{ + char buf[32]; + unsigned int n; + + n = (unsigned int) (_SLStack_Pointer - _SLRun_Stack); + while (n) + { + n--; + sprintf (buf, "(%u)", n); + _SLdump_objects (buf, _SLRun_Stack + n, 1, 1); + } + return 0; +} + +/*}}}*/ + +int _SLang_is_arith_type (SLtype t) +{ + return (int) Is_Arith_Type[t]; +} +void _SLang_set_arith_type (SLtype t, unsigned char v) +{ + Is_Arith_Type[t] = v; +} + +#if _SLANG_OPTIMIZE_FOR_SPEED +int _SLang_get_class_type (SLtype t) +{ + return Class_Type[t]; +} +void _SLang_set_class_type (SLtype t, SLtype ct) +{ + Class_Type[t] = ct; +} + +#endif diff --git a/libslang/src/slang.h b/libslang/src/slang.h new file mode 100644 index 0000000..133ecd2 --- /dev/null +++ b/libslang/src/slang.h @@ -0,0 +1,2034 @@ +#ifndef DAVIS_SLANG_H_ +#define DAVIS_SLANG_H_ +/* -*- mode: C; mode: fold; -*- */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#define SLANG_VERSION 10409 +#define SLANG_VERSION_STRING "1.4.9" + +/*{{{ System Dependent Macros and Typedefs */ + +#if defined(__WATCOMC__) && defined(DOS) +# ifndef __MSDOS__ +# define __MSDOS__ +# endif +# ifndef DOS386 +# define DOS386 +# endif +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif /* __watcomc__ */ + +#if defined(unix) || defined(__unix) +# ifndef __unix__ +# define __unix__ 1 +# endif +#endif + +#if !defined(__GO32__) +# ifdef __unix__ +# define REAL_UNIX_SYSTEM +# endif +#endif + +/* Set of the various defines for pc systems. This includes OS/2 */ +#ifdef __GO32__ +# ifndef __DJGPP__ +# define __DJGPP__ 1 +# endif +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif + +#ifdef __BORLANDC__ +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif + +#ifdef __MSDOS__ +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif + +#if defined(OS2) || defined(__os2__) +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +# ifndef __os2__ +# define __os2__ +# endif +#endif + +#if defined(__NT__) || defined(__MINGW32__) /* || defined(__CYGWIN32__) */ +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif + +#if defined(IBMPC_SYSTEM) || defined(VMS) +# ifdef REAL_UNIX_SYSTEM +# undef REAL_UNIX_SYSTEM +# endif +#endif + +#ifdef __cplusplus +extern "C" { +#endif +#if 0 +} +#endif + +#include +#include +#if defined(__STDC__) || defined(__BORLANDC__) || defined(__cplusplus) +# include /* for offsetof */ +#endif + +/* ---------------------------- Generic Macros ----------------------------- */ + +/* __SC__ is defined for Symantec C++ + DOS386 is defined for -mx memory model, 32 bit DOS extender. */ + +#if defined(__SC__) && !defined(DOS386) +# include +#endif + +#if defined(__BORLANDC__) +# include +#endif + +#ifdef __GNUC__ +# define _SLATTRIBUTE_(x) __attribute__ (x) +#else +# define _SLATTRIBUTE_(x) +#endif +#define _SLATTRIBUTE_PRINTF(a,b) _SLATTRIBUTE_((format(printf,a,b))) + +#if defined (__cplusplus) || defined(__STDC__) || defined(IBMPC_SYSTEM) +typedef void *VOID_STAR; +#define SLCONST const +#else +typedef unsigned char *VOID_STAR; +#define SLCONST +#endif + +typedef int (*FVOID_STAR)(void); + +#if defined(__MSDOS__) && defined(__BORLANDC__) +# define SLFREE(buf) farfree((void far *)(buf)) +# define SLMALLOC(x) farmalloc((unsigned long) (x)) +# define SLREALLOC(buf, n) farrealloc((void far *) (buf), (unsigned long) (n)) +# define SLCALLOC(n, m) farcalloc((unsigned long) (n), (unsigned long) (m)) +#else +# if defined(VMS) && !defined(__DECC) +# define SLFREE VAXC$FREE_OPT +# define SLMALLOC VAXC$MALLOC_OPT +# define SLREALLOC VAXC$REALLOC_OPT +# define SLCALLOC VAXC$CALLOC_OPT +# else +# define SLFREE(x) free((char *)(x)) +# define SLMALLOC malloc +# define SLREALLOC realloc +# define SLCALLOC calloc +# endif +#endif + + extern char *SLdebug_malloc (unsigned long); + extern char *SLdebug_calloc (unsigned long, unsigned long); + extern char *SLdebug_realloc (char *, unsigned long); + extern void SLdebug_free (char *); + extern void SLmalloc_dump_statistics (void); + extern char *SLstrcpy(register char *, register char *); + extern int SLstrcmp(register char *, register char *); + extern char *SLstrncpy(char *, register char *, register int); + + extern void SLmemset (char *, char, int); + extern char *SLmemchr (register char *, register char, register int); + extern char *SLmemcpy (char *, char *, int); + extern int SLmemcmp (char *, char *, int); + +/*}}}*/ + +/*{{{ Interpreter Typedefs */ + +typedef unsigned char SLtype; /* This will be unsigned int in V2 */ + +typedef struct _SLang_Name_Type +{ + char *name; + struct _SLang_Name_Type *next; + char name_type; + /* These values must be less than 0x10 because they map directly + * to byte codes. See _slang.h. + */ +#define SLANG_LVARIABLE 0x01 +#define SLANG_GVARIABLE 0x02 +#define SLANG_IVARIABLE 0x03 /* intrinsic variables */ + /* Note!!! For Macro MAKE_VARIABLE below to work, SLANG_IVARIABLE Must + be 1 less than SLANG_RVARIABLE!!! */ +#define SLANG_RVARIABLE 0x04 /* read only variable */ +#define SLANG_INTRINSIC 0x05 +#define SLANG_FUNCTION 0x06 +#define SLANG_MATH_UNARY 0x07 +#define SLANG_APP_UNARY 0x08 +#define SLANG_ICONSTANT 0x09 +#define SLANG_DCONSTANT 0x0A +#define SLANG_PVARIABLE 0x0B /* private */ +#define SLANG_PFUNCTION 0x0C /* private */ + + /* Rest of fields depend on name type */ +} +SLang_Name_Type; + +typedef struct +{ + char *name; + struct _SLang_Name_Type *next; /* this is for the hash table */ + char name_type; + + FVOID_STAR i_fun; /* address of object */ + + /* Do not change this without modifying slang.c:execute_intrinsic_fun */ +#define SLANG_MAX_INTRIN_ARGS 7 + SLtype arg_types [SLANG_MAX_INTRIN_ARGS]; + unsigned char num_args; + SLtype return_type; +} +SLang_Intrin_Fun_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + VOID_STAR addr; + SLtype type; +} +SLang_Intrin_Var_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + int unary_op; +} +SLang_App_Unary_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + int unary_op; +} +SLang_Math_Unary_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + int i; +} +SLang_IConstant_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + double d; +} +SLang_DConstant_Type; + +typedef struct +{ + char *field_name; /* gets replaced by slstring at run-time */ + unsigned int offset; + SLtype type; + unsigned char read_only; +} +SLang_IStruct_Field_Type; + +typedef SLCONST struct +{ + char *field_name; + unsigned int offset; + SLtype type; + unsigned char read_only; +} +SLang_CStruct_Field_Type; + +extern int SLadd_intrin_fun_table (SLang_Intrin_Fun_Type *, char *); +extern int SLadd_intrin_var_table (SLang_Intrin_Var_Type *, char *); +extern int SLadd_app_unary_table (SLang_App_Unary_Type *, char *); +extern int SLadd_math_unary_table (SLang_Math_Unary_Type *, char *); +extern int SLadd_iconstant_table (SLang_IConstant_Type *, char *); +extern int SLadd_dconstant_table (SLang_DConstant_Type *, char *); +extern int SLadd_istruct_table (SLang_IStruct_Field_Type *, VOID_STAR, char *); + + +typedef struct _SLang_NameSpace_Type SLang_NameSpace_Type; + +extern int SLns_add_intrin_fun_table (SLang_NameSpace_Type *, SLang_Intrin_Fun_Type *, char *); +extern int SLns_add_intrin_var_table (SLang_NameSpace_Type *, SLang_Intrin_Var_Type *, char *); +extern int SLns_add_app_unary_table (SLang_NameSpace_Type *, SLang_App_Unary_Type *, char *); +extern int SLns_add_math_unary_table (SLang_NameSpace_Type *, SLang_Math_Unary_Type *, char *); +extern int SLns_add_iconstant_table (SLang_NameSpace_Type *, SLang_IConstant_Type *, char *); +extern int SLns_add_dconstant_table (SLang_NameSpace_Type *, SLang_DConstant_Type *, char *); +extern int SLns_add_istruct_table (SLang_NameSpace_Type *, SLang_IStruct_Field_Type *, VOID_STAR, char *); + +extern SLang_NameSpace_Type *SLns_create_namespace (char *); +extern void SLns_delete_namespace (SLang_NameSpace_Type *); + +extern int SLns_load_file (char *, char *); +extern int SLns_load_string (char *, char *); +extern int (*SLns_Load_File_Hook) (char *, char *); +int SLang_load_file_verbose (int); +/* if non-zero, display file loading messages */ + +typedef struct SLang_Load_Type +{ + int type; + + VOID_STAR client_data; + /* Pointer to data that client needs for loading */ + + int auto_declare_globals; + /* if non-zero, undefined global variables are declared as static */ + + char *(*read)(struct SLang_Load_Type *); + /* function to call to read next line from obj. */ + + unsigned int line_num; + /* Number of lines read, used for error reporting */ + + int parse_level; + /* 0 if at top level of parsing */ + + char *name; + /* Name of this object, e.g., filename. This name should be unique because + * it alone determines the name space for static objects associated with + * the compilable unit. + */ + + char *namespace_name; + unsigned long reserved[3]; + /* For future expansion */ +} SLang_Load_Type; + +extern SLang_Load_Type *SLallocate_load_type (char *); +extern void SLdeallocate_load_type (SLang_Load_Type *); +extern SLang_Load_Type *SLns_allocate_load_type (char *, char *); + +/* Returns SLang_Error upon failure */ +extern int SLang_load_object (SLang_Load_Type *); +extern int (*SLang_Load_File_Hook)(char *); +extern int (*SLang_Auto_Declare_Var_Hook) (char *); + +extern int SLang_generate_debug_info (int); + + +#if defined(ultrix) && !defined(__GNUC__) +# ifndef NO_PROTOTYPES +# define NO_PROTOTYPES +# endif +#endif + +#ifndef NO_PROTOTYPES +# define _PROTO(x) x +#else +# define _PROTO(x) () +#endif + +typedef struct SL_OOBinary_Type +{ + SLtype data_type; /* partner type for binary op */ + + int (*binary_function)_PROTO((int, + SLtype, VOID_STAR, unsigned int, + SLtype, VOID_STAR, unsigned int, + VOID_STAR)); + + int (*binary_result) _PROTO((int, SLtype, SLtype, SLtype *)); + struct SL_OOBinary_Type *next; +} +SL_OOBinary_Type; + +typedef struct _SL_Typecast_Type +{ + SLtype data_type; /* to_type */ + int allow_implicit; + + int (*typecast)_PROTO((SLtype, VOID_STAR, unsigned int, + SLtype, VOID_STAR)); + struct _SL_Typecast_Type *next; +} +SL_Typecast_Type; + +typedef struct _SLang_Struct_Type SLang_Struct_Type; +typedef struct _SLang_Foreach_Context_Type SLang_Foreach_Context_Type; + +#if 0 +#if defined(SL_APP_WANTS_FOREACH) +typedef struct _SLang_Foreach_Context_Type SLang_Foreach_Context_Type; +/* It is up to the application to define struct _SLang_Foreach_Context_Type */ +#else +typedef int SLang_Foreach_Context_Type; +#endif +#endif + +typedef struct +{ + unsigned char cl_class_type; +#define SLANG_CLASS_TYPE_MMT 0 +#define SLANG_CLASS_TYPE_SCALAR 1 +#define SLANG_CLASS_TYPE_VECTOR 2 +#define SLANG_CLASS_TYPE_PTR 3 + + unsigned int cl_data_type; /* SLANG_INTEGER_TYPE, etc... */ + char *cl_name; /* slstring type */ + + unsigned int cl_sizeof_type; + VOID_STAR cl_transfer_buf; /* cl_sizeof_type bytes*/ + + /* Methods */ + + /* Most of the method functions are prototyped: + * int method (SLtype type, VOID_STAR addr); + * Here, @type@ represents the type of object that the method is asked + * to deal with. The second parameter @addr@ will contain the ADDRESS of + * the object. For example, if type is SLANG_INT_TYPE, then @addr@ will + * actually be int *. Similary, if type is SLANG_STRING_TYPE, + * then @addr@ will contain the address of the string, i.e., char **. + */ + + void (*cl_destroy)_PROTO((SLtype, VOID_STAR)); + /* Prototype: void destroy(unsigned type, VOID_STAR val) + * Called to delete/free the object */ + + char *(*cl_string)_PROTO((SLtype, VOID_STAR)); + /* Prototype: char *to_string (SLtype t, VOID_STAR p); + * Here p is a pointer to the object for which a string representation + * is to be returned. The returned pointer is to be a MALLOCED string. + */ + + /* Prototype: void push(SLtype type, VOID_STAR v); + * Push a copy of the object of type @type@ at address @v@ onto the + * stack. + */ + int (*cl_push)_PROTO((SLtype, VOID_STAR)); + + /* Prototype: int pop(SLtype type, VOID_STAR v); + * Pops value from stack and assign it to object, whose address is @v@. + */ + int (*cl_pop)_PROTO((SLtype, VOID_STAR)); + + int (*cl_unary_op_result_type)_PROTO((int, SLtype, SLtype *)); + int (*cl_unary_op)_PROTO((int, SLtype, VOID_STAR, unsigned int, VOID_STAR)); + + int (*cl_app_unary_op_result_type)_PROTO((int, SLtype, SLtype *)); + int (*cl_app_unary_op)_PROTO((int, SLtype, VOID_STAR, unsigned int, VOID_STAR)); + + /* If this function is non-NULL, it will be called for sin, cos, etc... */ +#define SLMATH_SIN 1 +#define SLMATH_COS 2 +#define SLMATH_TAN 3 +#define SLMATH_ATAN 4 +#define SLMATH_ASIN 5 +#define SLMATH_ACOS 6 +#define SLMATH_EXP 7 +#define SLMATH_LOG 8 +#define SLMATH_SQRT 9 +#define SLMATH_LOG10 10 +#define SLMATH_REAL 11 +#define SLMATH_IMAG 12 +#define SLMATH_SINH 13 +#define SLMATH_COSH 14 +#define SLMATH_TANH 15 +#define SLMATH_ATANH 16 +#define SLMATH_ASINH 17 +#define SLMATH_ACOSH 18 +#define SLMATH_TODOUBLE 19 +#define SLMATH_CONJ 20 + + int (*cl_math_op)_PROTO((int, SLtype, VOID_STAR, unsigned int, VOID_STAR)); + int (*cl_math_op_result_type)_PROTO((int, SLtype, SLtype *)); + + SL_OOBinary_Type *cl_binary_ops; + SL_Typecast_Type *cl_typecast_funs; + + void (*cl_byte_code_destroy)_PROTO((SLtype, VOID_STAR)); + void (*cl_user_destroy_fun)_PROTO((SLtype, VOID_STAR)); + int (*cl_init_array_object)_PROTO((SLtype, VOID_STAR)); + int (*cl_datatype_deref)_PROTO((SLtype)); + SLang_Struct_Type *cl_struct_def; + int (*cl_dereference) _PROTO((SLtype, VOID_STAR)); + int (*cl_acopy) (SLtype, VOID_STAR, VOID_STAR); + int (*cl_apop) _PROTO((SLtype, VOID_STAR)); + int (*cl_apush) _PROTO((SLtype, VOID_STAR)); + int (*cl_push_literal) _PROTO((SLtype, VOID_STAR)); + void (*cl_adestroy)_PROTO((SLtype, VOID_STAR)); + int (*cl_push_intrinsic)_PROTO((SLtype, VOID_STAR)); + int (*cl_void_typecast)_PROTO((SLtype, VOID_STAR, unsigned int, SLtype, VOID_STAR)); + + int (*cl_anytype_typecast)_PROTO((SLtype, VOID_STAR, unsigned int, SLtype, VOID_STAR)); + + /* Array access functions */ + int (*cl_aput) (SLtype, unsigned int); + int (*cl_aget) (SLtype, unsigned int); + int (*cl_anew) (SLtype, unsigned int); + + /* length method */ + int (*cl_length) (SLtype, VOID_STAR, unsigned int *); + + /* foreach */ + SLang_Foreach_Context_Type *(*cl_foreach_open) (SLtype, unsigned int); + void (*cl_foreach_close) (SLtype, SLang_Foreach_Context_Type *); + int (*cl_foreach) (SLtype, SLang_Foreach_Context_Type *); + + /* Structure access: get and put (assign to) fields */ + int (*cl_sput) (SLtype, char *); + int (*cl_sget) (SLtype, char *); + + /* File I/O */ + int (*cl_fread) (SLtype, FILE *, VOID_STAR, unsigned int, unsigned int *); + int (*cl_fwrite) (SLtype, FILE *, VOID_STAR, unsigned int, unsigned int *); + int (*cl_fdread) (SLtype, int, VOID_STAR, unsigned int, unsigned int *); + int (*cl_fdwrite) (SLtype, int, VOID_STAR, unsigned int, unsigned int *); + + int (*cl_to_bool) (SLtype, int *); + + int (*cl_cmp)(SLtype, VOID_STAR, VOID_STAR, int *); +} SLang_Class_Type; + +/* These are the low-level functions for building push/pop methods. They + * know nothing about memory management. For SLANG_CLASS_TYPE_MMT, use the + * MMT push/pop functions instead. + */ +extern int SLclass_push_double_obj (SLtype, double); +extern int SLclass_push_float_obj (SLtype, float); +extern int SLclass_push_long_obj (SLtype, long); +extern int SLclass_push_int_obj (SLtype, int); +extern int SLclass_push_short_obj (SLtype, short); +extern int SLclass_push_char_obj (SLtype, char); +extern int SLclass_push_ptr_obj (SLtype, VOID_STAR); +extern int SLclass_pop_double_obj (SLtype, double *); +extern int SLclass_pop_float_obj (SLtype, float *); +extern int SLclass_pop_long_obj (SLtype, long *); +extern int SLclass_pop_int_obj (SLtype, int *); +extern int SLclass_pop_short_obj (SLtype, short *); +extern int SLclass_pop_char_obj (SLtype, char *); +extern int SLclass_pop_ptr_obj (SLtype, VOID_STAR *); + +extern SLang_Class_Type *SLclass_allocate_class (char *); +extern int SLclass_get_class_id (SLang_Class_Type *cl); +extern int SLclass_create_synonym (char *, SLtype); +extern int SLclass_is_class_defined (SLtype); +extern int SLclass_dup_object (SLtype type, VOID_STAR from, VOID_STAR to); + +extern int SLclass_register_class (SLang_Class_Type *, SLtype, unsigned int, SLtype); +extern int SLclass_set_string_function (SLang_Class_Type *, char *(*)(SLtype, VOID_STAR)); +extern int SLclass_set_destroy_function (SLang_Class_Type *, void (*)(SLtype, VOID_STAR)); +extern int SLclass_set_push_function (SLang_Class_Type *, int (*)(SLtype, VOID_STAR)); +extern int SLclass_set_apush_function (SLang_Class_Type *, int (*)(SLtype, VOID_STAR)); +extern int SLclass_set_pop_function (SLang_Class_Type *, int (*)(SLtype, VOID_STAR)); + +extern int SLclass_set_aget_function (SLang_Class_Type *, int (*)(SLtype, unsigned int)); +extern int SLclass_set_aput_function (SLang_Class_Type *, int (*)(SLtype, unsigned int)); +extern int SLclass_set_anew_function (SLang_Class_Type *, int (*)(SLtype, unsigned int)); + +extern int SLclass_set_sget_function (SLang_Class_Type *, int (*)(SLtype, char *)); +extern int SLclass_set_sput_function (SLang_Class_Type *, int (*)(SLtype, char *)); + +extern int SLclass_set_acopy_function (SLang_Class_Type *, int (*)(SLtype, VOID_STAR, VOID_STAR)); + +/* Typecast object on the stack to type p1. p2 and p3 should be set to 1 */ +extern int SLclass_typecast (SLtype, int, int); + +extern int SLclass_add_unary_op (SLtype, + int (*) (int, + SLtype, VOID_STAR, unsigned int, + VOID_STAR), + int (*) (int, SLtype, SLtype *)); + +extern int +SLclass_add_app_unary_op (SLtype, + int (*) (int, + SLtype, VOID_STAR, unsigned int, + VOID_STAR), + int (*) (int, SLtype, SLtype *)); + +extern int +SLclass_add_binary_op (SLtype, SLtype, + int (*) (int, + SLtype, VOID_STAR, unsigned int, + SLtype, VOID_STAR, unsigned int, + VOID_STAR), + int (*) (int, SLtype, SLtype, SLtype *)); + +extern int +SLclass_add_math_op (SLtype, + int (*)(int, + SLtype, VOID_STAR, unsigned int, + VOID_STAR), + int (*)(int, SLtype, SLtype *)); + +extern int +SLclass_add_typecast (SLtype /* from */, SLtype /* to */, + int (*)_PROTO((SLtype, VOID_STAR, unsigned int, + SLtype, VOID_STAR)), + int /* allow implicit typecasts */ + ); + +extern char *SLclass_get_datatype_name (SLtype); + +extern double SLcomplex_abs (double *); +extern double *SLcomplex_times (double *, double *, double *); +extern double *SLcomplex_divide (double *, double *, double *); +extern double *SLcomplex_sin (double *, double *); +extern double *SLcomplex_cos (double *, double *); +extern double *SLcomplex_tan (double *, double *); +extern double *SLcomplex_asin (double *, double *); +extern double *SLcomplex_acos (double *, double *); +extern double *SLcomplex_atan (double *, double *); +extern double *SLcomplex_exp (double *, double *); +extern double *SLcomplex_log (double *, double *); +extern double *SLcomplex_log10 (double *, double *); +extern double *SLcomplex_sqrt (double *, double *); +extern double *SLcomplex_sinh (double *, double *); +extern double *SLcomplex_cosh (double *, double *); +extern double *SLcomplex_tanh (double *, double *); +extern double *SLcomplex_pow (double *, double *, double *); +extern double SLmath_hypot (double x, double y); + +/* Not implemented yet */ +extern double *SLcomplex_asinh (double *, double *); +extern double *SLcomplex_acosh (double *, double *); +extern double *SLcomplex_atanh (double *, double *); + +#ifdef _SLANG_SOURCE_ +typedef struct _SLang_MMT_Type SLang_MMT_Type; +#else +typedef int SLang_MMT_Type; +#endif + +extern void SLang_free_mmt (SLang_MMT_Type *); +extern VOID_STAR SLang_object_from_mmt (SLang_MMT_Type *); +extern SLang_MMT_Type *SLang_create_mmt (SLtype, VOID_STAR); +extern int SLang_push_mmt (SLang_MMT_Type *); +extern SLang_MMT_Type *SLang_pop_mmt (SLtype); +extern void SLang_inc_mmt (SLang_MMT_Type *); + +/* Maximum number of dimensions of an array. */ +#define SLARRAY_MAX_DIMS 7 +typedef struct _SLang_Array_Type +{ + SLtype data_type; + unsigned int sizeof_type; + VOID_STAR data; + unsigned int num_elements; + unsigned int num_dims; + int dims [SLARRAY_MAX_DIMS]; + VOID_STAR (*index_fun)_PROTO((struct _SLang_Array_Type *, int *)); + /* This function is designed to allow a type to store an array in + * any manner it chooses. This function returns the address of the data + * value at the specified index location. + */ + unsigned int flags; +#define SLARR_DATA_VALUE_IS_READ_ONLY 1 +#define SLARR_DATA_VALUE_IS_POINTER 2 +#define SLARR_DATA_VALUE_IS_RANGE 4 +#define SLARR_DATA_VALUE_IS_INTRINSIC 8 + SLang_Class_Type *cl; + unsigned int num_refs; + void (*free_fun)_PROTO((struct _SLang_Array_Type *)); + VOID_STAR client_data; +} +SLang_Array_Type; + +extern int SLang_pop_array_of_type (SLang_Array_Type **, SLtype); +extern int SLang_pop_array (SLang_Array_Type **, int); +extern int SLang_push_array (SLang_Array_Type *, int); +extern void SLang_free_array (SLang_Array_Type *); +extern SLang_Array_Type *SLang_create_array (SLtype, int, VOID_STAR, int *, unsigned int); +extern SLang_Array_Type *SLang_duplicate_array (SLang_Array_Type *); +extern int SLang_get_array_element (SLang_Array_Type *, int *, VOID_STAR); +extern int SLang_set_array_element (SLang_Array_Type *, int *, VOID_STAR); + +typedef int SLarray_Contract_Fun_Type (VOID_STAR xp, unsigned int increment, unsigned int num, VOID_STAR yp); +typedef struct +{ + SLtype from_type; /* if array is this type */ + SLtype typecast_to_type; /* typecast it to this */ + SLtype result_type; /* to produce this */ + SLarray_Contract_Fun_Type *f; /* via this function */ +} +SLarray_Contract_Type; +extern int SLarray_contract_array (SLCONST SLarray_Contract_Type *); + +typedef int SLarray_Map_Fun_Type (SLtype xtype, VOID_STAR xp, + unsigned int increment, unsigned int num, + SLtype ytype, VOID_STAR yp, VOID_STAR clientdata); +typedef struct +{ + SLtype from_type; /* if array is this type */ + SLtype typecast_to_type; /* typecast it to this */ + SLtype result_type; /* to produce this */ + SLarray_Map_Fun_Type *f; /* via this function */ +} +SLarray_Map_Type; + +extern int SLarray_map_array_1 (SLCONST SLarray_Map_Type *, + int *use_this_dim, + VOID_STAR clientdata); +extern int SLarray_map_array (SLCONST SLarray_Map_Type *); + + +/*}}}*/ + +/*{{{ Interpreter Function Prototypes */ + + extern volatile int SLang_Error; +/* Non zero if error occurs. Must be reset to zero to continue. */ +/* error codes, severe errors are less than 0 */ +#define SL_APPLICATION_ERROR -2 +#define SL_VARIABLE_UNINITIALIZED -3 +#define SL_INTERNAL_ERROR -5 +#define SL_STACK_OVERFLOW -6 +#define SL_STACK_UNDERFLOW -7 +#define SL_UNDEFINED_NAME -8 +#define SL_SYNTAX_ERROR -9 +#define SL_DUPLICATE_DEFINITION -10 +#define SL_TYPE_MISMATCH -11 +#define SL_OBJ_UNKNOWN -13 +#define SL_UNKNOWN_ERROR -14 +#define SL_TYPE_UNDEFINED_OP_ERROR -16 + +#define SL_INTRINSIC_ERROR 1 +/* Intrinsic error is an error generated by intrinsic functions */ +#define SL_USER_BREAK 2 +#define SL_DIVIDE_ERROR 3 +#define SL_OBJ_NOPEN 4 +#define SL_USER_ERROR 5 +#define SL_USAGE_ERROR 6 +#define SL_READONLY_ERROR 7 +#define SL_INVALID_PARM 8 +#define SL_NOT_IMPLEMENTED 9 +#define SL_MALLOC_ERROR 10 +#define SL_OVERFLOW 11 +#define SL_FLOATING_EXCEPTION 12 + +/* Compatibility */ +#define USER_BREAK SL_USER_BREAK +#define INTRINSIC_ERROR SL_INTRINSIC_ERROR + + extern int SLang_Traceback; + /* If non-zero, dump an S-Lang traceback upon error. Available as + _traceback in S-Lang. */ + + extern char *SLang_User_Prompt; + /* Prompt to use when reading from stdin */ + extern int SLang_Version; + extern char *SLang_Version_String; +extern char *SLang_Doc_Dir; + +extern void (*SLang_VMessage_Hook) (char *, va_list); +extern void SLang_vmessage (char *, ...) _SLATTRIBUTE_PRINTF(1,2); + + extern void (*SLang_Error_Hook)(char *); + /* Pointer to application dependent error messaging routine. By default, + messages are displayed on stderr. */ + + extern void (*SLang_Exit_Error_Hook)(char *, va_list); +extern void SLang_exit_error (char *, ...) _SLATTRIBUTE_((format (printf, 1, 2), noreturn)); + extern void (*SLang_Dump_Routine)(char *); + /* Called if S-Lang traceback is enabled as well as other debugging + routines (e.g., trace). By default, these messages go to stderr. */ + + extern void (*SLang_Interrupt)(void); + /* function to call whenever inner interpreter is entered. This is + a good place to set SLang_Error to USER_BREAK. */ + + extern void (*SLang_User_Clear_Error)(void); + /* function that gets called when '_clear_error' is called. */ + + /* If non null, these call C functions before and after a slang function. */ + extern void (*SLang_Enter_Function)(char *); +extern void (*SLang_Exit_Function)(char *); + +extern int SLang_Num_Function_Args; + +/* Functions: */ + +extern int SLang_init_all (void); +/* Initializes interpreter and all modules */ + +extern int SLang_init_slang (void); +/* This function is mandatory and must be called by all applications that + * use the interpreter + */ +extern int SLang_init_posix_process (void); /* process specific intrinsics */ +extern int SLang_init_stdio (void); /* fgets, etc. stdio functions */ +extern int SLang_init_posix_dir (void); +extern int SLang_init_ospath (void); + +extern int SLang_init_slmath (void); +/* called if math functions sin, cos, etc... are needed. */ + + extern int SLang_init_slfile (void); + extern int SLang_init_slunix (void); + /* These functions are obsolte. Use init_stdio, posix_process, etc. */ + +extern int SLang_init_slassoc (void); +/* Assoc Arrays (Hashes) */ + +extern int SLang_init_array (void); +/* Additional arrays functions: transpose, etc... */ + +extern int SLang_init_array_extra (void); +/* Additional arrays functions: sum, min, max, ... */ + +/* Dynamic linking facility */ +extern int SLang_init_import (void); + + extern int SLang_load_file (char *); + /* Load a file of S-Lang code for interpreting. If the parameter is + * NULL, input comes from stdin. */ + + extern void SLang_restart(int); + /* should be called if an error occurs. If the passed integer is + * non-zero, items are popped off the stack; otherwise, the stack is + * left intact. Any time the stack is believed to be trashed, this routine + * should be called with a non-zero argument (e.g., if setjmp/longjmp is + * called). */ + + extern int SLang_byte_compile_file(char *, int); + /* takes a file of S-Lang code and ``byte-compiles'' it for faster + * loading. The new filename is equivalent to the old except that a `c' is + * appended to the name. (e.g., init.sl --> init.slc). The second + * specified the method; currently, it is not used. + */ + + extern int SLang_autoload(char *, char *); + /* Automatically load S-Lang function p1 from file p2. This function + is also available via S-Lang */ + + extern int SLang_load_string(char *); + /* Like SLang_load_file except input is from a null terminated string. */ + + extern int SLdo_pop(void); + /* pops item off stack and frees any memory associated with it */ + extern int SLdo_pop_n(unsigned int); + /* pops n items off stack and frees any memory associated with them */ + +extern int SLang_pop_datatype (SLtype *); +extern int SLang_push_datatype (SLtype); + +extern int SLang_pop_integer(int *); +extern int SLang_pop_uinteger(unsigned int *); + /* pops integer *p0 from the stack. Returns 0 upon success and non-zero + * if the stack is empty or a type mismatch occurs, setting SLang_Error. + */ +extern int SLang_pop_char (char *); +extern int SLang_pop_uchar (SLtype *); +extern int SLang_pop_short(short *); +extern int SLang_pop_ushort(unsigned short *); +extern int SLang_pop_long(long *); +extern int SLang_pop_ulong(unsigned long *); + +extern int SLang_pop_float(float *); +extern int SLang_pop_double(double *, int *, int *); + /* Pops double *p1 from stack. If *p3 is non-zero, *p1 was derived + from the integer *p2. Returns zero upon success. */ + + extern int SLang_pop_complex (double *, double *); + + extern int SLpop_string (char **); + extern int SLang_pop_string(char **, int *); + /* pops string *p0 from stack. If *p1 is non-zero, the string must be + * freed after its use. DO NOT FREE p0 if *p1 IS ZERO! Returns 0 upon + * success */ + + extern int SLang_push_complex (double, double); + + extern int SLang_push_char (char); + extern int SLang_push_uchar (SLtype); + + extern int SLang_push_integer(int); + extern int SLang_push_uinteger(unsigned int); + /* push integer p1 on stack */ + + extern int SLang_push_short(short); + extern int SLang_push_ushort(unsigned short); + extern int SLang_push_long(long); + extern int SLang_push_ulong(unsigned long); + extern int SLang_push_float(float); + extern int SLang_push_double(double); + /* Push double onto stack */ + + extern int SLang_push_string(char *); + /* Push string p1 onto stack */ + + extern int SLang_push_malloced_string(char *); + /* The normal SLang_push_string pushes an slstring. This one converts + * a normally malloced string to an slstring, and then frees the + * malloced string. So, do NOT use the malloced string after calling + * this routine because it will be freed! The routine returns -1 upon + * error, but the string will be freed. + */ + +extern int SLang_push_null (void); +extern int SLang_pop_null (void); + +extern int SLang_push_value (SLtype type, VOID_STAR); +extern int SLang_pop_value (SLtype type, VOID_STAR); +extern void SLang_free_value (SLtype type, VOID_STAR); + +typedef struct _SLang_Object_Type SLang_Any_Type; + +extern int SLang_pop_anytype (SLang_Any_Type **); +extern int SLang_push_anytype (SLang_Any_Type *); +extern void SLang_free_anytype (SLang_Any_Type *); + +#ifdef _SLANG_SOURCE_ +typedef struct _SLang_Ref_Type SLang_Ref_Type; +#else +typedef int SLang_Ref_Type; +#endif + +extern int SLang_pop_ref (SLang_Ref_Type **); +extern void SLang_free_ref (SLang_Ref_Type *); +extern int SLang_assign_to_ref (SLang_Ref_Type *, SLtype, VOID_STAR); +extern SLang_Name_Type *SLang_pop_function (void); +extern SLang_Name_Type *SLang_get_fun_from_ref (SLang_Ref_Type *); +extern void SLang_free_function (SLang_Name_Type *f); + +/* C structure interface */ +extern int SLang_push_cstruct (VOID_STAR, SLang_CStruct_Field_Type *); +extern int SLang_pop_cstruct (VOID_STAR, SLang_CStruct_Field_Type *); +extern void SLang_free_cstruct (VOID_STAR, SLang_CStruct_Field_Type *); +extern int SLang_assign_cstruct_to_ref (SLang_Ref_Type *, VOID_STAR, SLang_CStruct_Field_Type *); + + extern int SLang_is_defined(char *); + /* Return non-zero is p1 is defined otherwise returns 0. */ + + extern int SLang_run_hooks(char *, unsigned int, ...); + /* calls S-Lang function p1 pushing p2 strings in the variable argument + * list onto the stack first. + * Returns -1 upon error, 1 if hooks exists and it ran, + * or 0 if hook does not exist. Thus it returns non-zero is hook was called. + */ + +/* These functions return 1 if the indicated function exists and the function + * runs without error. If the function does not exist, the function returns + * 0. Otherwise -1 is returned with SLang_Error set appropriately. + */ +extern int SLexecute_function (SLang_Name_Type *); +extern int SLang_execute_function(char *); + + +extern int SLang_end_arg_list (void); +extern int SLang_start_arg_list (void); + +extern void SLang_verror (int, char *, ...) _SLATTRIBUTE_PRINTF(2,3); + +extern void SLang_doerror(char *); + /* set SLang_Error and display p1 as error message */ + +extern int SLang_add_intrinsic_array (char *, /* name */ + SLtype, /* type */ + int, /* readonly */ + VOID_STAR, /* data */ + unsigned int, ...); /* num dims */ + +extern int SLextract_list_element (char *, unsigned int, char, + char *, unsigned int); + +extern void SLexpand_escaped_string (register char *, register char *, + register char *); + +extern SLang_Name_Type *SLang_get_function (char *); +extern void SLang_release_function (SLang_Name_Type *); + +extern int SLreverse_stack (int); +extern int SLroll_stack (int); +/* If argument p is positive, the top p objects on the stack are rolled + * up. If negative, the stack is rolled down. + */ +extern int SLdup_n (int n); +/* Duplicate top n elements of stack */ + +extern int SLang_peek_at_stack1 (void); +extern int SLang_peek_at_stack (void); +/* Returns type of next object on stack-- -1 upon stack underflow. */ +extern void SLmake_lut (unsigned char *, unsigned char *, unsigned char); + + extern int SLang_guess_type (char *); + +extern int SLstruct_create_struct (unsigned int, + char **, + SLtype *, + VOID_STAR *); + +/*}}}*/ + +/*{{{ Misc Functions */ + +/* This is an interface to atexit */ +extern int SLang_add_cleanup_function (void (*)(void)); + +extern char *SLmake_string (char *); +extern char *SLmake_nstring (char *, unsigned int); +/* Returns a null terminated string made from the first n characters of the + * string. + */ + +/* The string created by this routine must be freed by SLang_free_slstring + * and nothing else!! Also these strings must not be modified. Use + * SLmake_string if you intend to modify them!! + */ +extern char *SLang_create_nslstring (char *, unsigned int); +extern char *SLang_create_slstring (char *); +extern void SLang_free_slstring (char *); /* handles NULL */ +extern int SLang_pop_slstring (char **); /* free with SLang_free_slstring */ +extern char *SLang_concat_slstrings (char *a, char *b); +extern char *SLang_create_static_slstring (char *); /* adds a string that will not get deleted */ +extern void SLstring_dump_stats (void); + +/* Binary strings */ +/* The binary string is an opaque type. Use the SLbstring_get_pointer function + * to get a pointer and length. + */ +typedef struct _SLang_BString_Type SLang_BString_Type; +extern unsigned char *SLbstring_get_pointer (SLang_BString_Type *, unsigned int *); + +extern SLang_BString_Type *SLbstring_dup (SLang_BString_Type *); +extern SLang_BString_Type *SLbstring_create (unsigned char *, unsigned int); + +/* The create_malloced function used the first argument which is assumed + * to be a pointer to a len + 1 malloced string. The extra byte is for + * \0 termination. + */ +extern SLang_BString_Type *SLbstring_create_malloced (unsigned char *, unsigned int, int); + +/* Create a bstring from an slstring */ +extern SLang_BString_Type *SLbstring_create_slstring (char *); + +extern void SLbstring_free (SLang_BString_Type *); +extern int SLang_pop_bstring (SLang_BString_Type **); +extern int SLang_push_bstring (SLang_BString_Type *); + +extern char *SLmalloc (unsigned int); +extern char *SLcalloc (unsigned int, unsigned int); +extern void SLfree(char *); /* This function handles NULL */ +extern char *SLrealloc (char *, unsigned int); + +extern char *SLcurrent_time_string (void); + +extern int SLatoi(unsigned char *); +extern long SLatol (unsigned char *); +extern unsigned long SLatoul (unsigned char *); + +extern int SLang_pop_fileptr (SLang_MMT_Type **, FILE **); +extern char *SLang_get_name_from_fileptr (SLang_MMT_Type *); + +typedef struct _SLFile_FD_Type SLFile_FD_Type; +extern SLFile_FD_Type *SLfile_create_fd (char *, int); +extern void SLfile_free_fd (SLFile_FD_Type *); +extern int SLfile_push_fd (SLFile_FD_Type *); +extern int SLfile_pop_fd (SLFile_FD_Type **); +extern int SLfile_get_fd (SLFile_FD_Type *, int *); +extern SLFile_FD_Type *SLfile_dup_fd (SLFile_FD_Type *f0); +extern int SLang_init_posix_io (void); + +typedef double (*SLang_To_Double_Fun_Type)(VOID_STAR); +extern SLang_To_Double_Fun_Type SLarith_get_to_double_fun (SLtype, unsigned int *); + +extern int SLang_set_argc_argv (int, char **); + +/*}}}*/ + +/*{{{ SLang getkey interface Functions */ + +#ifdef REAL_UNIX_SYSTEM +extern int SLang_TT_Baud_Rate; +extern int SLang_TT_Read_FD; +#endif + +extern int SLang_init_tty (int, int, int); +/* Initializes the tty for single character input. If the first parameter *p1 + * is in the range 0-255, it will be used for the abort character; + * otherwise, (unix only) if it is -1, the abort character will be the one + * used by the terminal. If the second parameter p2 is non-zero, flow + * control is enabled. If the last parmeter p3 is zero, output processing + * is NOT turned on. A value of zero is required for the screen management + * routines. Returns 0 upon success. In addition, if SLang_TT_Baud_Rate == + * 0 when this function is called, SLang will attempt to determine the + * terminals baud rate. As far as the SLang library is concerned, if + * SLang_TT_Baud_Rate is less than or equal to zero, the baud rate is + * effectively infinite. + */ + +extern void SLang_reset_tty (void); +/* Resets tty to what it was prior to a call to SLang_init_tty */ +#ifdef REAL_UNIX_SYSTEM +extern void SLtty_set_suspend_state (int); + /* If non-zero argument, terminal driver will be told to react to the + * suspend character. If 0, it will not. + */ +extern int (*SLang_getkey_intr_hook) (void); +#endif + +#define SLANG_GETKEY_ERROR 0xFFFF +extern unsigned int SLang_getkey (void); +/* reads a single key from the tty. If the read fails, 0xFFFF is returned. */ + +#ifdef IBMPC_SYSTEM +extern int SLgetkey_map_to_ansi (int); +#endif + +extern int SLang_ungetkey_string (unsigned char *, unsigned int); +extern int SLang_buffer_keystring (unsigned char *, unsigned int); +extern int SLang_ungetkey (unsigned char); +extern void SLang_flush_input (void); +extern int SLang_input_pending (int); +extern int SLang_Abort_Char; +/* The value of the character (0-255) used to trigger SIGINT */ +extern int SLang_Ignore_User_Abort; +/* If non-zero, pressing the abort character will not result in USER_BREAK + * SLang_Error. */ + +extern int SLang_set_abort_signal (void (*)(int)); +/* If SIGINT is generated, the function p1 will be called. If p1 is NULL + * the SLang_default signal handler is called. This sets SLang_Error to + * USER_BREAK. I suspect most users will simply want to pass NULL. + */ +extern unsigned int SLang_Input_Buffer_Len; + +extern volatile int SLKeyBoard_Quit; + +#ifdef VMS +/* If this function returns -1, ^Y will be added to input buffer. */ +extern int (*SLtty_VMS_Ctrl_Y_Hook) (void); +#endif +/*}}}*/ + +/*{{{ SLang Keymap routines */ + +typedef struct SLKeymap_Function_Type +{ + char *name; + int (*f)(void); +} +SLKeymap_Function_Type; + +#define SLANG_MAX_KEYMAP_KEY_SEQ 14 +typedef struct SLang_Key_Type +{ + struct SLang_Key_Type *next; + union + { + char *s; + FVOID_STAR f; + unsigned int keysym; + } + f; + unsigned char type; /* type of function */ +#define SLKEY_F_INTERPRET 0x01 +#define SLKEY_F_INTRINSIC 0x02 +#define SLKEY_F_KEYSYM 0x03 + unsigned char str[SLANG_MAX_KEYMAP_KEY_SEQ + 1];/* key sequence */ +} +SLang_Key_Type; + +typedef struct SLKeyMap_List_Type +{ + char *name; /* hashed string */ + SLang_Key_Type *keymap; + SLKeymap_Function_Type *functions; /* intrinsic functions */ +} +SLKeyMap_List_Type; + +/* This is arbitrary but I have got to start somewhere */ +#define SLANG_MAX_KEYMAPS 30 +extern SLKeyMap_List_Type SLKeyMap_List[SLANG_MAX_KEYMAPS]; + +extern char *SLang_process_keystring(char *); + +extern int SLkm_define_key (char *, FVOID_STAR, SLKeyMap_List_Type *); + +extern int SLang_define_key(char *, char *, SLKeyMap_List_Type *); +/* Like define_key1 except that p2 is a string that is to be associated with + * a function in the functions field of p3. + */ + +extern int SLkm_define_keysym (char *, unsigned int, SLKeyMap_List_Type *); + +extern void SLang_undefine_key(char *, SLKeyMap_List_Type *); + +extern SLKeyMap_List_Type *SLang_create_keymap(char *, SLKeyMap_List_Type *); +/* create and returns a pointer to a new keymap named p1 created by copying + * keymap p2. If p2 is NULL, it is up to the calling routine to initialize + * the keymap. + */ + +extern char *SLang_make_keystring(unsigned char *); + +extern SLang_Key_Type *SLang_do_key(SLKeyMap_List_Type *, int (*)(void)); +/* read a key using keymap p1 with getkey function p2 */ + +extern + FVOID_STAR + SLang_find_key_function(char *, SLKeyMap_List_Type *); + +extern SLKeyMap_List_Type *SLang_find_keymap(char *); + +extern int SLang_Last_Key_Char; +extern int SLang_Key_TimeOut_Flag; + +/*}}}*/ + +/*{{{ SLang Readline Interface */ + +typedef struct SLang_Read_Line_Type +{ + struct SLang_Read_Line_Type *prev, *next; + unsigned char *buf; + int buf_len; /* number of chars in the buffer */ + int num; /* num and misc are application specific*/ + int misc; +} SLang_Read_Line_Type; + +/* Maximum size of display */ +#define SLRL_DISPLAY_BUFFER_SIZE 256 + +typedef struct +{ + SLang_Read_Line_Type *root, *tail, *last; + unsigned char *buf; /* edit buffer */ + int buf_len; /* sizeof buffer */ + int point; /* current editing point */ + int tab; /* tab width */ + int len; /* current line size */ + + /* display variables */ + int edit_width; /* length of display field */ + int curs_pos; /* current column */ + int start_column; /* column offset of display */ + int dhscroll; /* amount to use for horiz scroll */ + char *prompt; + + FVOID_STAR last_fun; /* last function executed by rl */ + + /* These two contain an image of what is on the display */ + unsigned char upd_buf1[SLRL_DISPLAY_BUFFER_SIZE]; + unsigned char upd_buf2[SLRL_DISPLAY_BUFFER_SIZE]; + unsigned char *old_upd, *new_upd; /* pointers to previous two buffers */ + int new_upd_len, old_upd_len; /* length of output buffers */ + + SLKeyMap_List_Type *keymap; + + /* tty variables */ + unsigned int flags; /* */ +#define SL_RLINE_NO_ECHO 1 +#define SL_RLINE_USE_ANSI 2 +#define SL_RLINE_BLINK_MATCH 4 + unsigned int (*getkey)(void); /* getkey function -- required */ + void (*tt_goto_column)(int); + void (*tt_insert)(char); + void (*update_hook)(unsigned char *, int, int); + /* The update hook is called with a pointer to a buffer p1 that contains + * an image of what the update hook is suppoed to produce. The length + * of the buffer is p2 and after the update, the cursor is to be placed + * in column p3. + */ + /* This function is only called when blinking matches */ + int (*input_pending)(int); + unsigned long reserved[4]; +} SLang_RLine_Info_Type; + +extern int SLang_RL_EOF_Char; + +extern SLang_Read_Line_Type * SLang_rline_save_line (SLang_RLine_Info_Type *); +extern int SLang_init_readline (SLang_RLine_Info_Type *); +extern int SLang_read_line (SLang_RLine_Info_Type *); +extern int SLang_rline_insert (char *); +extern void SLrline_redraw (SLang_RLine_Info_Type *); +extern int SLang_Rline_Quit; + +/*}}}*/ + +/*{{{ Low Level Screen Output Interface */ + +extern unsigned long SLtt_Num_Chars_Output; +extern int SLtt_Baud_Rate; + +typedef unsigned long SLtt_Char_Type; + +#define SLTT_BOLD_MASK 0x01000000UL +#define SLTT_BLINK_MASK 0x02000000UL +#define SLTT_ULINE_MASK 0x04000000UL +#define SLTT_REV_MASK 0x08000000UL +#define SLTT_ALTC_MASK 0x10000000UL + +extern int SLtt_Screen_Rows; +extern int SLtt_Screen_Cols; +extern int SLtt_Term_Cannot_Insert; +extern int SLtt_Term_Cannot_Scroll; +extern int SLtt_Use_Ansi_Colors; +extern int SLtt_Ignore_Beep; +#if defined(REAL_UNIX_SYSTEM) +extern int SLtt_Force_Keypad_Init; +extern int SLang_TT_Write_FD; +#endif + +#ifndef IBMPC_SYSTEM +extern char *SLtt_Graphics_Char_Pairs; +#endif + +#ifndef __GO32__ +#if defined(VMS) || defined(REAL_UNIX_SYSTEM) +extern int SLtt_Blink_Mode; +extern int SLtt_Use_Blink_For_ACS; +extern int SLtt_Newline_Ok; +extern int SLtt_Has_Alt_Charset; +extern int SLtt_Has_Status_Line; /* if 0, NO. If > 0, YES, IF -1, ?? */ +# ifndef VMS +extern int SLtt_Try_Termcap; +# endif +#endif +#endif + +#if defined(IBMPC_SYSTEM) +extern int SLtt_Msdos_Cheap_Video; +#endif + +typedef unsigned short SLsmg_Char_Type; +#define SLSMG_EXTRACT_CHAR(x) ((x) & 0xFF) +#define SLSMG_EXTRACT_COLOR(x) (((x)>>8)&0xFF) +#define SLSMG_BUILD_CHAR(ch,color) (((SLsmg_Char_Type)(unsigned char)(ch))|((color)<<8)) + +extern int SLtt_flush_output (void); +extern void SLtt_set_scroll_region(int, int); +extern void SLtt_reset_scroll_region(void); +extern void SLtt_reverse_video (int); +extern void SLtt_bold_video (void); +extern void SLtt_begin_insert(void); +extern void SLtt_end_insert(void); +extern void SLtt_del_eol(void); +extern void SLtt_goto_rc (int, int); +extern void SLtt_delete_nlines(int); +extern void SLtt_delete_char(void); +extern void SLtt_erase_line(void); +extern void SLtt_normal_video(void); +extern void SLtt_cls(void); +extern void SLtt_beep(void); +extern void SLtt_reverse_index(int); +extern void SLtt_smart_puts(SLsmg_Char_Type *, SLsmg_Char_Type *, int, int); +extern void SLtt_write_string (char *); +extern void SLtt_putchar(char); +extern int SLtt_init_video (void); +extern int SLtt_reset_video (void); +extern void SLtt_get_terminfo(void); +extern void SLtt_get_screen_size (void); +extern int SLtt_set_cursor_visibility (int); + +extern int SLtt_set_mouse_mode (int, int); + +#if defined(VMS) || defined(REAL_UNIX_SYSTEM) +extern int SLtt_initialize (char *); +extern void SLtt_enable_cursor_keys(void); +extern void SLtt_set_term_vtxxx(int *); +extern void SLtt_set_color_esc (int, char *); +extern void SLtt_wide_width(void); +extern void SLtt_narrow_width(void); +extern void SLtt_set_alt_char_set (int); +extern int SLtt_write_to_status_line (char *, int); +extern void SLtt_disable_status_line (void); +# ifdef REAL_UNIX_SYSTEM +/* These are termcap/terminfo routines that assume SLtt_initialize has + * been called. + */ +extern char *SLtt_tgetstr (char *); +extern int SLtt_tgetnum (char *); +extern int SLtt_tgetflag (char *); + +/* The following are terminfo-only routines -- these prototypes will change + * in V2.x. + */ +extern char *SLtt_tigetent (char *); +extern char *SLtt_tigetstr (char *, char **); +extern int SLtt_tigetnum (char *, char **); +# endif +#endif + +extern SLtt_Char_Type SLtt_get_color_object (int); +extern void SLtt_set_color_object (int, SLtt_Char_Type); +extern void SLtt_set_color (int, char *, char *, char *); +extern void SLtt_set_mono (int, char *, SLtt_Char_Type); +extern void SLtt_add_color_attribute (int, SLtt_Char_Type); +extern void SLtt_set_color_fgbg (int, SLtt_Char_Type, SLtt_Char_Type); + +/*}}}*/ + +/*{{{ SLang Preprocessor Interface */ + +typedef struct +{ + int this_level; + int exec_level; + int prev_exec_level; + char preprocess_char; + char comment_char; + unsigned char flags; +#define SLPREP_BLANK_LINES_OK 1 +#define SLPREP_COMMENT_LINES_OK 2 +#define SLPREP_STOP_READING 4 +#define SLPREP_EMBEDDED_TEXT 8 +} +SLPreprocess_Type; + +extern int SLprep_open_prep (SLPreprocess_Type *); +extern void SLprep_close_prep (SLPreprocess_Type *); +extern int SLprep_line_ok (char *, SLPreprocess_Type *); + extern int SLdefine_for_ifdef (char *); + /* Adds a string to the SLang #ifdef preparsing defines. SLang already + defines MSDOS, UNIX, and VMS on the appropriate system. */ +extern int (*SLprep_exists_hook) (char *, char); + +/*}}}*/ + +/*{{{ SLsmg Screen Management Functions */ + +extern void SLsmg_fill_region (int, int, unsigned int, unsigned int, unsigned char); +extern void SLsmg_set_char_set (int); +#ifndef IBMPC_SYSTEM +extern int SLsmg_Scroll_Hash_Border; +#endif +extern int SLsmg_suspend_smg (void); +extern int SLsmg_resume_smg (void); +extern void SLsmg_erase_eol (void); +extern void SLsmg_gotorc (int, int); +extern void SLsmg_erase_eos (void); +extern void SLsmg_reverse_video (void); +extern void SLsmg_set_color (int); +extern void SLsmg_normal_video (void); +extern void SLsmg_printf (char *, ...) _SLATTRIBUTE_PRINTF(1,2); +/* extern void SLsmg_printf (char *, ...) _SLATTRIBUTE_PRINTF(1,2); */ +extern void SLsmg_vprintf (char *, va_list); +extern void SLsmg_write_string (char *); +extern void SLsmg_write_nstring (char *, unsigned int); +extern void SLsmg_write_char (char); +extern void SLsmg_write_nchars (char *, unsigned int); +extern void SLsmg_write_wrapped_string (char *, int, int, unsigned int, unsigned int, int); +extern void SLsmg_cls (void); +extern void SLsmg_refresh (void); +extern void SLsmg_touch_lines (int, unsigned int); +extern void SLsmg_touch_screen (void); +extern int SLsmg_init_smg (void); +extern int SLsmg_reinit_smg (void); +extern void SLsmg_reset_smg (void); +extern SLsmg_Char_Type SLsmg_char_at(void); +extern void SLsmg_set_screen_start (int *, int *); +extern void SLsmg_draw_hline (unsigned int); +extern void SLsmg_draw_vline (int); +extern void SLsmg_draw_object (int, int, unsigned char); +extern void SLsmg_draw_box (int, int, unsigned int, unsigned int); +extern int SLsmg_get_column(void); +extern int SLsmg_get_row(void); +extern void SLsmg_forward (int); +extern void SLsmg_write_color_chars (SLsmg_Char_Type *, unsigned int); +extern unsigned int SLsmg_read_raw (SLsmg_Char_Type *, unsigned int); +extern unsigned int SLsmg_write_raw (SLsmg_Char_Type *, unsigned int); +extern void SLsmg_set_color_in_region (int, int, int, unsigned int, unsigned int); +extern int SLsmg_Display_Eight_Bit; +extern int SLsmg_Tab_Width; + +#define SLSMG_NEWLINE_IGNORED 0 /* default */ +#define SLSMG_NEWLINE_MOVES 1 /* moves to next line, column 0 */ +#define SLSMG_NEWLINE_SCROLLS 2 /* moves but scrolls at bottom of screen */ +#define SLSMG_NEWLINE_PRINTABLE 3 /* prints as ^J */ +extern int SLsmg_Newline_Behavior; + +extern int SLsmg_Backspace_Moves; + +#ifdef IBMPC_SYSTEM +# define SLSMG_HLINE_CHAR 0xC4 +# define SLSMG_VLINE_CHAR 0xB3 +# define SLSMG_ULCORN_CHAR 0xDA +# define SLSMG_URCORN_CHAR 0xBF +# define SLSMG_LLCORN_CHAR 0xC0 +# define SLSMG_LRCORN_CHAR 0xD9 +# define SLSMG_RTEE_CHAR 0xB4 +# define SLSMG_LTEE_CHAR 0xC3 +# define SLSMG_UTEE_CHAR 0xC2 +# define SLSMG_DTEE_CHAR 0xC1 +# define SLSMG_PLUS_CHAR 0xC5 +/* There are several to choose from: 0xB0, 0xB1, and 0xB2 */ +# define SLSMG_CKBRD_CHAR 0xB0 +# define SLSMG_DIAMOND_CHAR 0x04 +# define SLSMG_DEGREE_CHAR 0xF8 +# define SLSMG_PLMINUS_CHAR 0xF1 +# define SLSMG_BULLET_CHAR 0xF9 +# define SLSMG_LARROW_CHAR 0x1B +# define SLSMG_RARROW_CHAR 0x1A +# define SLSMG_DARROW_CHAR 0x19 +# define SLSMG_UARROW_CHAR 0x18 +# define SLSMG_BOARD_CHAR 0xB2 +# define SLSMG_BLOCK_CHAR 0xDB +#else +# if defined(AMIGA) +# define SLSMG_HLINE_CHAR '-' +# define SLSMG_VLINE_CHAR '|' +# define SLSMG_ULCORN_CHAR '+' +# define SLSMG_URCORN_CHAR '+' +# define SLSMG_LLCORN_CHAR '+' +# define SLSMG_LRCORN_CHAR '+' +# define SLSMG_CKBRD_CHAR '#' +# define SLSMG_RTEE_CHAR '+' +# define SLSMG_LTEE_CHAR '+' +# define SLSMG_UTEE_CHAR '+' +# define SLSMG_DTEE_CHAR '+' +# define SLSMG_PLUS_CHAR '+' +# define SLSMG_DIAMOND_CHAR '+' +# define SLSMG_DEGREE_CHAR '\\' +# define SLSMG_PLMINUS_CHAR '#' +# define SLSMG_BULLET_CHAR 'o' +# define SLSMG_LARROW_CHAR '<' +# define SLSMG_RARROW_CHAR '>' +# define SLSMG_DARROW_CHAR 'v' +# define SLSMG_UARROW_CHAR '^' +# define SLSMG_BOARD_CHAR '#' +# define SLSMG_BLOCK_CHAR '#' +# else +# define SLSMG_HLINE_CHAR 'q' +# define SLSMG_VLINE_CHAR 'x' +# define SLSMG_ULCORN_CHAR 'l' +# define SLSMG_URCORN_CHAR 'k' +# define SLSMG_LLCORN_CHAR 'm' +# define SLSMG_LRCORN_CHAR 'j' +# define SLSMG_CKBRD_CHAR 'a' +# define SLSMG_RTEE_CHAR 'u' +# define SLSMG_LTEE_CHAR 't' +# define SLSMG_UTEE_CHAR 'w' +# define SLSMG_DTEE_CHAR 'v' +# define SLSMG_PLUS_CHAR 'n' +# define SLSMG_DIAMOND_CHAR '`' +# define SLSMG_DEGREE_CHAR 'f' +# define SLSMG_PLMINUS_CHAR 'g' +# define SLSMG_BULLET_CHAR '~' +# define SLSMG_LARROW_CHAR ',' +# define SLSMG_RARROW_CHAR '+' +# define SLSMG_DARROW_CHAR '.' +# define SLSMG_UARROW_CHAR '-' +# define SLSMG_BOARD_CHAR 'h' +# define SLSMG_BLOCK_CHAR '0' +# endif /* AMIGA */ +#endif /* IBMPC_SYSTEM */ + +#ifndef IBMPC_SYSTEM +# define SLSMG_COLOR_BLACK 0x000000 +# define SLSMG_COLOR_RED 0x000001 +# define SLSMG_COLOR_GREEN 0x000002 +# define SLSMG_COLOR_BROWN 0x000003 +# define SLSMG_COLOR_BLUE 0x000004 +# define SLSMG_COLOR_MAGENTA 0x000005 +# define SLSMG_COLOR_CYAN 0x000006 +# define SLSMG_COLOR_LGRAY 0x000007 +# define SLSMG_COLOR_GRAY 0x000008 +# define SLSMG_COLOR_BRIGHT_RED 0x000009 +# define SLSMG_COLOR_BRIGHT_GREEN 0x00000A +# define SLSMG_COLOR_BRIGHT_BROWN 0x00000B +# define SLSMG_COLOR_BRIGHT_BLUE 0x00000C +# define SLSMG_COLOR_BRIGHT_CYAN 0x00000D +# define SLSMG_COLOR_BRIGHT_MAGENTA 0x00000E +# define SLSMG_COLOR_BRIGHT_WHITE 0x00000F +#endif + +typedef struct +{ + void (*tt_normal_video)(void); + void (*tt_set_scroll_region)(int, int); + void (*tt_goto_rc)(int, int); + void (*tt_reverse_index)(int); + void (*tt_reset_scroll_region)(void); + void (*tt_delete_nlines)(int); + void (*tt_cls) (void); + void (*tt_del_eol) (void); + void (*tt_smart_puts) (SLsmg_Char_Type *, SLsmg_Char_Type *, int, int); + int (*tt_flush_output) (void); + int (*tt_reset_video) (void); + int (*tt_init_video) (void); + + int *tt_screen_rows; + int *tt_screen_cols; + + int *tt_term_cannot_scroll; + int *tt_has_alt_charset; + int *tt_use_blink_for_acs; + char **tt_graphic_char_pairs; + + long reserved[4]; +} +SLsmg_Term_Type; +extern void SLsmg_set_terminal_info (SLsmg_Term_Type *); + +/*}}}*/ + +/*{{{ SLang Keypad Interface */ + +#define SL_KEY_ERR 0xFFFF + +#define SL_KEY_UP 0x101 +#define SL_KEY_DOWN 0x102 +#define SL_KEY_LEFT 0x103 +#define SL_KEY_RIGHT 0x104 +#define SL_KEY_PPAGE 0x105 +#define SL_KEY_NPAGE 0x106 +#define SL_KEY_HOME 0x107 +#define SL_KEY_END 0x108 +#define SL_KEY_A1 0x109 +#define SL_KEY_A3 0x10A +#define SL_KEY_B2 0x10B +#define SL_KEY_C1 0x10C +#define SL_KEY_C3 0x10D +#define SL_KEY_REDO 0x10E +#define SL_KEY_UNDO 0x10F +#define SL_KEY_BACKSPACE 0x110 +#define SL_KEY_ENTER 0x111 +#define SL_KEY_IC 0x112 +#define SL_KEY_DELETE 0x113 + +#define SL_KEY_F0 0x200 +#define SL_KEY_F(X) (SL_KEY_F0 + X) + +/* I do not intend to use keysymps > 0x1000. Applications can use those. */ +/* Returns 0 upon success or -1 upon error. */ +extern int SLkp_define_keysym (char *, unsigned int); + +/* This function must be called AFTER SLtt_get_terminfo and not before. */ +extern int SLkp_init (void); + +/* By default, SLang_getkey is used as the low-level function. This hook + * allows you to specify something else. + */ +extern void SLkp_set_getkey_function (int (*)(void)); + +/* This function uses SLang_getkey and assumes that what ever initialization + * is required for SLang_getkey has been performed. If you do not want + * SLang_getkey to be used, then specify another function via + * SLkp_set_getkey_function. + */ +extern int SLkp_getkey (void); + +/*}}}*/ + +/*{{{ SLang Scroll Interface */ + +typedef struct _SLscroll_Type +{ + struct _SLscroll_Type *next; + struct _SLscroll_Type *prev; + unsigned int flags; +} +SLscroll_Type; + +typedef struct +{ + unsigned int flags; + SLscroll_Type *top_window_line; /* list element at top of window */ + SLscroll_Type *bot_window_line; /* list element at bottom of window */ + SLscroll_Type *current_line; /* current list element */ + SLscroll_Type *lines; /* first list element */ + unsigned int nrows; /* number of rows in window */ + unsigned int hidden_mask; /* applied to flags in SLscroll_Type */ + unsigned int line_num; /* current line number (visible) */ + unsigned int num_lines; /* total number of lines (visible) */ + unsigned int window_row; /* row of current_line in window */ + unsigned int border; /* number of rows that form scroll border */ + int cannot_scroll; /* should window scroll or recenter */ +} +SLscroll_Window_Type; + +extern int SLscroll_find_top (SLscroll_Window_Type *); +extern int SLscroll_find_line_num (SLscroll_Window_Type *); +extern unsigned int SLscroll_next_n (SLscroll_Window_Type *, unsigned int); +extern unsigned int SLscroll_prev_n (SLscroll_Window_Type *, unsigned int); +extern int SLscroll_pageup (SLscroll_Window_Type *); +extern int SLscroll_pagedown (SLscroll_Window_Type *); + +/*}}}*/ + +/*{{{ Signal Routines */ + +typedef void SLSig_Fun_Type (int); +extern SLSig_Fun_Type *SLsignal (int, SLSig_Fun_Type *); +extern SLSig_Fun_Type *SLsignal_intr (int, SLSig_Fun_Type *); +extern int SLsig_block_signals (void); +extern int SLsig_unblock_signals (void); +extern int SLsystem (char *); + +extern char *SLerrno_strerror (int); +extern int SLerrno_set_errno (int); + +/*}}}*/ + +/*{{{ Interpreter Macro Definitions */ + +/* The definitions here are for objects that may be on the run-time stack. + * They are actually sub_types of literal and data main_types. The actual + * numbers are historical. + */ +#define SLANG_UNDEFINED_TYPE 0x00 /* MUST be 0 */ +#define SLANG_VOID_TYPE 0x01 /* also matches ANY type */ +#define SLANG_INT_TYPE 0x02 +#define SLANG_DOUBLE_TYPE 0x03 +#define SLANG_CHAR_TYPE 0x04 +#define SLANG_INTP_TYPE 0x05 +/* An object of SLANG_INTP_TYPE should never really occur on the stack. Rather, + * the integer to which it refers will be there instead. It is defined here + * because it is a valid type for MAKE_VARIABLE. + */ +#define SLANG_REF_TYPE 0x06 +/* SLANG_REF_TYPE refers to an object on the stack that is a pointer (reference) + * to some other object. + */ +#define SLANG_COMPLEX_TYPE 0x07 +#define SLANG_NULL_TYPE 0x08 +#define SLANG_UCHAR_TYPE 0x09 +#define SLANG_SHORT_TYPE 0x0A +#define SLANG_USHORT_TYPE 0x0B +#define SLANG_UINT_TYPE 0x0C +#define SLANG_LONG_TYPE 0x0D +#define SLANG_ULONG_TYPE 0x0E +#define SLANG_STRING_TYPE 0x0F +#define SLANG_FLOAT_TYPE 0x10 +#define SLANG_STRUCT_TYPE 0x11 +#define SLANG_ISTRUCT_TYPE 0x12 +#define SLANG_ARRAY_TYPE 0x20 +#define SLANG_DATATYPE_TYPE 0x21 +#define SLANG_FILE_PTR_TYPE 0x22 +#define SLANG_ASSOC_TYPE 0x23 +#define SLANG_ANY_TYPE 0x24 +#define SLANG_BSTRING_TYPE 0x25 +#define SLANG_FILE_FD_TYPE 0x26 + +#define _SLANG_MIN_UNUSED_TYPE 0x27 + +/* Compatibility */ +#ifdef FLOAT_TYPE +# undef FLOAT_TYPE +#endif +#define VOID_TYPE SLANG_VOID_TYPE +#define INT_TYPE SLANG_INT_TYPE +#define INTP_TYPE SLANG_INTP_TYPE +#define FLOAT_TYPE SLANG_DOUBLE_TYPE +#define ARRAY_TYPE SLANG_ARRAY_TYPE +#define CHAR_TYPE SLANG_CHAR_TYPE +#define STRING_TYPE SLANG_STRING_TYPE + +/* I am reserving values greater than or equal to 128 for user applications. + * The first 127 are reserved for S-Lang. + */ + +/* Binary and Unary Subtypes */ +/* Since the application can define new types and can overload the binary + * and unary operators, these definitions must be present in this file. + * The current implementation assumes both unary and binary are distinct. + */ +#define SLANG_PLUS 0x01 +#define SLANG_MINUS 0x02 +#define SLANG_TIMES 0x03 +#define SLANG_DIVIDE 0x04 +#define SLANG_EQ 0x05 +#define SLANG_NE 0x06 +#define SLANG_GT 0x07 +#define SLANG_GE 0x08 +#define SLANG_LT 0x09 +#define SLANG_LE 0x0A +#define SLANG_POW 0x0B +#define SLANG_OR 0x0C +#define SLANG_AND 0x0D +#define SLANG_BAND 0x0E +#define SLANG_BOR 0x0F +#define SLANG_BXOR 0x10 +#define SLANG_SHL 0x11 +#define SLANG_SHR 0x12 +#define SLANG_MOD 0x13 + +/* UNARY subtypes (may be overloaded) */ +#define SLANG_PLUSPLUS 0x20 +#define SLANG_MINUSMINUS 0x21 +#define SLANG_ABS 0x22 +#define SLANG_SIGN 0x23 +#define SLANG_SQR 0x24 +#define SLANG_MUL2 0x25 +#define SLANG_CHS 0x26 +#define SLANG_NOT 0x27 +#define SLANG_BNOT 0x28 + +extern char *SLang_Error_Message; + +int SLadd_intrinsic_variable (char *, VOID_STAR, unsigned char, int); +int SLadd_intrinsic_function (char *, FVOID_STAR, unsigned char, unsigned int,...); + +int SLns_add_intrinsic_variable (SLang_NameSpace_Type *, char *, VOID_STAR, unsigned char, int); +int SLns_add_intrinsic_function (SLang_NameSpace_Type *, char *, FVOID_STAR, unsigned char, unsigned int,...); + +#define MAKE_INTRINSIC_N(n,f,out,in,a1,a2,a3,a4,a5,a6,a7) \ + {(n), NULL, SLANG_INTRINSIC, (FVOID_STAR) (f), \ + {a1,a2,a3,a4,a5,a6,a7}, (in), (out)} + +#define MAKE_INTRINSIC_7(n,f,out,a1,a2,a3,a4,a5,a6,a7) \ + MAKE_INTRINSIC_N(n,f,out,7,a1,a2,a3,a4,a5,a6,a7) +#define MAKE_INTRINSIC_6(n,f,out,a1,a2,a3,a4,a5,a6) \ + MAKE_INTRINSIC_N(n,f,out,6,a1,a2,a3,a4,a5,a6,0) +#define MAKE_INTRINSIC_5(n,f,out,a1,a2,a3,a4,a5) \ + MAKE_INTRINSIC_N(n,f,out,5,a1,a2,a3,a4,a5,0,0) +#define MAKE_INTRINSIC_4(n,f,out,a1,a2,a3,a4) \ + MAKE_INTRINSIC_N(n,f,out,4,a1,a2,a3,a4,0,0,0) +#define MAKE_INTRINSIC_3(n,f,out,a1,a2,a3) \ + MAKE_INTRINSIC_N(n,f,out,3,a1,a2,a3,0,0,0,0) +#define MAKE_INTRINSIC_2(n,f,out,a1,a2) \ + MAKE_INTRINSIC_N(n,f,out,2,a1,a2,0,0,0,0,0) +#define MAKE_INTRINSIC_1(n,f,out,a1) \ + MAKE_INTRINSIC_N(n,f,out,1,a1,0,0,0,0,0,0) +#define MAKE_INTRINSIC_0(n,f,out) \ + MAKE_INTRINSIC_N(n,f,out,0,0,0,0,0,0,0,0) + +#define MAKE_INTRINSIC_S(n,f,r) \ + MAKE_INTRINSIC_1(n,f,r,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_I(n,f,r) \ + MAKE_INTRINSIC_1(n,f,r,SLANG_INT_TYPE) + +#define MAKE_INTRINSIC_SS(n,f,r) \ + MAKE_INTRINSIC_2(n,f,r,SLANG_STRING_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_SI(n,f,r) \ + MAKE_INTRINSIC_2(n,f,r,SLANG_STRING_TYPE,SLANG_INT_TYPE) +#define MAKE_INTRINSIC_IS(n,f,r) \ + MAKE_INTRINSIC_2(n,f,r,SLANG_INT_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_II(n,f,r) \ + MAKE_INTRINSIC_2(n,f,r,SLANG_INT_TYPE,SLANG_INT_TYPE) + +#define MAKE_INTRINSIC_SSS(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_STRING_TYPE,SLANG_STRING_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_SSI(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_STRING_TYPE,SLANG_STRING_TYPE,SLANG_INT_TYPE) +#define MAKE_INTRINSIC_SIS(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_STRING_TYPE,SLANG_INT_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_SII(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_STRING_TYPE,SLANG_INT_TYPE,SLANG_INT_TYPE) +#define MAKE_INTRINSIC_ISS(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_INT_TYPE,SLANG_STRING_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_ISI(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_INT_TYPE,SLANG_STRING_TYPE,SLANG_INT_TYPE) +#define MAKE_INTRINSIC_IIS(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_INT_TYPE,SLANG_INT_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_III(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_INT_TYPE,SLANG_INT_TYPE,SLANG_INT_TYPE) + +#define MAKE_INTRINSIC(n, f, out, in) \ + MAKE_INTRINSIC_N(n,f,out,in,0,0,0,0,0,0,0) + +#define MAKE_VARIABLE(n, v, t, r) \ + {n, NULL, SLANG_IVARIABLE + (r), (VOID_STAR)(v), (t)} + +#define MAKE_APP_UNARY(n,op) \ + {(n), NULL, SLANG_APP_UNARY, (op)} + +#define MAKE_MATH_UNARY(n,op) \ + {(n), NULL, SLANG_MATH_UNARY, (op)} + +#define MAKE_ICONSTANT(n,val) \ + {(n),NULL, SLANG_ICONSTANT, (val)} + +#define MAKE_DCONSTANT(n,val) \ + {(n),NULL, SLANG_DCONSTANT, (val)} + +#ifndef offsetof +# define offsetof(T,F) ((unsigned int)((char *)&((T *)0L)->F - (char *)0L)) +#endif +#define MAKE_ISTRUCT_FIELD(s,f,n,t,r) {(n), offsetof(s,f), (t), (r)} +#define MAKE_CSTRUCT_FIELD(s,f,n,t,r) {(n), offsetof(s,f), (t), (r)} +#define MAKE_CSTRUCT_INT_FIELD(s,f,n,r) {(n), offsetof(s,f),\ + (sizeof(((s*)0L)->f)==sizeof(int))?(SLANG_INT_TYPE): \ + (sizeof(((s*)0L)->f)==sizeof(short))?(SLANG_SHORT_TYPE): \ + (sizeof(((s*)0L)->f)==sizeof(char))?(SLANG_CHAR_TYPE): \ + SLANG_LONG_TYPE, (r)\ +} + +#define SLANG_END_TABLE {NULL} +#define SLANG_END_INTRIN_FUN_TABLE MAKE_INTRINSIC_0(NULL,NULL,0) +#define SLANG_END_DCONST_TABLE MAKE_DCONSTANT(NULL,0) +#define SLANG_END_MATH_UNARY_TABLE MAKE_MATH_UNARY(NULL,0) +#define SLANG_END_INTRIN_VAR_TABLE MAKE_VARIABLE(NULL,NULL,0,0) +#define SLANG_END_ICONST_TABLE MAKE_ICONSTANT(NULL,0) +#define SLANG_END_ISTRUCT_TABLE {NULL, 0, 0, 0} +#define SLANG_END_CSTRUCT_TABLE {NULL, 0, 0, 0} + + +/*}}}*/ + +/*{{{ Upper/Lowercase Functions */ + +extern void SLang_define_case(int *, int *); +extern void SLang_init_case_tables (void); + +extern unsigned char _SLChg_UCase_Lut[256]; +extern unsigned char _SLChg_LCase_Lut[256]; +#define UPPER_CASE(x) (_SLChg_UCase_Lut[(unsigned char) (x)]) +#define LOWER_CASE(x) (_SLChg_LCase_Lut[(unsigned char) (x)]) +#define CHANGE_CASE(x) (((x) == _SLChg_LCase_Lut[(unsigned char) (x)]) ?\ + _SLChg_UCase_Lut[(unsigned char) (x)] : _SLChg_LCase_Lut[(unsigned char) (x)]) + +/*}}}*/ + +/*{{{ Regular Expression Interface */ + +typedef struct +{ + /* These must be set by calling routine. */ + unsigned char *pat; /* regular expression pattern */ + unsigned char *buf; /* buffer for compiled regexp */ + unsigned int buf_len; /* length of buffer */ + int case_sensitive; /* 1 if match is case sensitive */ + + /* The rest are set by SLang_regexp_compile */ + + int must_match; /* 1 if line must contain substring */ + int must_match_bol; /* true if it must match beginning of line */ + unsigned char must_match_str[16]; /* 15 char null term substring */ + int osearch; /* 1 if ordinary search suffices */ + unsigned int min_length; /* minimum length the match must be */ + int beg_matches[10]; /* offset of start of \( */ + unsigned int end_matches[10]; /* length of nth submatch + * Note that the entire match corresponds + * to \0 + */ + int offset; /* offset to be added to beg_matches */ + int reserved[10]; +} SLRegexp_Type; + +extern unsigned char *SLang_regexp_match(unsigned char *, + unsigned int, + SLRegexp_Type *); + +/* Returns 0 upon success. If failure, the offset into the + * pattern is returned (start = 1). + */ +extern int SLang_regexp_compile (SLRegexp_Type *); +extern char *SLregexp_quote_string (char *, char *, unsigned int); + +/*}}}*/ + +/*{{{ SLang Command Interface */ + +struct _SLcmd_Cmd_Type; /* Pre-declaration is needed below */ +typedef struct +{ + struct _SLcmd_Cmd_Type *table; + int argc; + /* Version 2.0 needs to use a union!! */ + char **string_args; + int *int_args; + double *double_args; + unsigned char *arg_type; + unsigned long reserved[4]; +} SLcmd_Cmd_Table_Type; + +typedef struct _SLcmd_Cmd_Type +{ + int (*cmdfun)(int, SLcmd_Cmd_Table_Type *); + char *cmd; + char *arg_type; +} SLcmd_Cmd_Type; + +extern int SLcmd_execute_string (char *, SLcmd_Cmd_Table_Type *); + +/*}}}*/ + +/*{{{ SLang Search Interface */ + +typedef struct +{ + int cs; /* case sensitive */ + unsigned char key[256]; + int ind[256]; + int key_len; + int dir; +} SLsearch_Type; + +extern int SLsearch_init (char *, int, int, SLsearch_Type *); +/* This routine must first be called before any search can take place. + * The second parameter specifies the direction of the search: greater than + * zero for a forwrd search and less than zero for a backward search. The + * third parameter specifies whether the search is case sensitive or not. + * The last parameter is a pointer to a structure that is filled by this + * function and it is this structure that must be passed to SLsearch. + */ + +extern unsigned char *SLsearch (unsigned char *, unsigned char *, SLsearch_Type *); +/* To use this routine, you must first call 'SLsearch_init'. Then the first + * two parameters p1 and p2 serve to define the region over which the search + * is to take place. The third parameter is the structure that was previously + * initialized by SLsearch_init. + * + * The routine returns a pointer to the match if found otherwise it returns + * NULL. + */ + +/*}}}*/ + +/*{{{ SLang Pathname Interface */ + +/* These function return pointers to the original space */ +extern char *SLpath_basename (char *); +extern char *SLpath_extname (char *); + +extern int SLpath_is_absolute_path (char *); + +/* Get and set the character delimiter for search paths */ +extern int SLpath_get_delimiter (void); +extern int SLpath_set_delimiter (int); + +/* search path for loading .sl files */ +extern int SLpath_set_load_path (char *); +/* search path for loading .sl files --- returns slstring */ +extern char *SLpath_get_load_path (void); + +/* These return malloced strings--- NOT slstrings */ +extern char *SLpath_dircat (char *, char *); +extern char *SLpath_find_file_in_path (char *, char *); +extern char *SLpath_dirname (char *); +extern int SLpath_file_exists (char *); +extern char *SLpath_pathname_sans_extname (char *); + +/*}}}*/ + +extern int SLang_set_module_load_path (char *); + +#define SLANG_MODULE(name) \ + extern int init_##name##_module_ns (char *); \ + extern void deinit_##name##_module (void) + +#if 0 +{ +#endif +#ifdef __cplusplus +} +#endif + +#endif /* _DAVIS_SLANG_H_ */ diff --git a/libslang/src/slarith.c b/libslang/src/slarith.c new file mode 100644 index 0000000..cff9ab0 --- /dev/null +++ b/libslang/src/slarith.c @@ -0,0 +1,1752 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include + +#ifdef HAVE_LOCALE_H +# include +#endif + +#include "slang.h" +#include "_slang.h" + +/* + * This file defines binary and unary operations on all integer types. + * Supported types include: + * + * SLANG_CHAR_TYPE (char) + * SLANG_SHORT_TYPE (short) + * SLANG_INT_TYPE (int) + * SLANG_LONG_TYPE (long) + * SLANG_FLOAT_TYPE (float) + * SLANG_DOUBLE_TYPE (double) + * + * as well as unsigned types. The result-type of an arithmentic operation + * will depend upon the data types involved. I am going to distinguish + * between the boolean operations such as `and' and `or' from the arithmetic + * operations such as `plus'. Since the result of a boolean operation is + * either 1 or 0, a boolean result will be represented by SLANG_CHAR_TYPE. + * Ordinarily I would use an integer but for arrays it makes more sense to + * use a character data type. + * + * So, the following will be assumed (`+' is any arithmetic operator) + * + * char + char = int + * char|short + short = int + * char|short|int + int = int + * char|short|int|long + long = long + * char|short|int|long|float + float = float + * char|short|int|long|float|double + double = double + * + * In the actual implementation, a brute force approach is avoided. Such + * an approach would mean defining different functions for all possible + * combinations of types. Including the unsigned types, and not including + * the complex number type, there are 10 arithmetic types and 10*10=100 + * different combinations of types. Clearly this would be too much. + * + * One approach would be to define binary functions only between operands of + * the same type and then convert types as appropriate. This would require + * just 6 such functions (int, uint, long, ulong, float, double). + * However, many conversion functions are going to be required, particularly + * since we are going to allow typecasting from one arithmetic to another. + * Since the bit pattern of signed and unsigned types are the same, and only + * the interpretation differs, there will be no functions to convert between + * signed and unsigned forms of a given type. + */ + +#define MAX_ARITHMETIC_TYPES 10 + +unsigned char _SLarith_Arith_Types[] = +{ + SLANG_CHAR_TYPE, + SLANG_UCHAR_TYPE, + SLANG_SHORT_TYPE, + SLANG_USHORT_TYPE, + SLANG_INT_TYPE, + SLANG_UINT_TYPE, + SLANG_LONG_TYPE, + SLANG_ULONG_TYPE, + SLANG_FLOAT_TYPE, + SLANG_DOUBLE_TYPE, + 0 +}; + +/* Here are a bunch of functions to convert from one type to another. To + * facilitate the process, a macros will be used. + */ + +#define DEFUN_1(f,from_type,to_type) \ +static void f (to_type *y, from_type *x, unsigned int n) \ +{ \ + unsigned int i; \ + for (i = 0; i < n; i++) y[i] = (to_type) x[i]; \ +} + +#define DEFUN_2(f,from_type,to_type,copy_fun) \ +static VOID_STAR f (VOID_STAR xp, unsigned int n) \ +{ \ + from_type *x; \ + to_type *y; \ + x = (from_type *) xp; \ + if (NULL == (y = (to_type *) SLmalloc (sizeof (to_type) * n))) return NULL; \ + copy_fun (y, x, n); \ + return (VOID_STAR) y; \ +} +typedef VOID_STAR (*Convert_Fun_Type)(VOID_STAR, unsigned int); + +DEFUN_1(copy_char_to_char,char,char) +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_char_to_short,char,short) +DEFUN_1(copy_char_to_ushort,char,unsigned short) +#else +# define copy_char_to_short copy_char_to_int +# define copy_char_to_ushort copy_char_to_uint +#endif +DEFUN_1(copy_char_to_int,char,int) +DEFUN_1(copy_char_to_uint,char,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_char_to_long,char,long) +DEFUN_1(copy_char_to_ulong,char,unsigned long) +#else +# define copy_char_to_long copy_char_to_int +# define copy_char_to_ulong copy_char_to_uint +#endif +#if SLANG_HAS_FLOAT +DEFUN_1(copy_char_to_float,char,float) +DEFUN_1(copy_char_to_double,char,double) +#endif + +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_uchar_to_short,unsigned char,short) +DEFUN_1(copy_uchar_to_ushort,unsigned char,unsigned short) +#else +# define copy_uchar_to_short copy_uchar_to_int +# define copy_uchar_to_ushort copy_uchar_to_uint +#endif +DEFUN_1(copy_uchar_to_int,unsigned char,int) +DEFUN_1(copy_uchar_to_uint,unsigned char,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_uchar_to_long,unsigned char,long) +DEFUN_1(copy_uchar_to_ulong,unsigned char,unsigned long) +#else +# define copy_uchar_to_long copy_uchar_to_int +# define copy_uchar_to_ulong copy_uchar_to_uint +#endif +#if SLANG_HAS_FLOAT +DEFUN_1(copy_uchar_to_float,unsigned char,float) +DEFUN_1(copy_uchar_to_double,unsigned char,double) +#endif + +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_short_to_char,short,char) +DEFUN_1(copy_short_to_uchar,short,unsigned char) +DEFUN_1(copy_short_to_short,short,short) +DEFUN_1(copy_short_to_int,short,int) +DEFUN_1(copy_short_to_uint,short,unsigned int) +DEFUN_1(copy_short_to_long,short,long) +DEFUN_1(copy_short_to_ulong,short,unsigned long) +#if SLANG_HAS_FLOAT +DEFUN_1(copy_short_to_float,short,float) +DEFUN_1(copy_short_to_double,short,double) +#endif +DEFUN_1(copy_ushort_to_char,unsigned short,char) +DEFUN_1(copy_ushort_to_uchar,unsigned short,unsigned char) +DEFUN_1(copy_ushort_to_int,unsigned short,int) +DEFUN_1(copy_ushort_to_uint,unsigned short,unsigned int) +DEFUN_1(copy_ushort_to_long,unsigned short,long) +DEFUN_1(copy_ushort_to_ulong,unsigned short,unsigned long) +#if SLANG_HAS_FLOAT +DEFUN_1(copy_ushort_to_float,unsigned short,float) +DEFUN_1(copy_ushort_to_double,unsigned short,double) +#endif +#else +# define copy_short_to_char copy_int_to_char +# define copy_short_to_uchar copy_int_to_uchar +# define copy_short_to_short copy_int_to_int +# define copy_short_to_int copy_int_to_int +# define copy_short_to_uint copy_int_to_int +# define copy_short_to_long copy_int_to_long +# define copy_short_to_ulong copy_int_to_ulong +#if SLANG_HAS_FLOAT +# define copy_short_to_float copy_int_to_float +# define copy_short_to_double copy_int_to_double +#endif +# define copy_ushort_to_char copy_uint_to_char +# define copy_ushort_to_uchar copy_uint_to_uchar +# define copy_ushort_to_int copy_int_to_int +# define copy_ushort_to_uint copy_int_to_int +# define copy_ushort_to_long copy_uint_to_long +# define copy_ushort_to_ulong copy_uint_to_ulong +#if SLANG_HAS_FLOAT +# define copy_ushort_to_float copy_uint_to_float +# define copy_ushort_to_double copy_uint_to_double +#endif +#endif + +DEFUN_1(copy_int_to_char,int,char) +DEFUN_1(copy_int_to_uchar,int,unsigned char) +DEFUN_1(copy_uint_to_char,unsigned int,char) +DEFUN_1(copy_uint_to_uchar,unsigned int,unsigned char) +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_int_to_short,int,short) +DEFUN_1(copy_int_to_ushort,int,unsigned short) +DEFUN_1(copy_uint_to_short,unsigned int,short) +DEFUN_1(copy_uint_to_ushort,unsigned int,unsigned short) +#else +# define copy_int_to_short copy_int_to_int +# define copy_int_to_ushort copy_int_to_int +# define copy_uint_to_short copy_int_to_int +# define copy_uint_to_ushort copy_int_to_int +#endif +DEFUN_1(copy_int_to_int,int,int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_int_to_long,int,long) +DEFUN_1(copy_int_to_ulong,int,unsigned long) +DEFUN_1(copy_uint_to_long,unsigned int,long) +DEFUN_1(copy_uint_to_ulong,unsigned int,unsigned long) +#else +# define copy_int_to_long copy_int_to_int +# define copy_int_to_ulong copy_int_to_int +# define copy_uint_to_long copy_int_to_int +# define copy_uint_to_ulong copy_int_to_int +#endif +#if SLANG_HAS_FLOAT +DEFUN_1(copy_int_to_float,int,float) +DEFUN_1(copy_int_to_double,int,double) +DEFUN_1(copy_uint_to_float,unsigned int,float) +DEFUN_1(copy_uint_to_double,unsigned int,double) +#endif + +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_long_to_char,long,char) +DEFUN_1(copy_long_to_uchar,long,unsigned char) +DEFUN_1(copy_long_to_short,long,short) +DEFUN_1(copy_long_to_ushort,long,unsigned short) +DEFUN_1(copy_long_to_int,long,int) +DEFUN_1(copy_long_to_uint,long,unsigned int) +DEFUN_1(copy_long_to_long,long,long) +DEFUN_1(copy_ulong_to_char,unsigned long,char) +DEFUN_1(copy_ulong_to_uchar,unsigned long,unsigned char) +DEFUN_1(copy_ulong_to_short,unsigned long,short) +DEFUN_1(copy_ulong_to_ushort,unsigned long,unsigned short) +DEFUN_1(copy_ulong_to_int,unsigned long,int) +DEFUN_1(copy_ulong_to_uint,unsigned long,unsigned int) +#if SLANG_HAS_FLOAT +DEFUN_1(copy_long_to_float,long,float) +DEFUN_1(copy_long_to_double,long,double) +DEFUN_1(copy_ulong_to_float,unsigned long,float) +DEFUN_1(copy_ulong_to_double,unsigned long,double) +#endif +#else +#define copy_long_to_char copy_int_to_char +#define copy_long_to_uchar copy_int_to_uchar +#define copy_long_to_short copy_int_to_short +#define copy_long_to_ushort copy_int_to_ushort +#define copy_long_to_int copy_int_to_int +#define copy_long_to_uint copy_int_to_int +#define copy_long_to_long copy_int_to_int +#define copy_long_to_float copy_int_to_float +#define copy_long_to_double copy_int_to_double +#define copy_ulong_to_char copy_uint_to_char +#define copy_ulong_to_uchar copy_uint_to_uchar +#define copy_ulong_to_short copy_uint_to_short +#define copy_ulong_to_ushort copy_uint_to_ushort +#define copy_ulong_to_int copy_int_to_int +#define copy_ulong_to_uint copy_int_to_int +#define copy_ulong_to_float copy_uint_to_float +#define copy_ulong_to_double copy_uint_to_double +#endif + +#if SLANG_HAS_FLOAT +DEFUN_1(copy_float_to_char,float,char) +DEFUN_1(copy_float_to_uchar,float,unsigned char) +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_float_to_short,float,short) +DEFUN_1(copy_float_to_ushort,float,unsigned short) +#else +# define copy_float_to_short copy_float_to_int +# define copy_float_to_ushort copy_float_to_uint +#endif +DEFUN_1(copy_float_to_int,float,int) +DEFUN_1(copy_float_to_uint,float,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_float_to_long,float,long) +DEFUN_1(copy_float_to_ulong,float,unsigned long) +#else +# define copy_float_to_long copy_float_to_int +# define copy_float_to_ulong copy_float_to_uint +#endif + +DEFUN_1(copy_float_to_float,float,float) + +static void copy_float_to_double (double *y, float *x, unsigned int n) +{ + unsigned int i; + for (i = 0; i < n; i++) + y[i] = (double) x[i]; +} + + +/* DEFUN_1(copy_float_to_double,float,double) */ + +DEFUN_1(copy_double_to_char,double,char) +DEFUN_1(copy_double_to_uchar,double,unsigned char) +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_double_to_short,double,short) +DEFUN_1(copy_double_to_ushort,double,unsigned short) +#else +# define copy_double_to_short copy_double_to_int +# define copy_double_to_ushort copy_double_to_uint +#endif +DEFUN_1(copy_double_to_int,double,int) +DEFUN_1(copy_double_to_uint,double,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_double_to_long,double,long) +DEFUN_1(copy_double_to_ulong,double,unsigned long) +#else +# define copy_double_to_long copy_double_to_int +# define copy_double_to_ulong copy_double_to_uint +#endif +DEFUN_1(copy_double_to_float,double,float) +DEFUN_1(copy_double_to_double,double,double) +#endif /* SLANG_HAS_FLOAT */ + +DEFUN_2(char_to_int,char,int,copy_char_to_int) +DEFUN_2(char_to_uint,char,unsigned int,copy_char_to_uint) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(char_to_long,char,long,copy_char_to_long) +DEFUN_2(char_to_ulong,char,unsigned long,copy_char_to_ulong) +#else +# define char_to_long char_to_int +# define char_to_ulong char_to_uint +#endif +#if SLANG_HAS_FLOAT +DEFUN_2(char_to_float,char,float,copy_char_to_float) +DEFUN_2(char_to_double,char,double,copy_char_to_double) +#endif + +DEFUN_2(uchar_to_int,unsigned char,int,copy_uchar_to_int) +DEFUN_2(uchar_to_uint,unsigned char,unsigned int,copy_uchar_to_uint) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(uchar_to_long,unsigned char,long,copy_uchar_to_long) +DEFUN_2(uchar_to_ulong,unsigned char,unsigned long,copy_uchar_to_ulong) +#else +# define uchar_to_long uchar_to_int +# define uchar_to_ulong uchar_to_uint +#endif +#if SLANG_HAS_FLOAT +DEFUN_2(uchar_to_float,unsigned char,float,copy_uchar_to_float) +DEFUN_2(uchar_to_double,unsigned char,double,copy_uchar_to_double) +#endif + +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_2(short_to_int,short,int,copy_short_to_int) +DEFUN_2(short_to_uint,short,unsigned int,copy_short_to_uint) +DEFUN_2(short_to_long,short,long,copy_short_to_long) +DEFUN_2(short_to_ulong,short,unsigned long,copy_short_to_ulong) +#if SLANG_HAS_FLOAT +DEFUN_2(short_to_float,short,float,copy_short_to_float) +DEFUN_2(short_to_double,short,double,copy_short_to_double) +#endif +DEFUN_2(ushort_to_int,unsigned short,int,copy_ushort_to_int) +DEFUN_2(ushort_to_uint,unsigned short,unsigned int,copy_ushort_to_uint) +DEFUN_2(ushort_to_long,unsigned short,long,copy_ushort_to_long) +DEFUN_2(ushort_to_ulong,unsigned short,unsigned long,copy_ushort_to_ulong) +#if SLANG_HAS_FLOAT +DEFUN_2(ushort_to_float,unsigned short,float,copy_ushort_to_float) +DEFUN_2(ushort_to_double,unsigned short,double,copy_ushort_to_double) +#endif +#else +# define short_to_int NULL +# define short_to_uint NULL +# define short_to_long int_to_long +# define short_to_ulong int_to_ulong +#if SLANG_HAS_FLOAT +# define short_to_float int_to_float +# define short_to_double int_to_double +#endif +# define ushort_to_int NULL +# define ushort_to_uint NULL +# define ushort_to_long uint_to_long +# define ushort_to_ulong uint_to_ulong +#if SLANG_HAS_FLOAT +# define ushort_to_float uint_to_float +# define ushort_to_double uint_to_double +#endif +#endif + +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(int_to_long,int,long,copy_int_to_long) +DEFUN_2(int_to_ulong,int,unsigned long,copy_int_to_ulong) +#else +# define int_to_long NULL +# define int_to_ulong NULL +#endif +#if SLANG_HAS_FLOAT +DEFUN_2(int_to_float,int,float,copy_int_to_float) +DEFUN_2(int_to_double,int,double,copy_int_to_double) +#endif + +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(uint_to_long,unsigned int,long,copy_uint_to_long) +DEFUN_2(uint_to_ulong,unsigned int,unsigned long,copy_uint_to_ulong) +#else +# define uint_to_long NULL +# define uint_to_ulong NULL +#endif +#if SLANG_HAS_FLOAT +DEFUN_2(uint_to_float,unsigned int,float,copy_uint_to_float) +DEFUN_2(uint_to_double,unsigned int,double,copy_uint_to_double) + +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(long_to_float,long,float,copy_long_to_float) +DEFUN_2(long_to_double,long,double,copy_long_to_double) +DEFUN_2(ulong_to_float,unsigned long,float,copy_ulong_to_float) +DEFUN_2(ulong_to_double,unsigned long,double,copy_ulong_to_double) +#else +# define long_to_float int_to_float +# define long_to_double int_to_double +# define ulong_to_float uint_to_float +# define ulong_to_double uint_to_double +#endif + +DEFUN_2(float_to_double,float,double,copy_float_to_double) + +#define TO_DOUBLE_FUN(name,type) \ +static double name (VOID_STAR x) { return (double) *(type *) x; } +TO_DOUBLE_FUN(char_to_one_double,char) +TO_DOUBLE_FUN(uchar_to_one_double,unsigned char) +#if SIZEOF_INT != SIZEOF_SHORT +TO_DOUBLE_FUN(short_to_one_double,short) +TO_DOUBLE_FUN(ushort_to_one_double,unsigned short) +#else +# define short_to_one_double int_to_one_double +# define ushort_to_one_double uint_to_one_double +#endif +TO_DOUBLE_FUN(int_to_one_double,int) +TO_DOUBLE_FUN(uint_to_one_double,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +TO_DOUBLE_FUN(long_to_one_double,long) +TO_DOUBLE_FUN(ulong_to_one_double,unsigned long) +#else +# define long_to_one_double int_to_one_double +# define ulong_to_one_double uint_to_one_double +#endif +TO_DOUBLE_FUN(float_to_one_double,float) +TO_DOUBLE_FUN(double_to_one_double,double) + +SLang_To_Double_Fun_Type +SLarith_get_to_double_fun (unsigned char type, unsigned int *sizeof_type) +{ + unsigned int da; + SLang_To_Double_Fun_Type to_double; + + switch (type) + { + default: + return NULL; + + case SLANG_CHAR_TYPE: + da = sizeof (char); to_double = char_to_one_double; + break; + case SLANG_UCHAR_TYPE: + da = sizeof (unsigned char); to_double = uchar_to_one_double; + break; + case SLANG_SHORT_TYPE: + da = sizeof (short); to_double = short_to_one_double; + break; + case SLANG_USHORT_TYPE: + da = sizeof (unsigned short); to_double = ushort_to_one_double; + break; + case SLANG_INT_TYPE: + da = sizeof (int); to_double = int_to_one_double; + break; + case SLANG_UINT_TYPE: + da = sizeof (unsigned int); to_double = uint_to_one_double; + break; + case SLANG_LONG_TYPE: + da = sizeof (long); to_double = long_to_one_double; + break; + case SLANG_ULONG_TYPE: + da = sizeof (unsigned long); to_double = ulong_to_one_double; + break; + case SLANG_FLOAT_TYPE: + da = sizeof (float); to_double = float_to_one_double; + break; + case SLANG_DOUBLE_TYPE: + da = sizeof (double); to_double = double_to_one_double; + break; + } + + if (sizeof_type != NULL) *sizeof_type = da; + return to_double; +} +#endif /* SLANG_HAS_FLOAT */ +/* Each element of the matrix determines how the row maps onto the column. + * That is, let the matrix be B_ij. Where the i,j indices refer to + * precedence of the type. Then, + * B_ij->copy_function copies type i to type j. Similarly, + * B_ij->convert_function mallocs a new array of type j and copies i to it. + * + * Since types are always converted to higher levels of precedence for binary + * operations, many of the elements are NULL. + * + * Is the idea clear? + */ +typedef struct +{ + FVOID_STAR copy_function; + Convert_Fun_Type convert_function; +} +Binary_Matrix_Type; + +static Binary_Matrix_Type Binary_Matrix [MAX_ARITHMETIC_TYPES][MAX_ARITHMETIC_TYPES] = +{ + { + {(FVOID_STAR)copy_char_to_char, NULL}, + {(FVOID_STAR)copy_char_to_char, NULL}, + {(FVOID_STAR) copy_char_to_short, NULL}, + {(FVOID_STAR) copy_char_to_ushort, NULL}, + {(FVOID_STAR) copy_char_to_int, char_to_int}, + {(FVOID_STAR) copy_char_to_uint, char_to_uint}, + {(FVOID_STAR) copy_char_to_long, char_to_long}, + {(FVOID_STAR) copy_char_to_ulong, char_to_ulong}, +#if SLANG_HAS_FLOAT + {(FVOID_STAR) copy_char_to_float, char_to_float}, + {(FVOID_STAR) copy_char_to_double, char_to_double}, +#endif + }, + + { + {(FVOID_STAR)copy_char_to_char, NULL}, + {(FVOID_STAR)copy_char_to_char, NULL}, + {(FVOID_STAR) copy_uchar_to_short, NULL}, + {(FVOID_STAR) copy_uchar_to_ushort, NULL}, + {(FVOID_STAR) copy_uchar_to_int, uchar_to_int}, + {(FVOID_STAR) copy_uchar_to_uint, uchar_to_uint}, + {(FVOID_STAR) copy_uchar_to_long, uchar_to_long}, + {(FVOID_STAR) copy_uchar_to_ulong, uchar_to_ulong}, +#if SLANG_HAS_FLOAT + {(FVOID_STAR) copy_uchar_to_float, uchar_to_float}, + {(FVOID_STAR) copy_uchar_to_double, uchar_to_double}, +#endif + }, + + { + {(FVOID_STAR) copy_short_to_char, NULL}, + {(FVOID_STAR) copy_short_to_uchar, NULL}, + {(FVOID_STAR) copy_short_to_short, NULL}, + {(FVOID_STAR) copy_short_to_short, NULL}, + {(FVOID_STAR) copy_short_to_int, short_to_int}, + {(FVOID_STAR) copy_short_to_uint, short_to_uint}, + {(FVOID_STAR) copy_short_to_long, short_to_long}, + {(FVOID_STAR) copy_short_to_ulong, short_to_ulong}, +#if SLANG_HAS_FLOAT + {(FVOID_STAR) copy_short_to_float, short_to_float}, + {(FVOID_STAR) copy_short_to_double, short_to_double}, +#endif + }, + + { + {(FVOID_STAR) copy_ushort_to_char, NULL}, + {(FVOID_STAR) copy_ushort_to_uchar, NULL}, + {(FVOID_STAR) copy_short_to_short, NULL}, + {(FVOID_STAR) copy_short_to_short, NULL}, + {(FVOID_STAR) copy_ushort_to_int, ushort_to_int}, + {(FVOID_STAR) copy_ushort_to_uint, ushort_to_uint}, + {(FVOID_STAR) copy_ushort_to_long, ushort_to_long}, + {(FVOID_STAR) copy_ushort_to_ulong, ushort_to_ulong}, +#if SLANG_HAS_FLOAT + {(FVOID_STAR) copy_ushort_to_float, ushort_to_float}, + {(FVOID_STAR) copy_ushort_to_double, ushort_to_double}, +#endif + }, + + { + {(FVOID_STAR) copy_int_to_char, NULL}, + {(FVOID_STAR) copy_int_to_uchar, NULL}, + {(FVOID_STAR) copy_int_to_short, NULL}, + {(FVOID_STAR) copy_int_to_ushort, NULL}, + {(FVOID_STAR) copy_int_to_int, NULL}, + {(FVOID_STAR) copy_int_to_int, NULL}, + {(FVOID_STAR) copy_int_to_long, int_to_long}, + {(FVOID_STAR) copy_int_to_ulong, int_to_ulong}, +#if SLANG_HAS_FLOAT + {(FVOID_STAR) copy_int_to_float, int_to_float}, + {(FVOID_STAR) copy_int_to_double, int_to_double}, +#endif + }, + + { + {(FVOID_STAR) copy_uint_to_char, NULL}, + {(FVOID_STAR) copy_uint_to_uchar, NULL}, + {(FVOID_STAR) copy_uint_to_short, NULL}, + {(FVOID_STAR) copy_uint_to_ushort, NULL}, + {(FVOID_STAR) copy_int_to_int, NULL}, + {(FVOID_STAR) copy_int_to_int, NULL}, + {(FVOID_STAR) copy_uint_to_long, uint_to_long}, + {(FVOID_STAR) copy_uint_to_ulong, uint_to_ulong}, +#if SLANG_HAS_FLOAT + {(FVOID_STAR) copy_uint_to_float, uint_to_float}, + {(FVOID_STAR) copy_uint_to_double, uint_to_double}, +#endif + }, + + { + {(FVOID_STAR) copy_long_to_char, NULL}, + {(FVOID_STAR) copy_long_to_uchar, NULL}, + {(FVOID_STAR) copy_long_to_short, NULL}, + {(FVOID_STAR) copy_long_to_ushort, NULL}, + {(FVOID_STAR) copy_long_to_int, NULL}, + {(FVOID_STAR) copy_long_to_uint, NULL}, + {(FVOID_STAR) copy_long_to_long, NULL}, + {(FVOID_STAR) copy_long_to_long, NULL}, +#if SLANG_HAS_FLOAT + {(FVOID_STAR) copy_long_to_float, long_to_float}, + {(FVOID_STAR) copy_long_to_double, long_to_double}, +#endif + }, + + { + {(FVOID_STAR) copy_ulong_to_char, NULL}, + {(FVOID_STAR) copy_ulong_to_uchar, NULL}, + {(FVOID_STAR) copy_ulong_to_short, NULL}, + {(FVOID_STAR) copy_ulong_to_ushort, NULL}, + {(FVOID_STAR) copy_ulong_to_int, NULL}, + {(FVOID_STAR) copy_ulong_to_uint, NULL}, + {(FVOID_STAR) copy_long_to_long, NULL}, + {(FVOID_STAR) copy_long_to_long, NULL}, +#if SLANG_HAS_FLOAT + {(FVOID_STAR) copy_ulong_to_float, ulong_to_float}, + {(FVOID_STAR) copy_ulong_to_double, ulong_to_double}, +#endif + }, + +#if SLANG_HAS_FLOAT + { + {(FVOID_STAR) copy_float_to_char, NULL}, + {(FVOID_STAR) copy_float_to_uchar, NULL}, + {(FVOID_STAR) copy_float_to_short, NULL}, + {(FVOID_STAR) copy_float_to_ushort, NULL}, + {(FVOID_STAR) copy_float_to_int, NULL}, + {(FVOID_STAR) copy_float_to_uint, NULL}, + {(FVOID_STAR) copy_float_to_long, NULL}, + {(FVOID_STAR) copy_float_to_ulong, NULL}, + {(FVOID_STAR) copy_float_to_float, NULL}, + {(FVOID_STAR) copy_float_to_double, float_to_double}, + }, + + { + {(FVOID_STAR) copy_double_to_char, NULL}, + {(FVOID_STAR) copy_double_to_uchar, NULL}, + {(FVOID_STAR) copy_double_to_short, NULL}, + {(FVOID_STAR) copy_double_to_ushort, NULL}, + {(FVOID_STAR) copy_double_to_int, NULL}, + {(FVOID_STAR) copy_double_to_uint, NULL}, + {(FVOID_STAR) copy_double_to_long, NULL}, + {(FVOID_STAR) copy_double_to_ulong, NULL}, + {(FVOID_STAR) copy_double_to_float, NULL}, + {(FVOID_STAR) copy_double_to_double, NULL}, + } +#endif +}; + +#define GENERIC_BINARY_FUNCTION int_int_bin_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE int +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define ABS_FUNCTION abs +#define MOD_FUNCTION(a,b) ((a) % (b)) +#define GENERIC_UNARY_FUNCTION int_unary_op +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#if _SLANG_OPTIMIZE_FOR_SPEED +# define SCALAR_BINARY_FUNCTION int_int_scalar_bin_op +#endif +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_int_obj(SLANG_INT_TYPE,(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION int_cmp_function +#include "slarith.inc" + +#define GENERIC_BINARY_FUNCTION uint_uint_bin_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE unsigned int +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define MOD_FUNCTION(a,b) ((a) % (b)) +#define GENERIC_UNARY_FUNCTION uint_unary_op +#define ABS_FUNCTION(a) (a) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0) +#if _SLANG_OPTIMIZE_FOR_SPEED +# define SCALAR_BINARY_FUNCTION uint_uint_scalar_bin_op +#endif +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_int_obj(SLANG_UINT_TYPE,(int)(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION uint_cmp_function +#include "slarith.inc" + +#if SIZEOF_LONG != SIZEOF_INT +#define GENERIC_BINARY_FUNCTION long_long_bin_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE long +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define MOD_FUNCTION(a,b) ((a) % (b)) +#define GENERIC_UNARY_FUNCTION long_unary_op +#define ABS_FUNCTION(a) (((a) >= 0) ? (a) : -(a)) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#if _SLANG_OPTIMIZE_FOR_SPEED +# define SCALAR_BINARY_FUNCTION long_long_scalar_bin_op +#endif +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_long_obj(SLANG_LONG_TYPE,(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION long_cmp_function +#include "slarith.inc" + +#define GENERIC_BINARY_FUNCTION ulong_ulong_bin_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE unsigned long +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define MOD_FUNCTION(a,b) ((a) % (b)) +#define GENERIC_UNARY_FUNCTION ulong_unary_op +#define ABS_FUNCTION(a) (a) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0) +#if _SLANG_OPTIMIZE_FOR_SPEED +# define SCALAR_BINARY_FUNCTION ulong_ulong_scalar_bin_op +#endif +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_long_obj(SLANG_ULONG_TYPE,(long)(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION ulong_cmp_function +#include "slarith.inc" +#else +#define long_long_bin_op int_int_bin_op +#define ulong_ulong_bin_op uint_uint_bin_op +#define long_unary_op int_unary_op +#define ulong_unary_op uint_unary_op +#define long_cmp_function int_cmp_function +#define ulong_cmp_function uint_cmp_function +#endif /* SIZEOF_INT != SIZEOF_LONG */ + +#if SLANG_HAS_FLOAT +#define GENERIC_BINARY_FUNCTION float_float_bin_op +#define GENERIC_TYPE float +#define POW_FUNCTION(a,b) (float)pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE float +#define MOD_FUNCTION(a,b) (float)fmod((a),(b)) +#define GENERIC_UNARY_FUNCTION float_unary_op +#define ABS_FUNCTION(a) (float)fabs((double) a) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#if _SLANG_OPTIMIZE_FOR_SPEED +# define SCALAR_BINARY_FUNCTION float_float_scalar_bin_op +#endif +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_float_obj(SLANG_FLOAT_TYPE,(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_float_obj(SLANG_FLOAT_TYPE, (x)) +#define CMP_FUNCTION float_cmp_function +#include "slarith.inc" + +#define GENERIC_BINARY_FUNCTION double_double_bin_op +#define GENERIC_TYPE double +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define MOD_FUNCTION(a,b) (float)fmod((a),(b)) +#define GENERIC_UNARY_FUNCTION double_unary_op +#define ABS_FUNCTION(a) fabs(a) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#if _SLANG_OPTIMIZE_FOR_SPEED +# define SCALAR_BINARY_FUNCTION double_double_scalar_bin_op +#endif +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE,(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION double_cmp_function +#include "slarith.inc" +#endif /* SLANG_HAS_FLOAT */ + +#define GENERIC_UNARY_FUNCTION char_unary_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE signed char +#define ABS_FUNCTION abs +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#define CMP_FUNCTION char_cmp_function +#include "slarith.inc" + +#define GENERIC_UNARY_FUNCTION uchar_unary_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE unsigned char +#define ABS_FUNCTION(x) (x) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0) +#define CMP_FUNCTION uchar_cmp_function +#include "slarith.inc" + +#if SIZEOF_SHORT != SIZEOF_INT +#define GENERIC_UNARY_FUNCTION short_unary_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE short +#define ABS_FUNCTION abs +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#define CMP_FUNCTION short_cmp_function +#include "slarith.inc" + +#define GENERIC_UNARY_FUNCTION ushort_unary_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE unsigned short +#define ABS_FUNCTION(x) (x) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0) +#define CMP_FUNCTION ushort_cmp_function +#include "slarith.inc" +#endif /* SIZEOF_INT != SIZEOF_SHORT */ + +/* Unfortunately, the numbers that were assigned to the data-types were + * not well thought out. So, I need to use the following table. + */ +#define MAXIMUM_ARITH_TYPE_VALUE SLANG_FLOAT_TYPE + +#define IS_INTEGER_TYPE(x) \ + (((x) <= MAXIMUM_ARITH_TYPE_VALUE) \ + && (Type_Precedence_Table[x] < 8) && (Type_Precedence_Table[x] != -1)) +#define IS_ARITHMETIC_TYPE(x) \ + (((x) <= MAXIMUM_ARITH_TYPE_VALUE) && (Type_Precedence_Table[x] != -1)) + +#define LONG_PRECEDENCE_VALUE 6 +#define FLOAT_PRECEDENCE_VALUE 8 + +static signed char Type_Precedence_Table [MAXIMUM_ARITH_TYPE_VALUE + 1] = +{ + -1, /* SLANG_UNDEFINED_TYPE */ + -1, /* SLANG_VOID_TYPE */ + 4, /* SLANG_INT_TYPE */ +#if SLANG_HAS_FLOAT + 9, /* SLANG_DOUBLE_TYPE */ +#else + -1, +#endif + 0, /* SLANG_CHAR_TYPE */ + -1, /* SLANG_INTP_TYPE */ + -1, /* SLANG_REF_TYPE */ + -1, /* SLANG_COMPLEX_TYPE */ + -1, /* SLANG_NULL_TYPE */ + 1, /* SLANG_UCHAR_TYPE */ + 2, /* SLANG_SHORT_TYPE */ + 3, /* SLANG_USHORT_TYPE */ + 5, /* SLANG_UINT_TYPE */ + 6, /* SLANG_LONG_TYPE */ + 7, /* SLANG_ULONG_TYPE */ + -1, /* SLANG_STRING_TYPE */ +#if SLANG_HAS_FLOAT + 8 /* SLANG_FLOAT_TYPE */ +#else + -1 +#endif +}; + +int _SLarith_get_precedence (unsigned char type) +{ + if (type > MAXIMUM_ARITH_TYPE_VALUE) + return -1; + + return Type_Precedence_Table[type]; +} + +unsigned char _SLarith_promote_type (unsigned char t) +{ + switch (t) + { + case SLANG_FLOAT_TYPE: + case SLANG_DOUBLE_TYPE: + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: + case SLANG_INT_TYPE: + case SLANG_UINT_TYPE: + break; + + case SLANG_USHORT_TYPE: +#if SIZEOF_INT == SIZEOF_SHORT + t = SLANG_UINT_TYPE; + break; +#endif + /* drop */ + case SLANG_CHAR_TYPE: + case SLANG_UCHAR_TYPE: + case SLANG_SHORT_TYPE: + default: + t = SLANG_INT_TYPE; + } + + return t; +} + +static unsigned char promote_to_common_type (unsigned char a, unsigned char b) +{ + a = _SLarith_promote_type (a); + b = _SLarith_promote_type (b); + + return (Type_Precedence_Table[a] > Type_Precedence_Table[b]) ? a : b; +} + +static int arith_bin_op_result (int op, unsigned char a_type, unsigned char b_type, + unsigned char *c_type) +{ + switch (op) + { + case SLANG_EQ: + case SLANG_NE: + case SLANG_GT: + case SLANG_GE: + case SLANG_LT: + case SLANG_LE: + case SLANG_OR: + case SLANG_AND: + *c_type = SLANG_CHAR_TYPE; + return 1; +#if SLANG_HAS_FLOAT + case SLANG_POW: + if (SLANG_FLOAT_TYPE == promote_to_common_type (a_type, b_type)) + *c_type = SLANG_FLOAT_TYPE; + else + *c_type = SLANG_DOUBLE_TYPE; + return 1; +#endif + case SLANG_BAND: + case SLANG_BXOR: + case SLANG_BOR: + case SLANG_SHL: + case SLANG_SHR: + /* The bit-level operations are defined just for integer types */ + if ((0 == IS_INTEGER_TYPE (a_type)) + || (0 == IS_INTEGER_TYPE(b_type))) + return 0; + break; + + default: + break; + } + + *c_type = promote_to_common_type (a_type, b_type); + return 1; +} + +typedef int (*Bin_Fun_Type) (int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR); + +/* This array of functions must be indexed by precedence after arithmetic + * promotions. + */ +static Bin_Fun_Type Bin_Fun_Map [MAX_ARITHMETIC_TYPES] = +{ + NULL, + NULL, + NULL, + NULL, + int_int_bin_op, + uint_uint_bin_op, + long_long_bin_op, + ulong_ulong_bin_op, +#if SLANG_HAS_FLOAT + float_float_bin_op, + double_double_bin_op +#else + NULL, NULL +#endif +}; + +static int arith_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + Convert_Fun_Type af, bf; + Bin_Fun_Type binfun; + int a_indx, b_indx, c_indx; + unsigned char c_type; + int ret; + + c_type = promote_to_common_type (a_type, b_type); + + a_indx = Type_Precedence_Table [a_type]; + b_indx = Type_Precedence_Table [b_type]; + c_indx = Type_Precedence_Table [c_type]; + + af = Binary_Matrix[a_indx][c_indx].convert_function; + bf = Binary_Matrix[b_indx][c_indx].convert_function; + binfun = Bin_Fun_Map[c_indx]; + + if ((af != NULL) + && (NULL == (ap = (VOID_STAR) (*af) (ap, na)))) + return -1; + + if ((bf != NULL) + && (NULL == (bp = (VOID_STAR) (*bf) (bp, nb)))) + { + if (af != NULL) SLfree ((char *) ap); + return -1; + } + + ret = (*binfun) (op, a_type, ap, na, b_type, bp, nb, cp); + if (af != NULL) SLfree ((char *) ap); + if (bf != NULL) SLfree ((char *) bp); + + return ret; +} + +static int arith_unary_op_result (int op, unsigned char a, unsigned char *b) +{ + (void) a; + switch (op) + { + default: + return 0; + + case SLANG_SQR: + case SLANG_MUL2: + case SLANG_PLUSPLUS: + case SLANG_MINUSMINUS: + case SLANG_CHS: + case SLANG_ABS: + *b = a; + break; + + case SLANG_NOT: + case SLANG_BNOT: + if (0 == IS_INTEGER_TYPE(a)) + return 0; + *b = a; + break; + + case SLANG_SIGN: + *b = SLANG_INT_TYPE; + break; + } + return 1; +} + +static int integer_pop (unsigned char type, VOID_STAR ptr) +{ + SLang_Object_Type obj; + int i, j; + void (*f)(VOID_STAR, VOID_STAR, unsigned int); + + if (-1 == SLang_pop (&obj)) + return -1; + + if ((obj.data_type > MAXIMUM_ARITH_TYPE_VALUE) + || ((j = Type_Precedence_Table[obj.data_type]) == -1) + || (j >= FLOAT_PRECEDENCE_VALUE)) + { + _SLclass_type_mismatch_error (type, obj.data_type); + SLang_free_object (&obj); + return -1; + } + + i = Type_Precedence_Table[type]; + f = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[j][i].copy_function; + + (*f) (ptr, (VOID_STAR)&obj.v, 1); + + return 0; +} + +static int integer_push (unsigned char type, VOID_STAR ptr) +{ + SLang_Object_Type obj; + int i; + void (*f)(VOID_STAR, VOID_STAR, unsigned int); + + i = Type_Precedence_Table[type]; + f = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[i][i].copy_function; + + obj.data_type = type; + + (*f) ((VOID_STAR)&obj.v, ptr, 1); + + return SLang_push (&obj); +} + +int SLang_pop_char (char *i) +{ + return integer_pop (SLANG_CHAR_TYPE, (VOID_STAR) i); +} + +int SLang_pop_uchar (unsigned char *i) +{ + return integer_pop (SLANG_UCHAR_TYPE, (VOID_STAR) i); +} + +int SLang_pop_short (short *i) +{ + return integer_pop (SLANG_SHORT_TYPE, (VOID_STAR) i); +} + +int SLang_pop_ushort (unsigned short *i) +{ + return integer_pop (SLANG_USHORT_TYPE, (VOID_STAR) i); +} + +int SLang_pop_long (long *i) +{ + return integer_pop (SLANG_LONG_TYPE, (VOID_STAR) i); +} + +int SLang_pop_ulong (unsigned long *i) +{ + return integer_pop (SLANG_ULONG_TYPE, (VOID_STAR) i); +} + +int SLang_pop_integer (int *i) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (SLANG_INT_TYPE, &obj, 0)) + return -1; + *i = obj.v.int_val; + return 0; +#else + return integer_pop (SLANG_INT_TYPE, (VOID_STAR) i); +#endif +} + +int SLang_pop_uinteger (unsigned int *i) +{ + return integer_pop (SLANG_UINT_TYPE, (VOID_STAR) i); +} + +int SLang_push_integer (int i) +{ + return SLclass_push_int_obj (SLANG_INT_TYPE, i); +} +int SLang_push_uinteger (unsigned int i) +{ + return SLclass_push_int_obj (SLANG_UINT_TYPE, (int) i); +} +int SLang_push_char (char i) +{ + return SLclass_push_char_obj (SLANG_CHAR_TYPE, i); +} +int SLang_push_uchar (unsigned char i) +{ + return SLclass_push_char_obj (SLANG_UCHAR_TYPE, (char) i); +} +int SLang_push_short (short i) +{ + return SLclass_push_short_obj (SLANG_SHORT_TYPE, i); +} +int SLang_push_ushort (unsigned short i) +{ + return SLclass_push_short_obj (SLANG_USHORT_TYPE, (unsigned short) i); +} +int SLang_push_long (long i) +{ + return SLclass_push_long_obj (SLANG_LONG_TYPE, i); +} +int SLang_push_ulong (unsigned long i) +{ + return SLclass_push_long_obj (SLANG_ULONG_TYPE, (long) i); +} + +_INLINE_ +int _SLarith_typecast (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + int i, j; + + void (*copy)(VOID_STAR, VOID_STAR, unsigned int); + + i = Type_Precedence_Table[a_type]; + j = Type_Precedence_Table[b_type]; + + copy = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[i][j].copy_function; + + (*copy) (bp, ap, na); + return 1; +} + +#if SLANG_HAS_FLOAT + +int SLang_pop_double(double *x, int *convertp, int *ip) +{ + SLang_Object_Type obj; + int i, convert; + + if (0 != SLang_pop (&obj)) + return -1; + + i = 0; + convert = 0; + + switch (obj.data_type) + { + case SLANG_FLOAT_TYPE: + *x = (double) obj.v.float_val; + break; + + case SLANG_DOUBLE_TYPE: + *x = obj.v.double_val; + break; + + case SLANG_INT_TYPE: + i = obj.v.int_val; + *x = (double) i; + convert = 1; + break; + + case SLANG_CHAR_TYPE: *x = (double) obj.v.char_val; break; + case SLANG_UCHAR_TYPE: *x = (double) obj.v.uchar_val; break; + case SLANG_SHORT_TYPE: *x = (double) obj.v.short_val; break; + case SLANG_USHORT_TYPE: *x = (double) obj.v.ushort_val; break; + case SLANG_UINT_TYPE: *x = (double) obj.v.uint_val; break; + case SLANG_LONG_TYPE: *x = (double) obj.v.long_val; break; + case SLANG_ULONG_TYPE: *x = (double) obj.v.ulong_val; break; + + default: + _SLclass_type_mismatch_error (SLANG_DOUBLE_TYPE, obj.data_type); + SLang_free_object (&obj); + return -1; + } + + if (convertp != NULL) *convertp = convert; + if (ip != NULL) *ip = i; + + return 0; +} + +int SLang_push_double (double x) +{ + return SLclass_push_double_obj (SLANG_DOUBLE_TYPE, x); +} + +int SLang_pop_float (float *x) +{ + double d; + + /* Pop it as a double and let the double function do all the typcasting */ + if (-1 == SLang_pop_double (&d, NULL, NULL)) + return -1; + + *x = (float) d; + return 0; +} + +int SLang_push_float (float f) +{ + return SLclass_push_float_obj (SLANG_FLOAT_TYPE, (double) f); +} + +/* Double */ +static int double_push (SLtype type, VOID_STAR ptr) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + SLang_Object_Type obj; + obj.data_type = type; + obj.v.double_val = *(double *)ptr; + return SLang_push (&obj); +#else + return SLclass_push_double_obj (type, *(double *) ptr); +#endif +} + +static int double_push_literal (unsigned char type, VOID_STAR ptr) +{ + (void) type; + return SLang_push_double (**(double **)ptr); +} + +static int double_pop (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return SLang_pop_double ((double *) ptr, NULL, NULL); +} + +static void double_byte_code_destroy (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + SLfree (*(char **) ptr); +} + +static int float_push (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + SLang_push_float (*(float *) ptr); + return 0; +} + +static int float_pop (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return SLang_pop_float ((float *) ptr); +} + +#endif /* SLANG_HAS_FLOAT */ + +#if SLANG_HAS_FLOAT +static char Double_Format[16] = "%g"; + +void _SLset_double_format (char *s) +{ + strncpy (Double_Format, s, 15); + Double_Format[15] = 0; +} +#endif + +static char *arith_string (unsigned char type, VOID_STAR v) +{ + char buf [256]; + char *s; + + s = buf; + + switch (type) + { + default: + s = SLclass_get_datatype_name (type); + break; + + case SLANG_CHAR_TYPE: + sprintf (s, "%d", *(char *) v); + break; + case SLANG_UCHAR_TYPE: + sprintf (s, "%u", *(unsigned char *) v); + break; + case SLANG_SHORT_TYPE: + sprintf (s, "%d", *(short *) v); + break; + case SLANG_USHORT_TYPE: + sprintf (s, "%u", *(unsigned short *) v); + break; + case SLANG_INT_TYPE: + sprintf (s, "%d", *(int *) v); + break; + case SLANG_UINT_TYPE: + sprintf (s, "%u", *(unsigned int *) v); + break; + case SLANG_LONG_TYPE: + sprintf (s, "%ld", *(long *) v); + break; + case SLANG_ULONG_TYPE: + sprintf (s, "%lu", *(unsigned long *) v); + break; +#if SLANG_HAS_FLOAT + case SLANG_FLOAT_TYPE: + if (EOF == _SLsnprintf (buf, sizeof (buf), Double_Format, *(float *) v)) + sprintf (s, "%e", *(float *) v); + break; + case SLANG_DOUBLE_TYPE: + if (EOF == _SLsnprintf (buf, sizeof (buf), Double_Format, *(double *) v)) + sprintf (s, "%e", *(double *) v); + break; +#endif + } + + return SLmake_string (s); +} + +static int integer_to_bool (unsigned char type, int *t) +{ + (void) type; + return SLang_pop_integer (t); +} + +/* Note that integer literals are all stored in the byte-code as longs. This + * is why it is necessary to use *(long*). + */ +static int push_int_literal (unsigned char type, VOID_STAR ptr) +{ + return SLclass_push_int_obj (type, (int) *(long *) ptr); +} + +static int push_char_literal (unsigned char type, VOID_STAR ptr) +{ + return SLclass_push_char_obj (type, (char) *(long *) ptr); +} + +#if SIZEOF_SHORT != SIZEOF_INT +static int push_short_literal (unsigned char type, VOID_STAR ptr) +{ + return SLclass_push_short_obj (type, (short) *(long *) ptr); +} +#endif + +#if SIZEOF_INT != SIZEOF_LONG +static int push_long_literal (unsigned char type, VOID_STAR ptr) +{ + return SLclass_push_long_obj (type, *(long *) ptr); +} +#endif + +typedef struct +{ + char *name; + unsigned char data_type; + unsigned int sizeof_type; + int (*unary_fun)(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); + int (*push_literal) (unsigned char, VOID_STAR); + int (*cmp_fun) (unsigned char, VOID_STAR, VOID_STAR, int *); +} +Integer_Info_Type; + +static Integer_Info_Type Integer_Types [8] = +{ + {"Char_Type", SLANG_CHAR_TYPE, sizeof (char), char_unary_op, push_char_literal, char_cmp_function}, + {"UChar_Type", SLANG_UCHAR_TYPE, sizeof (unsigned char), uchar_unary_op, push_char_literal, uchar_cmp_function}, +#if SIZEOF_INT != SIZEOF_SHORT + {"Short_Type", SLANG_SHORT_TYPE, sizeof (short), short_unary_op, push_short_literal, short_cmp_function}, + {"UShort_Type", SLANG_USHORT_TYPE, sizeof (unsigned short), ushort_unary_op, push_short_literal, ushort_cmp_function}, +#else + {NULL, SLANG_SHORT_TYPE}, + {NULL, SLANG_USHORT_TYPE}, +#endif + + {"Integer_Type", SLANG_INT_TYPE, sizeof (int), int_unary_op, push_int_literal, int_cmp_function}, + {"UInteger_Type", SLANG_UINT_TYPE, sizeof (unsigned int), uint_unary_op, push_int_literal, uint_cmp_function}, + +#if SIZEOF_INT != SIZEOF_LONG + {"Long_Type", SLANG_LONG_TYPE, sizeof (long), long_unary_op, push_long_literal, long_cmp_function}, + {"ULong_Type", SLANG_ULONG_TYPE, sizeof (unsigned long), ulong_unary_op, push_long_literal, ulong_cmp_function} +#else + {NULL, SLANG_LONG_TYPE, 0, NULL, NULL, NULL}, + {NULL, SLANG_ULONG_TYPE, 0, NULL, NULL, NULL} +#endif +}; + +static int create_synonyms (void) +{ + static char *names[8] = + { + "Int16_Type", "UInt16_Type", "Int32_Type", "UInt32_Type", + "Int64_Type", "UInt64_Type", + "Float32_Type", "Float64_Type" + }; + int types[8]; + unsigned int i; + + memset ((char *) types, 0, sizeof (types)); + + /* The assumption is that sizeof(unsigned X) == sizeof (X) */ +#if SIZEOF_INT == 2 + types[0] = SLANG_INT_TYPE; + types[1] = SLANG_UINT_TYPE; +#else +# if SIZEOF_SHORT == 2 + types[0] = SLANG_SHORT_TYPE; + types[1] = SLANG_USHORT_TYPE; +# else +# if SIZEOF_LONG == 2 + types[0] = SLANG_LONG_TYPE; + types[1] = SLANG_ULONG_TYPE; +# endif +# endif +#endif + +#if SIZEOF_INT == 4 + types[2] = SLANG_INT_TYPE; + types[3] = SLANG_UINT_TYPE; +#else +# if SIZEOF_SHORT == 4 + types[2] = SLANG_SHORT_TYPE; + types[3] = SLANG_USHORT_TYPE; +# else +# if SIZEOF_LONG == 4 + types[2] = SLANG_LONG_TYPE; + types[3] = SLANG_ULONG_TYPE; +# endif +# endif +#endif + +#if SIZEOF_INT == 8 + types[4] = SLANG_INT_TYPE; + types[5] = SLANG_UINT_TYPE; +#else +# if SIZEOF_SHORT == 8 + types[4] = SLANG_SHORT_TYPE; + types[5] = SLANG_USHORT_TYPE; +# else +# if SIZEOF_LONG == 8 + types[4] = SLANG_LONG_TYPE; + types[5] = SLANG_ULONG_TYPE; +# endif +# endif +#endif + +#if SLANG_HAS_FLOAT + +#if SIZEOF_FLOAT == 4 + types[6] = SLANG_FLOAT_TYPE; +#else +# if SIZEOF_DOUBLE == 4 + types[6] = SLANG_DOUBLE_TYPE; +# endif +#endif +#if SIZEOF_FLOAT == 8 + types[7] = SLANG_FLOAT_TYPE; +#else +# if SIZEOF_DOUBLE == 8 + types[7] = SLANG_DOUBLE_TYPE; +# endif +#endif + +#endif + + if ((-1 == SLclass_create_synonym ("Int_Type", SLANG_INT_TYPE)) + || (-1 == SLclass_create_synonym ("UInt_Type", SLANG_UINT_TYPE))) + return -1; + + for (i = 0; i < 8; i++) + { + if (types[i] == 0) continue; + + if (-1 == SLclass_create_synonym (names[i], types[i])) + return -1; + } + +#if SIZEOF_INT == SIZEOF_SHORT + if ((-1 == SLclass_create_synonym ("Short_Type", SLANG_INT_TYPE)) + || (-1 == SLclass_create_synonym ("UShort_Type", SLANG_UINT_TYPE)) + || (-1 == _SLclass_copy_class (SLANG_SHORT_TYPE, SLANG_INT_TYPE)) + || (-1 == _SLclass_copy_class (SLANG_USHORT_TYPE, SLANG_UINT_TYPE))) + return -1; +#endif +#if SIZEOF_INT == SIZEOF_LONG + if ((-1 == SLclass_create_synonym ("Long_Type", SLANG_INT_TYPE)) + || (-1 == SLclass_create_synonym ("ULong_Type", SLANG_UINT_TYPE)) + || (-1 == _SLclass_copy_class (SLANG_LONG_TYPE, SLANG_INT_TYPE)) + || (-1 == _SLclass_copy_class (SLANG_ULONG_TYPE, SLANG_UINT_TYPE))) + return -1; +#endif + return 0; +} + +int _SLarith_register_types (void) +{ + SLang_Class_Type *cl; + int a_type, b_type; + int i, j; + +#if defined(HAVE_SETLOCALE) && defined(LC_NUMERIC) + /* make sure decimal point it used --- the parser requires it */ + (void) setlocale (LC_NUMERIC, "C"); +#endif + + for (i = 0; i < 8; i++) + { + Integer_Info_Type *info; + + info = Integer_Types + i; + + if (info->name == NULL) + { + /* This happens when the object is the same size as an integer + * For this case, we really want to copy the integer class. + * We will handle that when the synonym is created. + */ + continue; + } + + if (NULL == (cl = SLclass_allocate_class (info->name))) + return -1; + + (void) SLclass_set_string_function (cl, arith_string); + (void) SLclass_set_push_function (cl, integer_push); + (void) SLclass_set_pop_function (cl, integer_pop); + cl->cl_push_literal = info->push_literal; + cl->cl_to_bool = integer_to_bool; + + cl->cl_cmp = info->cmp_fun; + + if (-1 == SLclass_register_class (cl, info->data_type, info->sizeof_type, + SLANG_CLASS_TYPE_SCALAR)) + return -1; + if (-1 == SLclass_add_unary_op (info->data_type, info->unary_fun, arith_unary_op_result)) + return -1; + + _SLang_set_arith_type (info->data_type, 1); + } + +#if SLANG_HAS_FLOAT + if (NULL == (cl = SLclass_allocate_class ("Double_Type"))) + return -1; + (void) SLclass_set_push_function (cl, double_push); + (void) SLclass_set_pop_function (cl, double_pop); + (void) SLclass_set_string_function (cl, arith_string); + cl->cl_byte_code_destroy = double_byte_code_destroy; + cl->cl_push_literal = double_push_literal; + cl->cl_cmp = double_cmp_function; + + if (-1 == SLclass_register_class (cl, SLANG_DOUBLE_TYPE, sizeof (double), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + if (-1 == SLclass_add_unary_op (SLANG_DOUBLE_TYPE, double_unary_op, arith_unary_op_result)) + return -1; + _SLang_set_arith_type (SLANG_DOUBLE_TYPE, 2); + + if (NULL == (cl = SLclass_allocate_class ("Float_Type"))) + return -1; + (void) SLclass_set_string_function (cl, arith_string); + (void) SLclass_set_push_function (cl, float_push); + (void) SLclass_set_pop_function (cl, float_pop); + cl->cl_cmp = float_cmp_function; + + if (-1 == SLclass_register_class (cl, SLANG_FLOAT_TYPE, sizeof (float), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + if (-1 == SLclass_add_unary_op (SLANG_FLOAT_TYPE, float_unary_op, arith_unary_op_result)) + return -1; + _SLang_set_arith_type (SLANG_FLOAT_TYPE, 2); +#endif + + if (-1 == create_synonyms ()) + return -1; + + for (a_type = 0; a_type <= MAXIMUM_ARITH_TYPE_VALUE; a_type++) + { + if (-1 == (i = Type_Precedence_Table [a_type])) + continue; + + for (b_type = 0; b_type <= MAXIMUM_ARITH_TYPE_VALUE; b_type++) + { + int implicit_ok; + + if (-1 == (j = Type_Precedence_Table [b_type])) + continue; + + /* Allow implicit typecast, except from into to float */ + implicit_ok = ((j >= FLOAT_PRECEDENCE_VALUE) + || (i < FLOAT_PRECEDENCE_VALUE)); + + if (-1 == SLclass_add_binary_op (a_type, b_type, arith_bin_op, arith_bin_op_result)) + return -1; + + if (i != j) + if (-1 == SLclass_add_typecast (a_type, b_type, _SLarith_typecast, implicit_ok)) + return -1; + } + } + + return 0; +} + +#if _SLANG_OPTIMIZE_FOR_SPEED + +static void promote_objs (SLang_Object_Type *a, SLang_Object_Type *b, + SLang_Object_Type *c, SLang_Object_Type *d) +{ + unsigned char ia, ib, ic, id; + int i, j; + void (*copy)(VOID_STAR, VOID_STAR, unsigned int); + + ia = a->data_type; + ib = b->data_type; + + ic = _SLarith_promote_type (ia); + + if (ic == ib) id = ic; /* already promoted */ + else id = _SLarith_promote_type (ib); + + i = Type_Precedence_Table[ic]; + j = Type_Precedence_Table[id]; + if (i > j) + { + id = ic; + j = i; + } + + c->data_type = d->data_type = id; + + i = Type_Precedence_Table[ia]; + copy = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[i][j].copy_function; + (*copy) ((VOID_STAR) &c->v, (VOID_STAR)&a->v, 1); + + i = Type_Precedence_Table[ib]; + copy = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[i][j].copy_function; + (*copy) ((VOID_STAR) &d->v, (VOID_STAR)&b->v, 1); +} + +int _SLarith_bin_op (SLang_Object_Type *oa, SLang_Object_Type *ob, int op) +{ + unsigned char a_type, b_type; + + a_type = oa->data_type; + b_type = ob->data_type; + + if (a_type != b_type) + { + SLang_Object_Type obj_a, obj_b; + + /* Handle common cases */ +#if SLANG_HAS_FLOAT + if ((a_type == SLANG_INT_TYPE) + && (b_type == SLANG_DOUBLE_TYPE)) + return double_double_scalar_bin_op (oa->v.int_val, ob->v.double_val, op); + + if ((a_type == SLANG_DOUBLE_TYPE) + && (b_type == SLANG_INT_TYPE)) + return double_double_scalar_bin_op (oa->v.double_val, ob->v.int_val, op); +#endif + /* Otherwise do it the hard way */ + promote_objs (oa, ob, &obj_a, &obj_b); + oa = &obj_a; + ob = &obj_b; + + a_type = oa->data_type; + /* b_type = ob->data_type; */ + } + + + switch (a_type) + { + case SLANG_CHAR_TYPE: + return int_int_scalar_bin_op (oa->v.char_val, ob->v.char_val, op); + + case SLANG_UCHAR_TYPE: + return int_int_scalar_bin_op (oa->v.uchar_val, ob->v.uchar_val, op); + + case SLANG_SHORT_TYPE: + return int_int_scalar_bin_op (oa->v.short_val, ob->v.short_val, op); + + case SLANG_USHORT_TYPE: +# if SIZEOF_INT == SIZEOF_SHORT + return uint_uint_scalar_bin_op (oa->v.ushort_val, ob->v.ushort_val, op); +# else + return int_int_scalar_bin_op ((int)oa->v.ushort_val, (int)ob->v.ushort_val, op); +# endif + +#if SIZEOF_LONG == SIZEOF_INT + case SLANG_LONG_TYPE: +#endif + case SLANG_INT_TYPE: + return int_int_scalar_bin_op (oa->v.int_val, ob->v.int_val, op); + +#if SIZEOF_LONG == SIZEOF_INT + case SLANG_ULONG_TYPE: +#endif + case SLANG_UINT_TYPE: + return uint_uint_scalar_bin_op (oa->v.uint_val, ob->v.uint_val, op); + +#if SIZEOF_LONG != SIZEOF_INT + case SLANG_LONG_TYPE: + return long_long_scalar_bin_op (oa->v.long_val, ob->v.long_val, op); + case SLANG_ULONG_TYPE: + return ulong_ulong_scalar_bin_op (oa->v.ulong_val, ob->v.ulong_val, op); +#endif +#if SLANG_HAS_FLOAT + case SLANG_FLOAT_TYPE: + return float_float_scalar_bin_op (oa->v.float_val, ob->v.float_val, op); + case SLANG_DOUBLE_TYPE: + return double_double_scalar_bin_op (oa->v.double_val, ob->v.double_val, op); +#endif + } + + return 1; +} +#endif diff --git a/libslang/src/slarith.inc b/libslang/src/slarith.inc new file mode 100644 index 0000000..2138c0f --- /dev/null +++ b/libslang/src/slarith.inc @@ -0,0 +1,784 @@ +/* -*- c -*- */ + +/* This include file is a template for defining arithmetic binary operations + * on arithmetic types. I realize that doing it this way is not very + * elegant but it minimizes the number of lines of code and I believe it + * promotes clarity. + */ + +/* The following macros should be properly defined before including this file: + * + * GENERIC_BINARY_FUNCTION: The name of the binary function + * GENERIC_TYPE: The class data type + * MOD_FUNCTION: The function to use for mod + * ABS_FUNCTION: Name of the abs function + * SIGN_FUNCTION: Name of the sign function + * GENERIC_UNARY_FUNCTION Name of the unary function + * + * If GENERIC_BIT_OPERATIONS is defined, the bit-level binary operators + * will get included. If the data type has a power operation (SLANG_POW), + * then POW_FUNCTION should be defined to return POW_RESULT_TYPE. + */ +#ifdef GENERIC_BINARY_FUNCTION + +static int GENERIC_BINARY_FUNCTION +(int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + GENERIC_TYPE *c, *a, *b; +#ifdef POW_FUNCTION + POW_RESULT_TYPE *d; +#endif + unsigned int n; +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + unsigned int n_max, da, db; +#endif + char *cc; + + (void) a_type; /* Both SLANG_INT_TYPE */ + (void) b_type; + + a = (GENERIC_TYPE *) ap; + b = (GENERIC_TYPE *) bp; + c = (GENERIC_TYPE *) cp; + cc = (char *) cp; + +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + if (na == 1) da = 0; else da = 1; + if (nb == 1) db = 0; else db = 1; + + if (na > nb) n_max = na; else n_max = nb; +#endif + + switch (op) + { + default: + return 0; +#ifdef POW_FUNCTION + case SLANG_POW: + d = (POW_RESULT_TYPE *) cp; +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + d[n] = POW_FUNCTION(*a, *b); + a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + d[n] = POW_FUNCTION(a[n],b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + if (xb == 2) + for (n = 0; n < na; n++) + d[n] = a[n] * a[n]; + else + for (n = 0; n < na; n++) + d[n] = POW_FUNCTION(a[n], xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + d[n] = POW_FUNCTION(xa, b[n]); + } +#endif + break; +#endif + case SLANG_PLUS: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a + *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] + b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] + xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa + b[n]; + } +#endif + break; + + case SLANG_MINUS: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a - *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] - b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] - xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa - b[n]; + } +#endif + break; + + case SLANG_TIMES: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a * *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] * b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] * xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa * b[n]; + } +#endif + break; + + case SLANG_DIVIDE: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + if (*b == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = (*a / *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + { + if (b[n] == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = a[n] / b[n]; + } + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + + if (xb == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + for (n = 0; n < na; n++) + c[n] = a[n] / xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + { + if (b[n] == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = xa / b[n]; + } + } +#endif + break; + + case SLANG_MOD: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + if (*b == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = MOD_FUNCTION(*a, *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + { + if (b[n] == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = MOD_FUNCTION(a[n],b[n]); + } + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + if (xb == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + for (n = 0; n < na; n++) + c[n] = MOD_FUNCTION(a[n],xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + { + if (b[n] == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = MOD_FUNCTION(xa,b[n]); + } + } +#endif + break; + +#ifdef GENERIC_BIT_OPERATIONS + case SLANG_BAND: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a & *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] & b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] & xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa & b[n]; + } +#endif + break; + + case SLANG_BXOR: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a ^ *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] ^ b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] ^ xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa ^ b[n]; + } +#endif + break; + + case SLANG_BOR: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a | *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] | b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] | xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa | b[n]; + } +#endif + break; + + case SLANG_SHL: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a << *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] << b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] << xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa << b[n]; + } +#endif + break; + + case SLANG_SHR: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a >> *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] >> b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] >> xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa >> b[n]; + } +#endif + break; +#endif /* GENERIC_BIT_OPERATIONS */ + case SLANG_EQ: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a == *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] == b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] == xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa == b[n]); + } +#endif + break; + + case SLANG_NE: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a != *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] != b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] != xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa != b[n]); + } +#endif + break; + + case SLANG_GT: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a > *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] > b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] > xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa > b[n]); + } +#endif + break; + + case SLANG_GE: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a >= *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] >= b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] >= xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa >= b[n]); + } +#endif + break; + + case SLANG_LT: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a < *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] < b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] < xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa < b[n]); + } +#endif + break; + + case SLANG_LE: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a <= *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] <= b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] <= xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa <= b[n]); + } +#endif + break; + + case SLANG_OR: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a || *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] || b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] || xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa || b[n]); + } +#endif + break; + + case SLANG_AND: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a && *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] && b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] && xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa && b[n]); + } +#endif + break; + } + return 1; +} + +#endif /* GENERIC_BINARY_FUNCTION */ + + +#ifdef GENERIC_UNARY_FUNCTION + +static int GENERIC_UNARY_FUNCTION +(int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + VOID_STAR bp + ) +{ + GENERIC_TYPE *a, *b; + unsigned int n; + int *ib; + + (void) a_type; + + a = (GENERIC_TYPE *) ap; + b = (GENERIC_TYPE *) bp; + + switch (op) + { + default: + return 0; + + case SLANG_PLUSPLUS: + for (n = 0; n < na; n++) b[n] = (a[n] + 1); + break; + case SLANG_MINUSMINUS: + for (n = 0; n < na; n++) b[n] = (a[n] - 1); + break; + case SLANG_CHS: + for (n = 0; n < na; n++) b[n] = (GENERIC_TYPE) -(a[n]); + break; + case SLANG_SQR: + for (n = 0; n < na; n++) b[n] = (a[n] * a[n]); + break; + case SLANG_MUL2: + for (n = 0; n < na; n++) b[n] = (2 * a[n]); + break; + case SLANG_ABS: + for (n = 0; n < na; n++) b[n] = ABS_FUNCTION (a[n]); + break; + case SLANG_SIGN: + ib = (int *) bp; + for (n = 0; n < na; n++) + ib[n] = SIGN_FUNCTION(a[n]); + break; + +#ifdef GENERIC_BIT_OPERATIONS + case SLANG_NOT: + for (n = 0; n < na; n++) b[n] = !(a[n]); + break; + case SLANG_BNOT: + for (n = 0; n < na; n++) b[n] = ~(a[n]); + break; +#endif + } + + return 1; +} +#endif /* GENERIC_UNARY_FUNCTION */ + + +#ifdef SCALAR_BINARY_FUNCTION + +static int SCALAR_BINARY_FUNCTION (GENERIC_TYPE a, GENERIC_TYPE b, int op) +{ + switch (op) + { + default: + return 1; +#if SLANG_HAS_FLOAT +#ifdef POW_FUNCTION + case SLANG_POW: + return PUSH_POW_OBJ_FUN(POW_FUNCTION(a, b)); +#endif +#endif + case SLANG_PLUS: + return PUSH_SCALAR_OBJ_FUN (a + b); + case SLANG_MINUS: + return PUSH_SCALAR_OBJ_FUN (a - b); + case SLANG_TIMES: + return PUSH_SCALAR_OBJ_FUN (a * b); + case SLANG_DIVIDE: + if (b == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + return PUSH_SCALAR_OBJ_FUN (a / b); + case SLANG_MOD: + if (b == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + return PUSH_SCALAR_OBJ_FUN (MOD_FUNCTION(a,b)); +#ifdef GENERIC_BIT_OPERATIONS + case SLANG_BAND: + return PUSH_SCALAR_OBJ_FUN (a & b); + case SLANG_BXOR: + return PUSH_SCALAR_OBJ_FUN (a ^ b); + case SLANG_BOR: + return PUSH_SCALAR_OBJ_FUN (a | b); + case SLANG_SHL: + return PUSH_SCALAR_OBJ_FUN (a << b); + case SLANG_SHR: + return PUSH_SCALAR_OBJ_FUN (a >> b); +#endif + case SLANG_GT: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a > b)); + case SLANG_LT: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a < b)); + case SLANG_GE: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a >= b)); + case SLANG_LE: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a <= b)); + case SLANG_EQ: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a == b)); + case SLANG_NE: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a != b)); + case SLANG_OR: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a || b)); + case SLANG_AND: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a && b)); + } +} + +#endif /* SCALAR_BINARY_FUNCTION */ + +#ifdef CMP_FUNCTION +static int CMP_FUNCTION (unsigned char unused, VOID_STAR a, VOID_STAR b, int *c) +{ + GENERIC_TYPE x, y; + + (void) unused; + x = *(GENERIC_TYPE *) a; + y = *(GENERIC_TYPE *) b; + + if (x > y) *c = 1; + else if (x == y) *c = 0; + else *c = -1; + + return 0; +} +#endif + +#undef CMP_FUNCTION +#undef SCALAR_BINARY_FUNCTION +#undef PUSH_POW_OBJ_FUN +#undef PUSH_SCALAR_OBJ_FUN +#undef GENERIC_BINARY_FUNCTION +#undef GENERIC_UNARY_FUNCTION +#undef GENERIC_BIT_OPERATIONS +#undef GENERIC_TYPE +#undef POW_FUNCTION +#undef POW_RESULT_TYPE +#undef MOD_FUNCTION +#undef ABS_FUNCTION +#undef SIGN_FUNCTION diff --git a/libslang/src/slarray.c b/libslang/src/slarray.c new file mode 100644 index 0000000..49829c2 --- /dev/null +++ b/libslang/src/slarray.c @@ -0,0 +1,3306 @@ +/* Array manipulation routines for S-Lang */ +/* Copyright (c) 1997, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +/* #define SL_APP_WANTS_FOREACH */ +#include "slang.h" +#include "_slang.h" + +typedef struct +{ + int first_index; + int last_index; + int delta; +} +SLarray_Range_Array_Type; + +/* Use SLang_pop_array when a linear array is required. */ +static int pop_array (SLang_Array_Type **at_ptr, int convert_scalar) +{ + SLang_Array_Type *at; + int one = 1; + int type; + + *at_ptr = NULL; + type = SLang_peek_at_stack (); + + switch (type) + { + case -1: + return -1; + + case SLANG_ARRAY_TYPE: + return SLclass_pop_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR *) at_ptr); + + case SLANG_NULL_TYPE: + convert_scalar = 0; + /* drop */ + default: + if (convert_scalar == 0) + { + SLdo_pop (); + SLang_verror (SL_TYPE_MISMATCH, "Context requires an array. Scalar not converted"); + return -1; + } + break; + } + + if (NULL == (at = SLang_create_array ((unsigned char) type, 0, NULL, &one, 1))) + return -1; + + if (-1 == at->cl->cl_apop ((unsigned char) type, at->data)) + { + SLang_free_array (at); + return -1; + } + + *at_ptr = at; + + return 0; +} + +static VOID_STAR linear_get_data_addr (SLang_Array_Type *at, int *dims) +{ + unsigned int num_dims; + unsigned int ofs; + unsigned int i; + int *max_dims; + + ofs = 0; + max_dims = at->dims; + num_dims = at->num_dims; + + for (i = 0; i < num_dims; i++) + { + int d = dims[i]; + + if (d < 0) + d = d + max_dims[i]; + + ofs = ofs * (unsigned int)max_dims [i] + (unsigned int) d; + } + + return (VOID_STAR) ((char *)at->data + (ofs * at->sizeof_type)); +} + +static VOID_STAR get_data_addr (SLang_Array_Type *at, int *dims) +{ + VOID_STAR data; + + data = at->data; + if (data == NULL) + { + SLang_verror (SL_UNKNOWN_ERROR, "Array has no data"); + return NULL; + } + + data = (*at->index_fun) (at, dims); + + if (data == NULL) + { + SLang_verror (SL_UNKNOWN_ERROR, "Unable to access array element"); + return NULL; + } + + return data; +} + +void _SLarray_free_array_elements (SLang_Class_Type *cl, VOID_STAR s, unsigned int num) +{ + unsigned int sizeof_type; + void (*f) (unsigned char, VOID_STAR); + char *p; + unsigned char type; + + if ((cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + || (cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR)) + return; + + f = cl->cl_destroy; + sizeof_type = cl->cl_sizeof_type; + type = cl->cl_data_type; + + p = (char *) s; + while (num != 0) + { + if (NULL != *(VOID_STAR *)p) + { + (*f) (type, (VOID_STAR)p); + *(VOID_STAR *) p = NULL; + } + p += sizeof_type; + num--; + } +} + +static int destroy_element (SLang_Array_Type *at, + int *dims, + VOID_STAR data) +{ + data = get_data_addr (at, dims); + if (data == NULL) + return -1; + + /* This function should only get called for arrays that have + * pointer elements. Do not call the destroy method if the element + * is NULL. + */ + if (NULL != *(VOID_STAR *)data) + { + (*at->cl->cl_destroy) (at->data_type, data); + *(VOID_STAR *) data = NULL; + } + return 0; +} + +/* This function only gets called when a new array is created. Thus there + * is no need to destroy the object first. + */ +static int new_object_element (SLang_Array_Type *at, + int *dims, + VOID_STAR data) +{ + data = get_data_addr (at, dims); + if (data == NULL) + return -1; + + return (*at->cl->cl_init_array_object) (at->data_type, data); +} + +int _SLarray_next_index (int *dims, int *max_dims, unsigned int num_dims) +{ + while (num_dims) + { + int dims_i; + + num_dims--; + + dims_i = dims [num_dims] + 1; + if (dims_i != (int) max_dims [num_dims]) + { + dims [num_dims] = dims_i; + return 0; + } + dims [num_dims] = 0; + } + + return -1; +} + +static int do_method_for_all_elements (SLang_Array_Type *at, + int (*method)(SLang_Array_Type *, + int *, + VOID_STAR), + VOID_STAR client_data) +{ + int dims [SLARRAY_MAX_DIMS]; + int *max_dims; + unsigned int num_dims; + + if (at->num_elements == 0) + return 0; + + max_dims = at->dims; + num_dims = at->num_dims; + + SLMEMSET((char *)dims, 0, sizeof(dims)); + + do + { + if (-1 == (*method) (at, dims, client_data)) + return -1; + } + while (0 == _SLarray_next_index (dims, max_dims, num_dims)); + + return 0; +} + +void SLang_free_array (SLang_Array_Type *at) +{ + unsigned int flags; + + if (at == NULL) return; + + if (at->num_refs > 1) + { + at->num_refs -= 1; + return; + } + + flags = at->flags; + + if (flags & SLARR_DATA_VALUE_IS_INTRINSIC) + return; /* not to be freed */ + + if (flags & SLARR_DATA_VALUE_IS_POINTER) + (void) do_method_for_all_elements (at, destroy_element, NULL); + + if (at->free_fun != NULL) + at->free_fun (at); + else + SLfree ((char *) at->data); + + SLfree ((char *) at); +} + +SLang_Array_Type * +SLang_create_array1 (unsigned char type, int read_only, VOID_STAR data, + int *dims, unsigned int num_dims, int no_init) +{ + SLang_Class_Type *cl; + unsigned int i; + SLang_Array_Type *at; + unsigned int num_elements; + unsigned int sizeof_type; + unsigned int size; + + if (num_dims > SLARRAY_MAX_DIMS) + { + SLang_verror (SL_NOT_IMPLEMENTED, "%u dimensional arrays are not supported", num_dims); + return NULL; + } + + for (i = 0; i < num_dims; i++) + { + if (dims[i] < 0) + { + SLang_verror (SL_INVALID_PARM, "Size of array dim %u is less than 0", i); + return NULL; + } + } + + cl = _SLclass_get_class (type); + + at = (SLang_Array_Type *) SLmalloc (sizeof(SLang_Array_Type)); + if (at == NULL) + return NULL; + + SLMEMSET ((char*) at, 0, sizeof(SLang_Array_Type)); + + at->data_type = type; + at->cl = cl; + at->num_dims = num_dims; + at->num_refs = 1; + + if (read_only) at->flags = SLARR_DATA_VALUE_IS_READ_ONLY; + switch (cl->cl_class_type) + { + case SLANG_CLASS_TYPE_VECTOR: + case SLANG_CLASS_TYPE_SCALAR: + break; + + default: + at->flags |= SLARR_DATA_VALUE_IS_POINTER; + } + + num_elements = 1; + for (i = 0; i < num_dims; i++) + { + at->dims [i] = dims[i]; + num_elements = dims [i] * num_elements; + } + + /* Now set the rest of the unused dimensions to 1. This makes it easier + * when transposing arrays. + */ + while (i < SLARRAY_MAX_DIMS) + at->dims[i++] = 1; + + at->num_elements = num_elements; + at->index_fun = linear_get_data_addr; + at->sizeof_type = sizeof_type = cl->cl_sizeof_type; + + if (data != NULL) + { + at->data = data; + return at; + } + + size = num_elements * sizeof_type; + + if (size == 0) size = 1; + + if (NULL == (data = (VOID_STAR) SLmalloc (size))) + { + SLang_free_array (at); + return NULL; + } + + if (no_init == 0) + SLMEMSET ((char *) data, 0, size); + + at->data = data; + + if ((cl->cl_init_array_object != NULL) + && (-1 == do_method_for_all_elements (at, new_object_element, NULL))) + { + SLang_free_array (at); + return NULL; + } + return at; +} + +SLang_Array_Type * +SLang_create_array (unsigned char type, int read_only, VOID_STAR data, + int *dims, unsigned int num_dims) +{ + return SLang_create_array1 (type, read_only, data, dims, num_dims, 0); +} + +int SLang_add_intrinsic_array (char *name, + unsigned char type, + int read_only, + VOID_STAR data, + unsigned int num_dims, ...) +{ + va_list ap; + unsigned int i; + int dims[SLARRAY_MAX_DIMS]; + SLang_Array_Type *at; + + if ((num_dims > SLARRAY_MAX_DIMS) + || (name == NULL) + || (data == NULL)) + { + SLang_verror (SL_INVALID_PARM, "Unable to create intrinsic array"); + return -1; + } + + va_start (ap, num_dims); + for (i = 0; i < num_dims; i++) + dims [i] = va_arg (ap, int); + va_end (ap); + + at = SLang_create_array (type, read_only, data, dims, num_dims); + if (at == NULL) + return -1; + at->flags |= SLARR_DATA_VALUE_IS_INTRINSIC; + + /* Note: The variable that refers to the intrinsic array is regarded as + * read-only. That way, Array_Name = another_array; will fail. + */ + if (-1 == SLadd_intrinsic_variable (name, (VOID_STAR) at, SLANG_ARRAY_TYPE, 1)) + { + SLang_free_array (at); + return -1; + } + return 0; +} + +static int pop_array_indices (int *dims, unsigned int num_dims) +{ + unsigned int n; + int i; + + if (num_dims > SLARRAY_MAX_DIMS) + { + SLang_verror (SL_INVALID_PARM, "Array size not supported"); + return -1; + } + + n = num_dims; + while (n != 0) + { + n--; + if (-1 == SLang_pop_integer (&i)) + return -1; + + dims[n] = i; + } + + return 0; +} + +int SLang_push_array (SLang_Array_Type *at, int free_flag) +{ + if (at == NULL) + return SLang_push_null (); + + at->num_refs += 1; + + if (0 == SLclass_push_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR) at)) + { + if (free_flag) + SLang_free_array (at); + return 0; + } + + at->num_refs -= 1; + + if (free_flag) SLang_free_array (at); + return -1; +} + +/* This function gets called via expressions such as Double_Type[10, 20]; + */ +static int push_create_new_array (void) +{ + unsigned int num_dims; + SLang_Array_Type *at; + unsigned char type; + int dims [SLARRAY_MAX_DIMS]; + int (*anew) (unsigned char, unsigned int); + + num_dims = (SLang_Num_Function_Args - 1); + + if (-1 == SLang_pop_datatype (&type)) + return -1; + + anew = (_SLclass_get_class (type))->cl_anew; + if (anew != NULL) + return (*anew) (type, num_dims); + + if (-1 == pop_array_indices (dims, num_dims)) + return -1; + + if (NULL == (at = SLang_create_array (type, 0, NULL, dims, num_dims))) + return -1; + + return SLang_push_array (at, 1); +} + +static int push_element_at_addr (SLang_Array_Type *at, + VOID_STAR data, int allow_null) +{ + SLang_Class_Type *cl; + + cl = at->cl; + if ((at->flags & SLARR_DATA_VALUE_IS_POINTER) + && (*(VOID_STAR *) data == NULL)) + { + if (allow_null) + return SLang_push_null (); + + SLang_verror (SL_VARIABLE_UNINITIALIZED, + "%s array has unitialized element", cl->cl_name); + return -1; + } + + return (*cl->cl_apush)(at->data_type, data); +} + +static int coerse_array_to_linear (SLang_Array_Type *at) +{ + SLarray_Range_Array_Type *range; + int *data; + int xmin, dx; + unsigned int i, imax; + + /* FIXME: Priority = low. This assumes that if an array is not linear, then + * it is a range. + */ + if (0 == (at->flags & SLARR_DATA_VALUE_IS_RANGE)) + return 0; + + range = (SLarray_Range_Array_Type *) at->data; + xmin = range->first_index; + dx = range->delta; + + imax = at->num_elements; + data = (int *) SLmalloc ((imax + 1) * sizeof (int)); + if (data == NULL) + return -1; + + for (i = 0; i < imax; i++) + { + data [i] = xmin; + xmin += dx; + } + + SLfree ((char *) range); + at->data = (VOID_STAR) data; + at->flags &= ~SLARR_DATA_VALUE_IS_RANGE; + at->index_fun = linear_get_data_addr; + return 0; +} + +static void +free_index_objects (SLang_Object_Type *index_objs, unsigned int num_indices) +{ + unsigned int i; + SLang_Object_Type *obj; + + for (i = 0; i < num_indices; i++) + { + obj = index_objs + i; + if (obj->data_type != 0) + SLang_free_object (obj); + } +} + +static int +pop_indices (SLang_Array_Type *at_to_index, + SLang_Object_Type *index_objs, unsigned int num_indices, + int *is_index_array) +{ + unsigned int i; + + SLMEMSET((char *) index_objs, 0, num_indices * sizeof (SLang_Object_Type)); + + *is_index_array = 0; + + if (num_indices >= SLARRAY_MAX_DIMS) + { + SLang_verror (SL_INVALID_PARM, "too many indices for array"); + return -1; + } + + i = num_indices; + while (i != 0) + { + SLang_Object_Type *obj; + + i--; + obj = index_objs + i; + if (-1 == _SLang_pop_object_of_type (SLANG_INT_TYPE, obj, 1)) + goto return_error; + + if (obj->data_type == SLANG_ARRAY_TYPE) + { + SLang_Array_Type *at = obj->v.array_val; + + if (at->num_dims == 1) + { + /* Note: Suppose a = Int_Type[10, 10]. Then the check + * on the range flag prevents this from being indexed by + * a range such as 'a[[0:99]]' + */ + if (num_indices == 1) + { + if ((at_to_index->num_dims > 1) + || (0 == (at->flags & SLARR_DATA_VALUE_IS_RANGE))) + *is_index_array = 1; + } + } + else + { + SLang_verror (SL_INVALID_PARM, "expecting a 1-d index array"); + goto return_error; + } + } + } + + return 0; + + return_error: + free_index_objects (index_objs, num_indices); + return -1; +} + +/* Here ind_at is a linear 1-d array of indices */ +static int +check_index_array_ranges (SLang_Array_Type *at, SLang_Array_Type *ind_at) +{ + int *indices, *indices_max; + unsigned int num_elements; + + num_elements = at->num_elements; + indices = (int *) ind_at->data; + indices_max = indices + ind_at->num_elements; + + while (indices < indices_max) + { + unsigned int d; + + d = (unsigned int) *indices++; + if (d >= num_elements) + { + SLang_verror (SL_INVALID_PARM, + "index-array is out of range"); + return -1; + } + } + return 0; +} + +static int +transfer_n_elements (SLang_Array_Type *at, VOID_STAR dest_data, VOID_STAR src_data, + unsigned int sizeof_type, unsigned int n, int is_ptr) +{ + unsigned char data_type; + SLang_Class_Type *cl; + + if (is_ptr == 0) + { + SLMEMCPY ((char *) dest_data, (char *)src_data, n * sizeof_type); + return 0; + } + + data_type = at->data_type; + cl = at->cl; + + while (n != 0) + { + if (*(VOID_STAR *)dest_data != NULL) + { + (*cl->cl_destroy) (data_type, dest_data); + *(VOID_STAR *) dest_data = NULL; + } + + if (*(VOID_STAR *) src_data == NULL) + *(VOID_STAR *) dest_data = NULL; + else + { + if (-1 == (*cl->cl_acopy) (data_type, src_data, dest_data)) + /* No need to destroy anything */ + return -1; + } + + src_data = (VOID_STAR) ((char *)src_data + sizeof_type); + dest_data = (VOID_STAR) ((char *)dest_data + sizeof_type); + + n--; + } + + return 0; +} + +int +_SLarray_aget_transfer_elem (SLang_Array_Type *at, int *indices, + VOID_STAR new_data, unsigned int sizeof_type, int is_ptr) +{ + VOID_STAR at_data; + + /* Since 1 element is being transferred, there is not need to coerse + * the array to linear. + */ + if (NULL == (at_data = get_data_addr (at, indices))) + return -1; + + return transfer_n_elements (at, new_data, at_data, sizeof_type, 1, is_ptr); +} + +/* Here the ind_at index-array is a 1-d array of indices. This function + * creates a 1-d array of made up of values of 'at' at the locations + * specified by the indices. The result is pushed. + */ +static int +aget_from_index_array (SLang_Array_Type *at, + SLang_Array_Type *ind_at) +{ + SLang_Array_Type *new_at; + int *indices, *indices_max; + unsigned char *new_data, *src_data; + unsigned int sizeof_type; + int is_ptr; + + if (-1 == coerse_array_to_linear (at)) + return -1; + + if (-1 == coerse_array_to_linear (ind_at)) + return -1; + + if (-1 == check_index_array_ranges (at, ind_at)) + return -1; + + if (NULL == (new_at = SLang_create_array (at->data_type, 0, NULL, ind_at->dims, 1))) + return -1; + + /* Since the index array is linear, I can address it directly */ + indices = (int *) ind_at->data; + indices_max = indices + ind_at->num_elements; + + src_data = (unsigned char *) at->data; + new_data = (unsigned char *) new_at->data; + sizeof_type = new_at->sizeof_type; + is_ptr = (new_at->flags & SLARR_DATA_VALUE_IS_POINTER); + + while (indices < indices_max) + { + unsigned int offset; + + offset = sizeof_type * (unsigned int)*indices; + if (-1 == transfer_n_elements (at, (VOID_STAR) new_data, + (VOID_STAR) (src_data + offset), + sizeof_type, 1, is_ptr)) + { + SLang_free_array (new_at); + return -1; + } + + new_data += sizeof_type; + indices++; + } + + return SLang_push_array (new_at, 1); +} + +/* This is extremely ugly. It is due to the fact that the index_objects + * may contain ranges. This is a utility function for the aget/aput + * routines + */ +static int +convert_nasty_index_objs (SLang_Array_Type *at, + SLang_Object_Type *index_objs, + unsigned int num_indices, + int **index_data, + int *range_buf, int *range_delta_buf, + int *max_dims, + unsigned int *num_elements, + int *is_array, int is_dim_array[SLARRAY_MAX_DIMS]) +{ + unsigned int i, total_num_elements; + SLang_Array_Type *ind_at; + + if (num_indices != at->num_dims) + { + SLang_verror (SL_INVALID_PARM, "Array requires %u indices", at->num_dims); + return -1; + } + + *is_array = 0; + total_num_elements = 1; + for (i = 0; i < num_indices; i++) + { + int max_index, min_index; + SLang_Object_Type *obj; + int at_dims_i; + + at_dims_i = at->dims[i]; + obj = index_objs + i; + range_delta_buf [i] = 0; + + if (obj->data_type == SLANG_INT_TYPE) + { + range_buf [i] = min_index = max_index = obj->v.int_val; + max_dims [i] = 1; + index_data[i] = range_buf + i; + is_dim_array[i] = 0; + } + else + { + *is_array = 1; + is_dim_array[i] = 1; + ind_at = obj->v.array_val; + + if (ind_at->flags & SLARR_DATA_VALUE_IS_RANGE) + { + SLarray_Range_Array_Type *r; + int delta; + int first_index, last_index; + + r = (SLarray_Range_Array_Type *) ind_at->data; + + /* In an array indexing context, range arrays have different + * semantics. Consider a[[0:10]]. Clearly this means elements + * 0-10 of a. But what does a[[0:-1]] mean? By itself, + * [0:-1] is a null matrix []. But, it is useful in an + * indexing context to allow -1 to refer to the last element + * of the array. Similarly, [-3:-1] refers to the last 3 + * elements. + * + * However, [-1:-3] does not refer to any of the elements. + */ + + /* FIXME: Priority=High; I think this is broken behavior + * and should be rethought. That is, a[[0:-1]] should + * specify no elements. That is, the behavior should be: + * [0:9] ==> first 9 elements + * [-3:-1] ==> last 3 elements + * [0:-1] ==> [] (no elements) + * [0:-1:-1] ==> [0, -1] ==> first and last elements + * [-1:-3] ==> [] + * + * Unfortunately, this is going to be difficult to fix + * because of the way rubber ranges are stored: + * [*] ==> [0:-1] + * + * Perhaps it is just best to document this behavior. + * Sigh. + */ + if ((first_index = r->first_index) < 0) + { + if (at_dims_i != 0) + first_index = (at_dims_i + first_index) % at_dims_i; + } + + if ((last_index = r->last_index) < 0) + { + if (at_dims_i != 0) + last_index = (at_dims_i + last_index) % at_dims_i; + } + + delta = r->delta; + + range_delta_buf [i] = delta; + range_buf[i] = first_index; + + if (delta > 0) + { + if (first_index > last_index) + max_dims[i] = min_index = max_index = 0; + else + { + max_index = min_index = first_index; + while (max_index + delta <= last_index) + max_index += delta; + max_dims [i] = 1 + (max_index - min_index) / delta; + } + } + else + { + if (first_index < last_index) + max_dims[i] = min_index = max_index = 0; + else + { + min_index = max_index = first_index; + while (min_index + delta >= last_index) + min_index += delta; + max_dims [i] = 1 + (max_index - min_index) / (-delta); + } + } + } + else + { + int *tmp, *tmp_max; + + if (0 == (max_dims[i] = ind_at->num_elements)) + { + total_num_elements = 0; + break; + } + + tmp = (int *) ind_at->data; + tmp_max = tmp + ind_at->num_elements; + index_data [i] = tmp; + + min_index = max_index = *tmp; + while (tmp < tmp_max) + { + if (max_index > *tmp) + max_index = *tmp; + if (min_index < *tmp) + min_index = *tmp; + + tmp++; + } + } + } + + if ((at_dims_i == 0) && (max_dims[i] == 0)) + { + total_num_elements = 0; + continue; + } + + if (max_index < 0) + max_index += at_dims_i; + if (min_index < 0) + min_index += at_dims_i; + + if ((min_index < 0) || (min_index >= at_dims_i) + || (max_index < 0) || (max_index >= at_dims_i)) + { + SLang_verror (SL_INVALID_PARM, "Array index %u ([%d:%d]) out of allowed range [0->%d]", + i, min_index, max_index, at_dims_i); + return -1; + } + + total_num_elements = total_num_elements * max_dims[i]; + } + + *num_elements = total_num_elements; + return 0; +} + +/* This routine pushes a 1-d vector of values from 'at' indexed by + * the objects 'index_objs'. These objects can either be integers or + * 1-d integer arrays. The fact that the 1-d arrays can be ranges + * makes this look ugly. + */ +static int +aget_from_indices (SLang_Array_Type *at, + SLang_Object_Type *index_objs, unsigned int num_indices) +{ + int *index_data [SLARRAY_MAX_DIMS]; + int range_buf [SLARRAY_MAX_DIMS]; + int range_delta_buf [SLARRAY_MAX_DIMS]; + int max_dims [SLARRAY_MAX_DIMS]; + unsigned int i, num_elements; + SLang_Array_Type *new_at; + int map_indices[SLARRAY_MAX_DIMS]; + int indices [SLARRAY_MAX_DIMS]; + unsigned int sizeof_type; + int is_ptr, ret, is_array; + char *new_data; + SLang_Class_Type *cl; + int is_dim_array[SLARRAY_MAX_DIMS]; + + if (-1 == convert_nasty_index_objs (at, index_objs, num_indices, + index_data, range_buf, range_delta_buf, + max_dims, &num_elements, &is_array, + is_dim_array)) + return -1; + + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + sizeof_type = at->sizeof_type; + + cl = _SLclass_get_class (at->data_type); + + if ((is_array == 0) && (num_elements == 1)) + { + new_data = (char *)cl->cl_transfer_buf; + memset (new_data, 0, sizeof_type); + new_at = NULL; + } + else + { + int i_num_elements = (int)num_elements; + + new_at = SLang_create_array (at->data_type, 0, NULL, &i_num_elements, 1); + if (NULL == new_at) + return -1; + if (num_elements == 0) + return SLang_push_array (new_at, 1); + + new_data = (char *)new_at->data; + } + + SLMEMSET((char *) map_indices, 0, sizeof(map_indices)); + do + { + for (i = 0; i < num_indices; i++) + { + int j; + + j = map_indices[i]; + + if (0 != range_delta_buf[i]) + indices[i] = range_buf[i] + j * range_delta_buf[i]; + else + indices[i] = index_data [i][j]; + } + + if (-1 == _SLarray_aget_transfer_elem (at, indices, (VOID_STAR)new_data, sizeof_type, is_ptr)) + { + SLang_free_array (new_at); + return -1; + } + new_data += sizeof_type; + } + while (0 == _SLarray_next_index (map_indices, max_dims, num_indices)); + + if (new_at != NULL) + { + int num_dims = 0; + /* Fixup dimensions on array */ + for (i = 0; i < num_indices; i++) + { + if (is_dim_array[i]) /* was: (max_dims[i] > 1) */ + { + new_at->dims[num_dims] = max_dims[i]; + num_dims++; + } + } + + if (num_dims != 0) new_at->num_dims = num_dims; + return SLang_push_array (new_at, 1); + } + + /* Here new_data is a whole new copy, so free it after the push */ + new_data -= sizeof_type; + if (is_ptr && (*(VOID_STAR *)new_data == NULL)) + ret = SLang_push_null (); + else + { + ret = (*cl->cl_apush) (at->data_type, (VOID_STAR)new_data); + (*cl->cl_adestroy) (at->data_type, (VOID_STAR)new_data); + } + + return ret; +} + +static int push_string_as_array (unsigned char *s, unsigned int len) +{ + int ilen; + SLang_Array_Type *at; + + ilen = (int) len; + + at = SLang_create_array (SLANG_UCHAR_TYPE, 0, NULL, &ilen, 1); + if (at == NULL) + return -1; + + memcpy ((char *)at->data, (char *)s, len); + return SLang_push_array (at, 1); +} + +static int pop_array_as_string (char **sp) +{ + SLang_Array_Type *at; + int ret; + + *sp = NULL; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE)) + return -1; + + ret = 0; + + if (NULL == (*sp = SLang_create_nslstring ((char *) at->data, at->num_elements))) + ret = -1; + + SLang_free_array (at); + return ret; +} + +static int pop_array_as_bstring (SLang_BString_Type **bs) +{ + SLang_Array_Type *at; + int ret; + + *bs = NULL; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE)) + return -1; + + ret = 0; + + if (NULL == (*bs = SLbstring_create ((unsigned char *) at->data, at->num_elements))) + ret = -1; + + SLang_free_array (at); + return ret; +} + +static int aget_from_array (unsigned int num_indices) +{ + SLang_Array_Type *at; + SLang_Object_Type index_objs [SLARRAY_MAX_DIMS]; + int ret; + int is_index_array; + unsigned int i; + + if (num_indices > SLARRAY_MAX_DIMS) + { + SLang_verror (SL_INVALID_PARM, "Number of dims must be less than %d", SLARRAY_MAX_DIMS); + return -1; + } + + if (-1 == pop_array (&at, 1)) + return -1; + + if (-1 == pop_indices (at, index_objs, num_indices, &is_index_array)) + { + SLang_free_array (at); + return -1; + } + + if (is_index_array == 0) + { +#if _SLANG_OPTIMIZE_FOR_SPEED + if ((num_indices == 1) && (index_objs[0].data_type == SLANG_INT_TYPE) + && (0 == (at->flags & (SLARR_DATA_VALUE_IS_RANGE|SLARR_DATA_VALUE_IS_POINTER))) + && (1 == at->num_dims) + && (at->data != NULL)) + { + int ofs = index_objs[0].v.int_val; + if (ofs < 0) ofs += at->dims[0]; + if ((ofs >= at->dims[0]) || (ofs < 0)) + ret = aget_from_indices (at, index_objs, num_indices); + else switch (at->data_type) + { + case SLANG_INT_TYPE: + ret = SLclass_push_int_obj (SLANG_INT_TYPE, *((int *)at->data + ofs)); + break; +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + ret = SLclass_push_double_obj (SLANG_DOUBLE_TYPE, *((double *)at->data + ofs)); + break; +#endif + default: + ret = aget_from_indices (at, index_objs, num_indices); + } + } + else +#endif + ret = aget_from_indices (at, index_objs, num_indices); + } + else + ret = aget_from_index_array (at, index_objs[0].v.array_val); + + SLang_free_array (at); + for (i = 0; i < num_indices; i++) + SLang_free_object (index_objs + i); + + return ret; +} + +static int push_string_element (unsigned char type, unsigned char *s, unsigned int len) +{ + int i; + + if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE) + { + char *str; + + /* The indices are array values. So, do this: */ + if (-1 == push_string_as_array (s, len)) + return -1; + + if (-1 == aget_from_array (1)) + return -1; + + if (type == SLANG_BSTRING_TYPE) + { + SLang_BString_Type *bs; + int ret; + + if (-1 == pop_array_as_bstring (&bs)) + return -1; + + ret = SLang_push_bstring (bs); + SLbstring_free (bs); + return ret; + } + + if (-1 == pop_array_as_string (&str)) + return -1; + return _SLang_push_slstring (str); /* frees s upon error */ + } + + if (-1 == SLang_pop_integer (&i)) + return -1; + + if (i < 0) i = i + (int)len; + if ((unsigned int) i > len) + i = len; /* get \0 character --- bstrings include it as well */ + + i = s[(unsigned int) i]; + + return SLang_push_integer (i); +} + +/* ARRAY[i, j, k] generates code: __args i j ...k ARRAY __aput/__aget + * Here i, j, ... k may be a mixture of integers and 1-d arrays, or + * a single array of indices. The index array is generated by the + * 'where' function. + * + * If ARRAY is of type DataType, then this function will create an array of + * the appropriate type. In that case, the indices i, j, ..., k must be + * integers. + */ +int _SLarray_aget (void) +{ + unsigned int num_indices; + int type; + int (*aget_fun) (unsigned char, unsigned int); + + num_indices = (SLang_Num_Function_Args - 1); + + type = SLang_peek_at_stack (); + switch (type) + { + case -1: + return -1; /* stack underflow */ + + case SLANG_DATATYPE_TYPE: + return push_create_new_array (); + + case SLANG_BSTRING_TYPE: + if (1 == num_indices) + { + SLang_BString_Type *bs; + int ret; + unsigned int len; + unsigned char *s; + + if (-1 == SLang_pop_bstring (&bs)) + return -1; + + if (NULL == (s = SLbstring_get_pointer (bs, &len))) + ret = -1; + else + ret = push_string_element (type, s, len); + + SLbstring_free (bs); + return ret; + } + break; + + case SLANG_STRING_TYPE: + if (1 == num_indices) + { + char *s; + int ret; + + if (-1 == SLang_pop_slstring (&s)) + return -1; + + ret = push_string_element (type, (unsigned char *)s, strlen (s)); + SLang_free_slstring (s); + return ret; + } + break; + + case SLANG_ARRAY_TYPE: + break; + + case SLANG_ASSOC_TYPE: + return _SLassoc_aget (type, num_indices); + + default: + aget_fun = _SLclass_get_class (type)->cl_aget; + if (NULL != aget_fun) + return (*aget_fun) (type, num_indices); + } + + return aget_from_array (num_indices); +} + +int +_SLarray_aput_transfer_elem (SLang_Array_Type *at, int *indices, + VOID_STAR data_to_put, unsigned int sizeof_type, int is_ptr) +{ + VOID_STAR at_data; + + /* Since 1 element is being transferred, there is no need to coerse + * the array to linear. + */ + if (NULL == (at_data = get_data_addr (at, indices))) + return -1; + + return transfer_n_elements (at, at_data, data_to_put, sizeof_type, 1, is_ptr); +} + +static int +aput_get_array_to_put (SLang_Class_Type *cl, unsigned int num_elements, int allow_array, + SLang_Array_Type **at_ptr, char **data_to_put, unsigned int *data_increment) +{ + unsigned char data_type; + int type; + SLang_Array_Type *at; + + *at_ptr = NULL; + + data_type = cl->cl_data_type; + type = SLang_peek_at_stack (); + + if (type != data_type) + { + if ((type != SLANG_NULL_TYPE) + || ((cl->cl_class_type != SLANG_CLASS_TYPE_PTR) + && (cl->cl_class_type != SLANG_CLASS_TYPE_MMT))) + { + if (-1 == SLclass_typecast (data_type, 1, allow_array)) + return -1; + } + else + { + /* This bit of code allows, e.g., a[10] = NULL; */ + *data_increment = 0; + *data_to_put = (char *) cl->cl_transfer_buf; + *((char **)cl->cl_transfer_buf) = NULL; + return SLdo_pop (); + } + } + + if ((data_type != SLANG_ARRAY_TYPE) + && (data_type != SLANG_ANY_TYPE) + && (SLANG_ARRAY_TYPE == SLang_peek_at_stack ())) + { + if (-1 == SLang_pop_array (&at, 0)) + return -1; + + if ((at->num_elements != num_elements) +#if 0 + || (at->num_dims != 1) +#endif + ) + { + SLang_verror (SL_TYPE_MISMATCH, "Array size is inappropriate for use with index-array"); + SLang_free_array (at); + return -1; + } + + *data_to_put = (char *) at->data; + *data_increment = at->sizeof_type; + *at_ptr = at; + return 0; + } + + *data_increment = 0; + *data_to_put = (char *) cl->cl_transfer_buf; + + if (-1 == (*cl->cl_apop)(data_type, (VOID_STAR) *data_to_put)) + return -1; + + return 0; +} + +static int +aput_from_indices (SLang_Array_Type *at, + SLang_Object_Type *index_objs, unsigned int num_indices) +{ + int *index_data [SLARRAY_MAX_DIMS]; + int range_buf [SLARRAY_MAX_DIMS]; + int range_delta_buf [SLARRAY_MAX_DIMS]; + int max_dims [SLARRAY_MAX_DIMS]; + unsigned int i, num_elements; + SLang_Array_Type *bt; + int map_indices[SLARRAY_MAX_DIMS]; + int indices [SLARRAY_MAX_DIMS]; + unsigned int sizeof_type; + int is_ptr, is_array, ret; + char *data_to_put; + unsigned int data_increment; + SLang_Class_Type *cl; + int is_dim_array [SLARRAY_MAX_DIMS]; + + if (-1 == convert_nasty_index_objs (at, index_objs, num_indices, + index_data, range_buf, range_delta_buf, + max_dims, &num_elements, &is_array, + is_dim_array)) + return -1; + + cl = at->cl; + + if (-1 == aput_get_array_to_put (cl, num_elements, is_array, + &bt, &data_to_put, &data_increment)) + return -1; + + sizeof_type = at->sizeof_type; + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + + ret = -1; + + SLMEMSET((char *) map_indices, 0, sizeof(map_indices)); + if (num_elements) do + { + for (i = 0; i < num_indices; i++) + { + int j; + + j = map_indices[i]; + + if (0 != range_delta_buf[i]) + indices[i] = range_buf[i] + j * range_delta_buf[i]; + else + indices[i] = index_data [i][j]; + } + + if (-1 == _SLarray_aput_transfer_elem (at, indices, (VOID_STAR)data_to_put, sizeof_type, is_ptr)) + goto return_error; + + data_to_put += data_increment; + } + while (0 == _SLarray_next_index (map_indices, max_dims, num_indices)); + + ret = 0; + + /* drop */ + + return_error: + if (bt == NULL) + { + if (is_ptr) + (*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR) data_to_put); + } + else SLang_free_array (bt); + + return ret; +} + +static int +aput_from_index_array (SLang_Array_Type *at, SLang_Array_Type *ind_at) +{ + int *indices, *indices_max; + unsigned int sizeof_type; + char *data_to_put, *dest_data; + unsigned int data_increment; + int is_ptr; + SLang_Array_Type *bt; + SLang_Class_Type *cl; + int ret; + + if (-1 == coerse_array_to_linear (at)) + return -1; + + if (-1 == coerse_array_to_linear (ind_at)) + return -1; + + if (-1 == check_index_array_ranges (at, ind_at)) + return -1; + + sizeof_type = at->sizeof_type; + + cl = at->cl; + + /* Note that if bt is returned as non NULL, then the array is a linear + * one. + */ + if (-1 == aput_get_array_to_put (cl, ind_at->num_elements, 1, + &bt, &data_to_put, &data_increment)) + return -1; + + /* Since the index array is linear, I can address it directly */ + indices = (int *) ind_at->data; + indices_max = indices + ind_at->num_elements; + + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + dest_data = (char *) at->data; + + ret = -1; + while (indices < indices_max) + { + unsigned int offset; + + offset = sizeof_type * (unsigned int)*indices; + + if (-1 == transfer_n_elements (at, (VOID_STAR) (dest_data + offset), + (VOID_STAR) data_to_put, sizeof_type, 1, + is_ptr)) + goto return_error; + + indices++; + data_to_put += data_increment; + } + + ret = 0; + /* Drop */ + + return_error: + + if (bt == NULL) + { + if (is_ptr) + (*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR)data_to_put); + } + else SLang_free_array (bt); + + return ret; +} + +/* ARRAY[i, j, k] = generates code: __args i j k ARRAY __aput + */ +int _SLarray_aput (void) +{ + unsigned int num_indices; + SLang_Array_Type *at; + SLang_Object_Type index_objs [SLARRAY_MAX_DIMS]; + int ret; + int is_index_array; + int (*aput_fun) (unsigned char, unsigned int); + int type; + + ret = -1; + num_indices = (SLang_Num_Function_Args - 1); + + type = SLang_peek_at_stack (); + switch (type) + { + case -1: + return -1; + + case SLANG_ARRAY_TYPE: + break; + + case SLANG_ASSOC_TYPE: + return _SLassoc_aput (type, num_indices); + + default: + if (NULL != (aput_fun = _SLclass_get_class (type)->cl_aput)) + return (*aput_fun) (type, num_indices); + break; + } + + if (-1 == SLang_pop_array (&at, 0)) + return -1; + + if (at->flags & SLARR_DATA_VALUE_IS_READ_ONLY) + { + SLang_verror (SL_READONLY_ERROR, "%s Array is read-only", + SLclass_get_datatype_name (at->data_type)); + SLang_free_array (at); + return -1; + } + + if (-1 == pop_indices (at, index_objs, num_indices, &is_index_array)) + { + SLang_free_array (at); + return -1; + } + + if (is_index_array == 0) + { +#if _SLANG_OPTIMIZE_FOR_SPEED + if ((num_indices == 1) && (index_objs[0].data_type == SLANG_INT_TYPE) + && (0 == (at->flags & (SLARR_DATA_VALUE_IS_RANGE|SLARR_DATA_VALUE_IS_POINTER))) + && (1 == at->num_dims) + && (at->data != NULL)) + { + int ofs = index_objs[0].v.int_val; + if (ofs < 0) ofs += at->dims[0]; + if ((ofs >= at->dims[0]) || (ofs < 0)) + ret = aput_from_indices (at, index_objs, num_indices); + else switch (at->data_type) + { + case SLANG_INT_TYPE: + ret = SLang_pop_integer (((int *)at->data + ofs)); + break; +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + ret = SLang_pop_double ((double *)at->data + ofs, NULL, NULL); + break; +#endif + default: + ret = aput_from_indices (at, index_objs, num_indices); + } + } + else +#endif + ret = aput_from_indices (at, index_objs, num_indices); + } + else + ret = aput_from_index_array (at, index_objs[0].v.array_val); + + SLang_free_array (at); + free_index_objects (index_objs, num_indices); + return ret; +} + +/* This is for 1-d matrices only. It is used by the sort function */ +static int push_element_at_index (SLang_Array_Type *at, int indx) +{ + VOID_STAR data; + + if (NULL == (data = get_data_addr (at, &indx))) + return -1; + + return push_element_at_addr (at, (VOID_STAR) data, 1); +} + +static SLang_Name_Type *Sort_Function; +static SLang_Array_Type *Sort_Array; + +#if _SLANG_OPTIMIZE_FOR_SPEED +static int double_sort_fun (int *a, int *b) +{ + double *da, *db; + + da = (double *) Sort_Array->data; + db = da + *b; + da = da + *a; + + if (*da > *db) return 1; + if (*da == *db) return 0; + return -1; +} +static int int_sort_fun (int *a, int *b) +{ + int *da, *db; + + da = (int *) Sort_Array->data; + db = da + *b; + da = da + *a; + + if (*da > *db) return 1; + if (*da == *db) return 0; + return -1; +} +#endif + +static int sort_cmp_fun (int *a, int *b) +{ + int cmp; + + if (SLang_Error + || (-1 == push_element_at_index (Sort_Array, *a)) + || (-1 == push_element_at_index (Sort_Array, *b)) + || (-1 == SLexecute_function (Sort_Function)) + || (-1 == SLang_pop_integer (&cmp))) + { + /* DO not allow qsort to loop forever. Return something meaningful */ + if (*a > *b) return 1; + if (*a < *b) return -1; + return 0; + } + + return cmp; +} + +static int builtin_sort_cmp_fun (int *a, int *b) +{ + VOID_STAR a_data; + VOID_STAR b_data; + SLang_Class_Type *cl; + + cl = Sort_Array->cl; + + if ((SLang_Error == 0) + && (NULL != (a_data = get_data_addr (Sort_Array, a))) + && (NULL != (b_data = get_data_addr (Sort_Array, b)))) + { + int cmp; + + if ((Sort_Array->flags & SLARR_DATA_VALUE_IS_POINTER) + && ((*(VOID_STAR *) a_data == NULL) || (*(VOID_STAR *) a_data == NULL))) + { + SLang_verror (SL_VARIABLE_UNINITIALIZED, + "%s array has unitialized element", cl->cl_name); + } + else if (0 == (*cl->cl_cmp)(Sort_Array->data_type, a_data, b_data, &cmp)) + return cmp; + } + + + if (*a > *b) return 1; + if (*a == *b) return 0; + return -1; +} + +static void sort_array_internal (SLang_Array_Type *at_str, + SLang_Name_Type *entry, + int (*sort_fun)(int *, int *)) +{ + SLang_Array_Type *ind_at; + /* This is a silly hack to make up for braindead compilers and the lack of + * uniformity in prototypes for qsort. + */ + void (*qsort_fun) (char *, unsigned int, int, int (*)(int *, int *)); + int *indx; + int i, n; + int dims[1]; + + if (Sort_Array != NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, "array_sort is not recursive"); + return; + } + + n = at_str->num_elements; + + if (at_str->num_dims != 1) + { + SLang_verror (SL_INVALID_PARM, "sort is restricted to 1 dim arrays"); + return; + } + + dims [0] = n; + + if (NULL == (ind_at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, dims, 1))) + return; + + indx = (int *) ind_at->data; + for (i = 0; i < n; i++) indx[i] = i; + + if (n > 1) + { + qsort_fun = (void (*)(char *, unsigned int, int, int (*)(int *, + int *))) + qsort; + + Sort_Array = at_str; + Sort_Function = entry; + (*qsort_fun) ((char *) indx, n, sizeof (int), sort_fun); + } + + Sort_Array = NULL; + (void) SLang_push_array (ind_at, 1); +} + +static void sort_array (void) +{ + SLang_Name_Type *entry; + SLang_Array_Type *at; + int (*sort_fun) (int *, int *); + + if (SLang_Num_Function_Args != 1) + { + sort_fun = sort_cmp_fun; + + if (NULL == (entry = SLang_pop_function ())) + return; + + if (-1 == SLang_pop_array (&at, 1)) + return; + } + else + { + if (-1 == SLang_pop_array (&at, 1)) + return; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (at->data_type == SLANG_DOUBLE_TYPE) + sort_fun = double_sort_fun; + else if (at->data_type == SLANG_INT_TYPE) + sort_fun = int_sort_fun; + else +#endif + sort_fun = builtin_sort_cmp_fun; + + if (at->cl->cl_cmp == NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "%s does not have a predefined sorting method", + at->cl->cl_name); + SLang_free_array (at); + return; + } + entry = NULL; + } + + sort_array_internal (at, entry, sort_fun); + SLang_free_array (at); + SLang_free_function (entry); +} + +static void bstring_to_array (SLang_BString_Type *bs) +{ + unsigned char *s; + unsigned int len; + + if (NULL == (s = SLbstring_get_pointer (bs, &len))) + (void) SLang_push_null (); + else + (void) push_string_as_array (s, len); +} + +static void array_to_bstring (SLang_Array_Type *at) +{ + unsigned int nbytes; + SLang_BString_Type *bs; + + nbytes = at->num_elements * at->sizeof_type; + bs = SLbstring_create ((unsigned char *)at->data, nbytes); + (void) SLang_push_bstring (bs); + SLbstring_free (bs); +} + +static void init_char_array (void) +{ + SLang_Array_Type *at; + char *s; + unsigned int n, ndim; + + if (SLang_pop_slstring (&s)) return; + + if (-1 == SLang_pop_array (&at, 0)) + goto free_and_return; + + if (at->data_type != SLANG_CHAR_TYPE) + { + SLang_doerror("Operation requires character array"); + goto free_and_return; + } + + n = strlen (s); + ndim = at->num_elements; + if (n > ndim) + { + SLang_doerror("String too big to init array"); + goto free_and_return; + } + + strncpy((char *) at->data, s, ndim); + /* drop */ + + free_and_return: + SLang_free_array (at); + SLang_free_slstring (s); +} + +static void array_info (void) +{ + SLang_Array_Type *at, *bt; + int num_dims; + + if (-1 == pop_array (&at, 1)) + return; + + num_dims = (int)at->num_dims; + + if (NULL != (bt = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &num_dims, 1))) + { + int *bdata; + int i; + int *a_dims; + + a_dims = at->dims; + bdata = (int *) bt->data; + for (i = 0; i < num_dims; i++) bdata [i] = a_dims [i]; + + if (0 == SLang_push_array (bt, 1)) + { + (void) SLang_push_integer ((int) at->num_dims); + (void) SLang_push_datatype (at->data_type); + } + } + + SLang_free_array (at); +} + +static VOID_STAR range_get_data_addr (SLang_Array_Type *at, int *dims) +{ + static int value; + SLarray_Range_Array_Type *r; + int d; + + d = *dims; + r = (SLarray_Range_Array_Type *)at->data; + + if (d < 0) + d += at->dims[0]; + + value = r->first_index + d * r->delta; + return (VOID_STAR) &value; +} + +static SLang_Array_Type *inline_implicit_int_array (int *xminptr, int *xmaxptr, int *dxptr) +{ + int delta; + SLang_Array_Type *at; + int dims, idims; + SLarray_Range_Array_Type *data; + + if (dxptr == NULL) delta = 1; + else delta = *dxptr; + + if (delta == 0) + { + SLang_verror (SL_INVALID_PARM, "range-array increment must be non-zero"); + return NULL; + } + + data = (SLarray_Range_Array_Type *) SLmalloc (sizeof (SLarray_Range_Array_Type)); + if (data == NULL) + return NULL; + + SLMEMSET((char *) data, 0, sizeof (SLarray_Range_Array_Type)); + data->delta = delta; + dims = 0; + + if (xminptr != NULL) + data->first_index = *xminptr; + else + data->first_index = 0; + + if (xmaxptr != NULL) + data->last_index = *xmaxptr; + else + data->last_index = -1; + +/* if ((xminptr != NULL) && (xmaxptr != NULL)) + { */ + idims = 1 + (data->last_index - data->first_index) / delta; + if (idims > 0) + dims = idims; + /* } */ + + if (NULL == (at = SLang_create_array (SLANG_INT_TYPE, 0, (VOID_STAR) data, &dims, 1))) + return NULL; + + at->index_fun = range_get_data_addr; + at->flags |= SLARR_DATA_VALUE_IS_RANGE; + + return at; +} + +#if SLANG_HAS_FLOAT +static SLang_Array_Type *inline_implicit_floating_array (unsigned char type, + double *xminptr, double *xmaxptr, double *dxptr) +{ + int n, i; + SLang_Array_Type *at; + int dims; + double xmin, xmax, dx; + + if ((xminptr == NULL) || (xmaxptr == NULL)) + { + SLang_verror (SL_INVALID_PARM, "range-array has unknown size"); + return NULL; + } + xmin = *xminptr; + xmax = *xmaxptr; + if (dxptr == NULL) dx = 1.0; + else dx = *dxptr; + + if (dx == 0.0) + { + SLang_doerror ("range-array increment must be non-zero"); + return NULL; + } + + /* I have convinced myself that it is better to use semi-open intervals + * because of less ambiguities. So, [a:b:c] will represent the set of + * values a, a + c, a + 2c ... a + nc + * such that a + nc < b. That is, b lies outside the interval. + */ + + /* Allow for roundoff by adding 0.5 before truncation */ + n = (int)(1.5 + ((xmax - xmin) / dx)); + if (n <= 0) + n = 0; + else + { + double last = xmin + (n-1) * dx; + + if (dx > 0.0) + { + if (last >= xmax) + n -= 1; + } + else if (last <= xmax) + n -= 1; + } + + dims = n; + if (NULL == (at = SLang_create_array1 (type, 0, NULL, &dims, 1, 1))) + return NULL; + + if (type == SLANG_DOUBLE_TYPE) + { + double *ptr; + + ptr = (double *) at->data; + + for (i = 0; i < n; i++) + ptr[i] = xmin + i * dx; + } + else + { + float *ptr; + + ptr = (float *) at->data; + + for (i = 0; i < n; i++) + ptr[i] = (float) (xmin + i * dx); + } + return at; +} +#endif + +/* FIXME: Priority=medium + * This needs to be updated to work with all integer types. + */ +int _SLarray_inline_implicit_array (void) +{ + int int_vals[3]; +#if SLANG_HAS_FLOAT + double double_vals[3]; + int is_int; +#endif + int has_vals[3]; + unsigned int i, count; + SLang_Array_Type *at; + int precedence; + unsigned char type; + + count = SLang_Num_Function_Args; + + if (count == 2) + has_vals [2] = 0; + else if (count != 3) + { + SLang_doerror ("wrong number of arguments to __implicit_inline_array"); + return -1; + } + +#if SLANG_HAS_FLOAT + is_int = 1; +#endif + + type = 0; + precedence = 0; + + i = count; + while (i--) + { + int this_type, this_precedence; + + if (-1 == (this_type = SLang_peek_at_stack ())) + return -1; + + this_precedence = _SLarith_get_precedence ((unsigned char) this_type); + if (precedence < this_precedence) + { + type = (unsigned char) this_type; + precedence = this_precedence; + } + + has_vals [i] = 1; + + switch (this_type) + { + case SLANG_NULL_TYPE: + has_vals[i] = 0; + (void) SLdo_pop (); + break; + +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + case SLANG_FLOAT_TYPE: + if (-1 == SLang_pop_double (double_vals + i, NULL, NULL)) + return -1; + is_int = 0; + break; +#endif + default: + if (-1 == SLang_pop_integer (int_vals + i)) + return -1; +#if SLANG_HAS_FLOAT + double_vals[i] = (double) int_vals[i]; +#endif + } + } + +#if SLANG_HAS_FLOAT + if (is_int == 0) + at = inline_implicit_floating_array (type, + (has_vals[0] ? &double_vals[0] : NULL), + (has_vals[1] ? &double_vals[1] : NULL), + (has_vals[2] ? &double_vals[2] : NULL)); + else +#endif + at = inline_implicit_int_array ((has_vals[0] ? &int_vals[0] : NULL), + (has_vals[1] ? &int_vals[1] : NULL), + (has_vals[2] ? &int_vals[2] : NULL)); + + if (at == NULL) + return -1; + + return SLang_push_array (at, 1); +} + +int _SLarray_wildcard_array (void) +{ + SLang_Array_Type *at; + + if (NULL == (at = inline_implicit_int_array (NULL, NULL, NULL))) + return -1; + + return SLang_push_array (at, 1); +} + +static SLang_Array_Type *concat_arrays (unsigned int count) +{ + SLang_Array_Type **arrays; + SLang_Array_Type *at, *bt; + unsigned int i; + int num_elements; + unsigned char type; + char *src_data, *dest_data; + int is_ptr; + unsigned int sizeof_type; + int max_dims, min_dims, max_rows, min_rows; + + arrays = (SLang_Array_Type **)SLmalloc (count * sizeof (SLang_Array_Type *)); + if (arrays == NULL) + { + SLdo_pop_n (count); + return NULL; + } + SLMEMSET((char *) arrays, 0, count * sizeof(SLang_Array_Type *)); + + at = NULL; + + num_elements = 0; + i = count; + + while (i != 0) + { + i--; + + if (-1 == SLang_pop_array (&bt, 1)) + goto free_and_return; + + arrays[i] = bt; + num_elements += (int)bt->num_elements; + } + + type = arrays[0]->data_type; + max_dims = min_dims = arrays[0]->num_dims; + min_rows = max_rows = arrays[0]->dims[0]; + + for (i = 1; i < count; i++) + { + SLang_Array_Type *ct; + int num; + + bt = arrays[i]; + + num = bt->num_dims; + if (num > max_dims) max_dims = num; + if (num < min_dims) min_dims = num; + + num = bt->dims[0]; + if (num > max_rows) max_rows = num; + if (num < min_rows) min_rows = num; + + if (type == bt->data_type) + continue; + + if (1 != _SLarray_typecast (bt->data_type, (VOID_STAR) &bt, 1, + type, (VOID_STAR) &ct, 1)) + goto free_and_return; + + SLang_free_array (bt); + arrays [i] = ct; + } + + if (NULL == (at = SLang_create_array (type, 0, NULL, &num_elements, 1))) + goto free_and_return; + + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + sizeof_type = at->sizeof_type; + dest_data = (char *) at->data; + + for (i = 0; i < count; i++) + { + bt = arrays[i]; + + src_data = (char *) bt->data; + num_elements = bt->num_elements; + + if (-1 == transfer_n_elements (bt, (VOID_STAR)dest_data, (VOID_STAR)src_data, sizeof_type, + num_elements, is_ptr)) + { + SLang_free_array (at); + at = NULL; + goto free_and_return; + } + + dest_data += num_elements * sizeof_type; + } + +#if 0 + /* If the arrays are all 1-d, and all the same size, then reshape to a + * 2-d array. This will allow us to do, e.g. + * a = [[1,2], [3,4]] + * to specifiy a 2-d. + * Someday I will generalize this. + */ + /* This is a bad idea. Everyone using it expects concatenation to happen. + * Perhaps I will extend the syntax to allow a 2-d array to be expressed + * as [[1,2];[3,4]]. + */ + if ((max_dims == min_dims) && (max_dims == 1) && (min_rows == max_rows)) + { + at->num_dims = 2; + at->dims[0] = count; + at->dims[1] = min_rows; + } +#endif + free_and_return: + + for (i = 0; i < count; i++) + SLang_free_array (arrays[i]); + SLfree ((char *) arrays); + + return at; +} + +int _SLarray_inline_array (void) +{ + SLang_Object_Type *obj, *objmin; + unsigned char type, this_type; + unsigned int count; + SLang_Array_Type *at; + + obj = _SLang_get_run_stack_pointer (); + objmin = _SLang_get_run_stack_base (); + + count = SLang_Num_Function_Args; + type = 0; + + while ((count > 0) && (--obj >= objmin)) + { + this_type = obj->data_type; + + if (type == 0) + type = this_type; + + if ((type == this_type) || (type == SLANG_ARRAY_TYPE)) + { + count--; + continue; + } + + switch (this_type) + { + case SLANG_ARRAY_TYPE: + type = SLANG_ARRAY_TYPE; + break; +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + if (0 == _SLang_is_arith_type (type)) + goto type_mismatch; + + type = this_type; + break; +#endif + default: + if (0 == _SLang_is_arith_type(this_type)) + goto type_mismatch; + + if (type == SLANG_COMPLEX_TYPE) + break; + + if (0 == _SLang_is_arith_type (type)) + goto type_mismatch; + + if (_SLarith_get_precedence (this_type) > _SLarith_get_precedence (type)) + type = this_type; + break; + } + count--; + } + + if (count != 0) + { + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + + count = SLang_Num_Function_Args; + + if (count == 0) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Empty inline-arrays not supported"); + return -1; + } + + if (type == SLANG_ARRAY_TYPE) + { + if (NULL == (at = concat_arrays (count))) + return -1; + } + else + { + SLang_Object_Type index_obj; + int icount = (int) count; + + if (NULL == (at = SLang_create_array (type, 0, NULL, &icount, 1))) + return -1; + + index_obj.data_type = SLANG_INT_TYPE; + while (count != 0) + { + count--; + index_obj.v.int_val = (int) count; + if (-1 == aput_from_indices (at, &index_obj, 1)) + { + SLang_free_array (at); + SLdo_pop_n (count); + return -1; + } + } + } + + return SLang_push_array (at, 1); + + type_mismatch: + _SLclass_type_mismatch_error (type, this_type); + return -1; +} + +static int array_binary_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) op; + (void) a; + (void) b; + *c = SLANG_ARRAY_TYPE; + return 1; +} + +static int array_binary_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + SLang_Array_Type *at, *bt, *ct; + unsigned int i, num_dims; + int (*binary_fun) (int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR); + SLang_Class_Type *a_cl, *b_cl, *c_cl; + int no_init; + + if (a_type == SLANG_ARRAY_TYPE) + { + if (na != 1) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Binary operation on multiple arrays not implemented"); + return -1; + } + + at = *(SLang_Array_Type **) ap; + if (-1 == coerse_array_to_linear (at)) + return -1; + ap = at->data; + a_type = at->data_type; + na = at->num_elements; + } + else + { + at = NULL; + } + + if (b_type == SLANG_ARRAY_TYPE) + { + if (nb != 1) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Binary operation on multiple arrays not implemented"); + return -1; + } + + bt = *(SLang_Array_Type **) bp; + if (-1 == coerse_array_to_linear (bt)) + return -1; + bp = bt->data; + b_type = bt->data_type; + nb = bt->num_elements; + } + else + { + bt = NULL; + } + + if ((at != NULL) && (bt != NULL)) + { + num_dims = at->num_dims; + + if (num_dims != bt->num_dims) + { + SLang_verror (SL_TYPE_MISMATCH, "Arrays must have same dim for binary operation"); + return -1; + } + + for (i = 0; i < num_dims; i++) + { + if (at->dims[i] != bt->dims[i]) + { + SLang_verror (SL_TYPE_MISMATCH, "Arrays must be the same for binary operation"); + return -1; + } + } + } + + a_cl = _SLclass_get_class (a_type); + b_cl = _SLclass_get_class (b_type); + + if (NULL == (binary_fun = _SLclass_get_binary_fun (op, a_cl, b_cl, &c_cl, 1))) + return -1; + + no_init = ((c_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + || (c_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR)); + + ct = NULL; +#if _SLANG_USE_TMP_OPTIMIZATION + /* If we are dealing with scalar (or vector) objects, and if the object + * appears to be owned by the stack, then use it instead of creating a + * new version. This can happen with code such as: + * @ x = [1,2,3,4]; + * @ x = __tmp(x) + 1; + */ + if (no_init) + { + if ((at != NULL) + && (at->num_refs == 1) + && (at->data_type == c_cl->cl_data_type)) + { + ct = at; + ct->num_refs = 2; + } + else if ((bt != NULL) + && (bt->num_refs == 1) + && (bt->data_type == c_cl->cl_data_type)) + { + ct = bt; + ct->num_refs = 2; + } + } +#endif /* _SLANG_USE_TMP_OPTIMIZATION */ + + if (ct == NULL) + { + if (at != NULL) ct = at; else ct = bt; + ct = SLang_create_array1 (c_cl->cl_data_type, 0, NULL, ct->dims, ct->num_dims, no_init); + if (ct == NULL) + return -1; + } + + + if ((na == 0) || (nb == 0) /* allow empty arrays */ + || (1 == (*binary_fun) (op, a_type, ap, na, b_type, bp, nb, ct->data))) + { + *(SLang_Array_Type **) cp = ct; + return 1; + } + + SLang_free_array (ct); + return -1; +} + +static void is_null_intrinsic (SLang_Array_Type *at) +{ + SLang_Array_Type *bt; + + bt = SLang_create_array (SLANG_CHAR_TYPE, 0, NULL, at->dims, at->num_dims); + if (bt == NULL) + return; + + if (at->flags & SLARR_DATA_VALUE_IS_POINTER) + { + char *cdata, *cdata_max; + char **data; + + if (-1 == coerse_array_to_linear (at)) + { + SLang_free_array (bt); + return; + } + + cdata = (char *)bt->data; + cdata_max = cdata + bt->num_elements; + data = (char **)at->data; + + while (cdata < cdata_max) + { + if (*data == NULL) + *cdata = 1; + + data++; + cdata++; + } + } + + SLang_push_array (bt, 1); +} + + +static void array_where (void) +{ + SLang_Array_Type *at, *bt; + char *a_data; + int *b_data; + unsigned int i, num_elements; + int b_num; + + if (-1 == SLang_pop_array (&at, 1)) + return; + + bt = NULL; + + if (at->data_type != SLANG_CHAR_TYPE) + { + int zero; + SLang_Array_Type *tmp_at; + + tmp_at = at; + zero = 0; + if (1 != array_binary_op (SLANG_NE, + SLANG_ARRAY_TYPE, (VOID_STAR) &at, 1, + SLANG_CHAR_TYPE, (VOID_STAR) &zero, 1, + (VOID_STAR) &tmp_at)) + goto return_error; + + SLang_free_array (at); + at = tmp_at; + if (at->data_type != SLANG_CHAR_TYPE) + { + SLang_Error = SL_TYPE_MISMATCH; + goto return_error; + } + } + + a_data = (char *) at->data; + num_elements = at->num_elements; + + b_num = 0; + for (i = 0; i < num_elements; i++) + if (a_data[i] != 0) b_num++; + + if (NULL == (bt = SLang_create_array1 (SLANG_INT_TYPE, 0, NULL, &b_num, 1, 1))) + goto return_error; + + b_data = (int *) bt->data; + + i = 0; + while (b_num) + { + if (a_data[i] != 0) + { + *b_data++ = i; + b_num--; + } + + i++; + } + + (void) SLang_push_array (bt, 0); + /* drop */ + + return_error: + SLang_free_array (at); + SLang_free_array (bt); +} + +static int do_array_reshape (SLang_Array_Type *at, SLang_Array_Type *ind_at) +{ + int *dims; + unsigned int i, num_dims; + unsigned int num_elements; + + if ((ind_at->data_type != SLANG_INT_TYPE) + || (ind_at->num_dims != 1)) + { + SLang_verror (SL_TYPE_MISMATCH, "Expecting 1-d integer array"); + return -1; + } + + num_dims = ind_at->num_elements; + dims = (int *) ind_at->data; + + num_elements = 1; + for (i = 0; i < num_dims; i++) + { + int d = dims[i]; + if (d < 0) + { + SLang_verror (SL_INVALID_PARM, "reshape: dimension is less then 0"); + return -1; + } + + num_elements = (unsigned int) d * num_elements; + } + + if ((num_elements != at->num_elements) + || (num_dims > SLARRAY_MAX_DIMS)) + { + SLang_verror (SL_INVALID_PARM, "Unable to reshape array to specified size"); + return -1; + } + + for (i = 0; i < num_dims; i++) + at->dims [i] = dims[i]; + + while (i < SLARRAY_MAX_DIMS) + { + at->dims [i] = 1; + i++; + } + + at->num_dims = num_dims; + return 0; +} + +static void array_reshape (SLang_Array_Type *at, SLang_Array_Type *ind_at) +{ + (void) do_array_reshape (at, ind_at); +} + +static void _array_reshape (SLang_Array_Type *ind_at) +{ + SLang_Array_Type *at; + SLang_Array_Type *new_at; + + if (-1 == SLang_pop_array (&at, 1)) + return; + + /* FIXME: Priority=low: duplicate_array could me modified to look at num_refs */ + + /* Now try to avoid the overhead of creating a new array if possible */ + if (at->num_refs == 1) + { + /* Great, we are the sole owner of this array. */ + if ((-1 == do_array_reshape (at, ind_at)) + || (-1 == SLclass_push_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR)at))) + SLang_free_array (at); + return; + } + + new_at = SLang_duplicate_array (at); + if (new_at != NULL) + { + if (0 == do_array_reshape (new_at, ind_at)) + (void) SLang_push_array (new_at, 0); + + SLang_free_array (new_at); + } + SLang_free_array (at); +} + +typedef struct +{ + SLang_Array_Type *at; + unsigned int increment; + char *addr; +} +Map_Arg_Type; +/* Usage: array_map (Return-Type, func, args,....); */ +static void array_map (void) +{ + Map_Arg_Type *args; + unsigned int num_args; + unsigned int i, i_control; + SLang_Name_Type *nt; + unsigned int num_elements; + SLang_Array_Type *at; + char *addr; + unsigned char type; + + at = NULL; + args = NULL; + nt = NULL; + + if (SLang_Num_Function_Args < 3) + { + SLang_verror (SL_INVALID_PARM, + "Usage: array_map (Return-Type, &func, args...)"); + SLdo_pop_n (SLang_Num_Function_Args); + return; + } + + num_args = (unsigned int)SLang_Num_Function_Args - 2; + args = (Map_Arg_Type *) SLmalloc (num_args * sizeof (Map_Arg_Type)); + if (args == NULL) + { + SLdo_pop_n (SLang_Num_Function_Args); + return; + } + memset ((char *) args, 0, num_args * sizeof (Map_Arg_Type)); + i = num_args; + i_control = 0; + while (i > 0) + { + i--; + if (-1 == SLang_pop_array (&args[i].at, 1)) + { + SLdo_pop_n (i + 2); + goto return_error; + } + if (args[i].at->num_elements > 1) + i_control = i; + } + + if (NULL == (nt = SLang_pop_function ())) + { + SLdo_pop_n (1); + goto return_error; + } + + num_elements = args[i_control].at->num_elements; + + if (-1 == SLang_pop_datatype (&type)) + goto return_error; + + if (type == SLANG_UNDEFINED_TYPE) /* Void_Type */ + at = NULL; + else + { + at = args[i_control].at; + + if (NULL == (at = SLang_create_array (type, 0, NULL, at->dims, at->num_dims))) + goto return_error; + } + + + for (i = 0; i < num_args; i++) + { + SLang_Array_Type *ati = args[i].at; + /* FIXME: Priority = low: The actual dimensions should be compared. */ + if (ati->num_elements == num_elements) + args[i].increment = ati->sizeof_type; + /* memset already guarantees increment to be zero */ + + /* FIXME: array_map on an empty array should return an empty array + * and not generate an error. + */ + if (ati->num_elements == 0) + { + SLang_verror (0, "array_map: function argument %d of %d is an empty array", + i+1, num_args); + goto return_error; + } + + args[i].addr = (char *) ati->data; + } + + if (at == NULL) + addr = NULL; + else + addr = (char *)at->data; + + for (i = 0; i < num_elements; i++) + { + unsigned int j; + + if (-1 == SLang_start_arg_list ()) + goto return_error; + + for (j = 0; j < num_args; j++) + { + if (-1 == push_element_at_addr (args[j].at, + (VOID_STAR) args[j].addr, + 1)) + { + SLdo_pop_n (j); + goto return_error; + } + + args[j].addr += args[j].increment; + } + + if (-1 == SLang_end_arg_list ()) + { + SLdo_pop_n (num_args); + goto return_error; + } + + if (-1 == SLexecute_function (nt)) + goto return_error; + + if (at == NULL) + continue; + + if (-1 == at->cl->cl_apop (type, (VOID_STAR) addr)) + goto return_error; + + addr += at->sizeof_type; + } + + if (at != NULL) + (void) SLang_push_array (at, 0); + + /* drop */ + + return_error: + SLang_free_array (at); + SLang_free_function (nt); + if (args != NULL) + { + for (i = 0; i < num_args; i++) + SLang_free_array (args[i].at); + + SLfree ((char *) args); + } +} + +static SLang_Intrin_Fun_Type Array_Table [] = +{ + MAKE_INTRINSIC_0("array_map", array_map, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("array_sort", sort_array, SLANG_VOID_TYPE), + MAKE_INTRINSIC_1("array_to_bstring", array_to_bstring, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), + MAKE_INTRINSIC_1("bstring_to_array", bstring_to_array, SLANG_VOID_TYPE, SLANG_BSTRING_TYPE), + MAKE_INTRINSIC("init_char_array", init_char_array, SLANG_VOID_TYPE, 0), + MAKE_INTRINSIC_1("_isnull", is_null_intrinsic, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), + MAKE_INTRINSIC_0("array_info", array_info, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("where", array_where, SLANG_VOID_TYPE), + MAKE_INTRINSIC_2("reshape", array_reshape, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE, SLANG_ARRAY_TYPE), + MAKE_INTRINSIC_1("_reshape", _array_reshape, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +static char *array_string (unsigned char type, VOID_STAR v) +{ + SLang_Array_Type *at; + char buf[512]; + unsigned int i, num_dims; + int *dims; + + at = *(SLang_Array_Type **) v; + type = at->data_type; + num_dims = at->num_dims; + dims = at->dims; + + sprintf (buf, "%s[%d", SLclass_get_datatype_name (type), at->dims[0]); + + for (i = 1; i < num_dims; i++) + sprintf (buf + strlen(buf), ",%d", dims[i]); + strcat (buf, "]"); + + return SLmake_string (buf); +} + +static void array_destroy (unsigned char type, VOID_STAR v) +{ + (void) type; + SLang_free_array (*(SLang_Array_Type **) v); +} + +static int array_push (unsigned char type, VOID_STAR v) +{ + SLang_Array_Type *at; + + (void) type; + at = *(SLang_Array_Type **) v; + return SLang_push_array (at, 0); +} + +/* Intrinsic arrays are not stored in a variable. So, the address that + * would contain the variable holds the array address. + */ +static int array_push_intrinsic (unsigned char type, VOID_STAR v) +{ + (void) type; + return SLang_push_array ((SLang_Array_Type *) v, 0); +} + +int _SLarray_add_bin_op (unsigned char type) +{ + SL_OOBinary_Type *ab; + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + ab = cl->cl_binary_ops; + + while (ab != NULL) + { + if (ab->data_type == SLANG_ARRAY_TYPE) + return 0; + ab = ab->next; + } + + if ((-1 == SLclass_add_binary_op (SLANG_ARRAY_TYPE, type, array_binary_op, array_binary_op_result)) + || (-1 == SLclass_add_binary_op (type, SLANG_ARRAY_TYPE, array_binary_op, array_binary_op_result))) + return -1; + + return 0; +} + +static SLang_Array_Type * +do_array_math_op (int op, int unary_type, + SLang_Array_Type *at, unsigned int na) +{ + unsigned char a_type, b_type; + int (*f) (int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); + SLang_Array_Type *bt; + SLang_Class_Type *b_cl; + int no_init; + + if (na != 1) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Operation restricted to 1 array"); + return NULL; + } + + a_type = at->data_type; + if (NULL == (f = _SLclass_get_unary_fun (op, at->cl, &b_cl, unary_type))) + return NULL; + b_type = b_cl->cl_data_type; + + if (-1 == coerse_array_to_linear (at)) + return NULL; + + no_init = ((b_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + || (b_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR)); + +#if _SLANG_USE_TMP_OPTIMIZATION + /* If we are dealing with scalar (or vector) objects, and if the object + * appears to be owned by the stack, then use it instead of creating a + * new version. This can happen with code such as: + * @ x = [1,2,3,4]; + * @ x = UNARY_OP(__tmp(x)); + */ + if (no_init + && (at->num_refs == 1) + && (at->data_type == b_cl->cl_data_type)) + { + bt = at; + bt->num_refs = 2; + } + else +#endif /* _SLANG_USE_TMP_OPTIMIZATION */ + if (NULL == (bt = SLang_create_array1 (b_type, 0, NULL, at->dims, at->num_dims, no_init))) + return NULL; + + if (1 != (*f)(op, a_type, at->data, at->num_elements, bt->data)) + { + SLang_free_array (bt); + return NULL; + } + return bt; +} + +static int +array_unary_op_result (int op, unsigned char a, unsigned char *b) +{ + (void) op; + (void) a; + *b = SLANG_ARRAY_TYPE; + return 1; +} + +static int +array_unary_op (int op, + unsigned char a, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + SLang_Array_Type *at; + + (void) a; + at = *(SLang_Array_Type **) ap; + if (NULL == (at = do_array_math_op (op, _SLANG_BC_UNARY, at, na))) + { + if (SLang_Error) return -1; + return 0; + } + *(SLang_Array_Type **) bp = at; + return 1; +} + +static int +array_math_op (int op, + unsigned char a, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + SLang_Array_Type *at; + + (void) a; + at = *(SLang_Array_Type **) ap; + if (NULL == (at = do_array_math_op (op, _SLANG_BC_MATH_UNARY, at, na))) + { + if (SLang_Error) return -1; + return 0; + } + *(SLang_Array_Type **) bp = at; + return 1; +} + +static int +array_app_op (int op, + unsigned char a, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + SLang_Array_Type *at; + + (void) a; + at = *(SLang_Array_Type **) ap; + if (NULL == (at = do_array_math_op (op, _SLANG_BC_APP_UNARY, at, na))) + { + if (SLang_Error) return -1; + return 0; + } + *(SLang_Array_Type **) bp = at; + return 1; +} + +int +_SLarray_typecast (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, + int is_implicit) +{ + SLang_Array_Type *at, *bt; + SLang_Class_Type *b_cl; + int no_init; + int (*t) (unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR); + + if (na != 1) + { + SLang_verror (SL_NOT_IMPLEMENTED, "typecast of multiple arrays not implemented"); + return -1; + } + + at = *(SLang_Array_Type **) ap; + a_type = at->data_type; + + if (a_type == b_type) + { + at->num_refs += 1; + *(SLang_Array_Type **) bp = at; + return 1; + } + + if (NULL == (t = _SLclass_get_typecast (a_type, b_type, is_implicit))) + return -1; + + if (-1 == coerse_array_to_linear (at)) + return -1; + + b_cl = _SLclass_get_class (b_type); + + no_init = ((b_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + || (b_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR)); + + if (NULL == (bt = SLang_create_array1 (b_type, 0, NULL, at->dims, at->num_dims, no_init))) + return -1; + + if (1 == (*t) (a_type, at->data, at->num_elements, b_type, bt->data)) + { + *(SLang_Array_Type **) bp = bt; + return 1; + } + + SLang_free_array (bt); + return 0; +} + +SLang_Array_Type *SLang_duplicate_array (SLang_Array_Type *at) +{ + SLang_Array_Type *bt; + char *data, *a_data; + unsigned int i, num_elements, sizeof_type; + unsigned int size; + int (*cl_acopy) (unsigned char, VOID_STAR, VOID_STAR); + unsigned char type; + + if (-1 == coerse_array_to_linear (at)) + return NULL; + + type = at->data_type; + num_elements = at->num_elements; + sizeof_type = at->sizeof_type; + size = num_elements * sizeof_type; + + if (NULL == (data = SLmalloc (size))) + return NULL; + + if (NULL == (bt = SLang_create_array (type, 0, (VOID_STAR)data, at->dims, at->num_dims))) + { + SLfree (data); + return NULL; + } + + a_data = (char *) at->data; + if (0 == (at->flags & SLARR_DATA_VALUE_IS_POINTER)) + { + SLMEMCPY (data, a_data, size); + return bt; + } + + SLMEMSET (data, 0, size); + + cl_acopy = at->cl->cl_acopy; + for (i = 0; i < num_elements; i++) + { + if (NULL != *(VOID_STAR *) a_data) + { + if (-1 == (*cl_acopy) (type, (VOID_STAR) a_data, (VOID_STAR) data)) + { + SLang_free_array (bt); + return NULL; + } + } + + data += sizeof_type; + a_data += sizeof_type; + } + + return bt; +} + +static int array_dereference (unsigned char type, VOID_STAR addr) +{ + SLang_Array_Type *at; + + (void) type; + at = SLang_duplicate_array (*(SLang_Array_Type **) addr); + if (at == NULL) return -1; + return SLang_push_array (at, 1); +} + +/* This function gets called via, e.g., @Array_Type (Double_Type, [10,20]); + */ +static int +array_datatype_deref (unsigned char type) +{ + SLang_Array_Type *ind_at; + SLang_Array_Type *at; + +#if 0 + /* The parser generated code for this as if a function call were to be + * made. However, the interpreter simply called the deref object routine + * instead of the function call. So, I must simulate the function call. + * This needs to be formalized to hide this detail from applications + * who wish to do the same. So... + * FIXME: Priority=medium + */ + if (0 == _SL_increment_frame_pointer ()) + (void) _SL_decrement_frame_pointer (); +#endif + + if (-1 == SLang_pop_array (&ind_at, 1)) + return -1; + + if ((ind_at->data_type != SLANG_INT_TYPE) + || (ind_at->num_dims != 1)) + { + SLang_verror (SL_TYPE_MISMATCH, "Expecting 1-d integer array"); + goto return_error; + } + + if (-1 == SLang_pop_datatype (&type)) + goto return_error; + + if (NULL == (at = SLang_create_array (type, 0, NULL, + (int *) ind_at->data, + ind_at->num_elements))) + goto return_error; + + SLang_free_array (ind_at); + return SLang_push_array (at, 1); + + return_error: + SLang_free_array (ind_at); + return -1; +} + +static int array_length (unsigned char type, VOID_STAR v, unsigned int *len) +{ + SLang_Array_Type *at; + + (void) type; + at = *(SLang_Array_Type **) v; + *len = at->num_elements; + return 0; +} + +int +_SLarray_init_slarray (void) +{ + SLang_Class_Type *cl; + + if (-1 == SLadd_intrin_fun_table (Array_Table, NULL)) + return -1; + + if (NULL == (cl = SLclass_allocate_class ("Array_Type"))) + return -1; + + (void) SLclass_set_string_function (cl, array_string); + (void) SLclass_set_destroy_function (cl, array_destroy); + (void) SLclass_set_push_function (cl, array_push); + cl->cl_push_intrinsic = array_push_intrinsic; + cl->cl_dereference = array_dereference; + cl->cl_datatype_deref = array_datatype_deref; + cl->cl_length = array_length; + + if (-1 == SLclass_register_class (cl, SLANG_ARRAY_TYPE, sizeof (VOID_STAR), + SLANG_CLASS_TYPE_PTR)) + return -1; + + if ((-1 == SLclass_add_binary_op (SLANG_ARRAY_TYPE, SLANG_ARRAY_TYPE, array_binary_op, array_binary_op_result)) + || (-1 == SLclass_add_unary_op (SLANG_ARRAY_TYPE, array_unary_op, array_unary_op_result)) + || (-1 == SLclass_add_app_unary_op (SLANG_ARRAY_TYPE, array_app_op, array_unary_op_result)) + || (-1 == SLclass_add_math_op (SLANG_ARRAY_TYPE, array_math_op, array_unary_op_result))) + return -1; + + return 0; +} + +int SLang_pop_array (SLang_Array_Type **at_ptr, int convert_scalar) +{ + if (-1 == pop_array (at_ptr, convert_scalar)) + return -1; + + if (-1 == coerse_array_to_linear (*at_ptr)) + { + SLang_free_array (*at_ptr); + return -1; + } + return 0; +} + +int SLang_pop_array_of_type (SLang_Array_Type **at, unsigned char type) +{ + if (-1 == SLclass_typecast (type, 1, 1)) + return -1; + + return SLang_pop_array (at, 1); +} + +void (*_SLang_Matrix_Multiply)(void); + +int _SLarray_matrix_multiply (void) +{ + if (_SLang_Matrix_Multiply != NULL) + { + (*_SLang_Matrix_Multiply)(); + return 0; + } + SLang_verror (SL_NOT_IMPLEMENTED, "Matrix multiplication not available"); + return -1; +} + +struct _SLang_Foreach_Context_Type +{ + SLang_Array_Type *at; + unsigned int next_element_index; +}; + +SLang_Foreach_Context_Type * +_SLarray_cl_foreach_open (SLtype type, unsigned int num) +{ + SLang_Foreach_Context_Type *c; + + if (num != 0) + { + SLdo_pop_n (num + 1); + SLang_verror (SL_NOT_IMPLEMENTED, + "%s does not support 'foreach using' form", + SLclass_get_datatype_name (type)); + return NULL; + } + + if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type)))) + return NULL; + + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + + if (-1 == pop_array (&c->at, 1)) + { + SLfree ((char *) c); + return NULL; + } + + return c; +} + +void _SLarray_cl_foreach_close (SLtype type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + SLang_free_array (c->at); + SLfree ((char *) c); +} + +int _SLarray_cl_foreach (SLtype type, SLang_Foreach_Context_Type *c) +{ + SLang_Array_Type *at; + VOID_STAR data; + + (void) type; + + if (c == NULL) + return -1; + + at = c->at; + if (at->num_elements == c->next_element_index) + return 0; + + /* FIXME: Priority = low. The following assumes linear arrays + * or Integer range arrays. Fixing it right requires a method to get the + * nth element of a multidimensional array. + */ + + if (at->flags & SLARR_DATA_VALUE_IS_RANGE) + { + int d = (int) c->next_element_index; + data = range_get_data_addr (at, &d); + } + else + data = (VOID_STAR) ((char *)at->data + (c->next_element_index * at->sizeof_type)); + + c->next_element_index += 1; + + if ((at->flags & SLARR_DATA_VALUE_IS_POINTER) + && (*(VOID_STAR *) data == NULL)) + { + if (-1 == SLang_push_null ()) + return -1; + } + else if (-1 == (*at->cl->cl_apush)(at->data_type, data)) + return -1; + + /* keep going */ + return 1; +} + diff --git a/libslang/src/slarrfun.c b/libslang/src/slarrfun.c new file mode 100644 index 0000000..50c7502 --- /dev/null +++ b/libslang/src/slarrfun.c @@ -0,0 +1,956 @@ +/* Advanced array manipulation routines for S-Lang */ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static int next_transposed_index (int *dims, int *max_dims, unsigned int num_dims) +{ + int i; + + for (i = 0; i < (int) num_dims; i++) + { + int dims_i; + + dims_i = dims [i] + 1; + if (dims_i != (int) max_dims [i]) + { + dims [i] = dims_i; + return 0; + } + dims [i] = 0; + } + + return -1; +} + +static SLang_Array_Type *allocate_transposed_array (SLang_Array_Type *at) +{ + unsigned int num_elements; + SLang_Array_Type *bt; + VOID_STAR b_data; + + num_elements = at->num_elements; + b_data = (VOID_STAR) SLmalloc (at->sizeof_type * num_elements); + if (b_data == NULL) + return NULL; + + bt = SLang_create_array (at->data_type, 0, b_data, at->dims, 2); + if (bt == NULL) + { + SLfree ((char *)b_data); + return NULL; + } + + bt->dims[1] = at->dims[0]; + bt->dims[0] = at->dims[1]; + + return bt; +} + +static int check_for_empty_array (char *fun, unsigned int num) +{ + if (num) + return 0; + + SLang_verror (SL_INVALID_PARM, "%s: array is empty", fun); + return -1; +} + +/* -------------- FLOAT --------------------- */ +#if SLANG_HAS_FLOAT +#define GENERIC_TYPE float +#define TRANSPOSE_2D_ARRAY transpose_floats +#define GENERIC_TYPE_A float +#define GENERIC_TYPE_B float +#define GENERIC_TYPE_C float +#define INNERPROD_FUNCTION innerprod_float_float +#if SLANG_HAS_COMPLEX +# define INNERPROD_COMPLEX_A innerprod_complex_float +# define INNERPROD_A_COMPLEX innerprod_float_complex +#endif +#define SUM_FUNCTION sum_floats +#define SUM_RESULT_TYPE float +#define CUMSUM_FUNCTION cumsum_floats +#define CUMSUM_RESULT_TYPE float +#define MIN_FUNCTION min_floats +#define MAX_FUNCTION max_floats +#include "slarrfun.inc" + +/* -------------- DOUBLE --------------------- */ +#define GENERIC_TYPE double +#define TRANSPOSE_2D_ARRAY transpose_doubles +#define GENERIC_TYPE_A double +#define GENERIC_TYPE_B double +#define GENERIC_TYPE_C double +#define INNERPROD_FUNCTION innerprod_double_double +#if SLANG_HAS_COMPLEX +# define INNERPROD_COMPLEX_A innerprod_complex_double +# define INNERPROD_A_COMPLEX innerprod_double_complex +#endif +#define SUM_FUNCTION sum_doubles +#define SUM_RESULT_TYPE double +#define CUMSUM_FUNCTION cumsum_doubles +#define CUMSUM_RESULT_TYPE double +#define MIN_FUNCTION min_doubles +#define MAX_FUNCTION max_doubles +#include "slarrfun.inc" + +#define GENERIC_TYPE_A double +#define GENERIC_TYPE_B float +#define GENERIC_TYPE_C double +#define INNERPROD_FUNCTION innerprod_double_float +#include "slarrfun.inc" + +#define GENERIC_TYPE_A float +#define GENERIC_TYPE_B double +#define GENERIC_TYPE_C double +#define INNERPROD_FUNCTION innerprod_float_double +#include "slarrfun.inc" + +/* Finally pick up the complex_complex multiplication + * and do the integers + */ +#if SLANG_HAS_COMPLEX +# define INNERPROD_COMPLEX_COMPLEX innerprod_complex_complex +#endif +#endif /* SLANG_HAS_FLOAT */ + +/* -------------- INT --------------------- */ +#define GENERIC_TYPE int +#define TRANSPOSE_2D_ARRAY transpose_ints +#define SUM_FUNCTION sum_ints +#define SUM_RESULT_TYPE double +#define CUMSUM_FUNCTION cumsum_ints +#define CUMSUM_RESULT_TYPE double +#define MIN_FUNCTION min_ints +#define MAX_FUNCTION max_ints +#include "slarrfun.inc" + +/* -------------- UNSIGNED INT --------------------- */ +#define GENERIC_TYPE unsigned int +#define SUM_FUNCTION sum_uints +#define SUM_RESULT_TYPE double +#define MIN_FUNCTION min_uints +#define MAX_FUNCTION max_uints +#include "slarrfun.inc" + +#if SIZEOF_LONG != SIZEOF_INT +/* -------------- LONG --------------------- */ +# define GENERIC_TYPE long +# define TRANSPOSE_2D_ARRAY transpose_longs +# define SUM_FUNCTION sum_longs +# define SUM_RESULT_TYPE double +# define MIN_FUNCTION min_longs +# define MAX_FUNCTION max_longs +# include "slarrfun.inc" +/* -------------- UNSIGNED LONG --------------------- */ +# define GENERIC_TYPE unsigned long +# define SUM_FUNCTION sum_ulongs +# define SUM_RESULT_TYPE double +# define MIN_FUNCTION min_ulongs +# define MAX_FUNCTION max_ulongs +# include "slarrfun.inc" +#else +# define transpose_longs transpose_ints +# define sum_longs sum_ints +# define sum_ulongs sum_uints +# define min_longs min_ints +# define min_ulongs min_uints +# define max_longs max_ints +# define max_ulongs max_uints +#endif + +#if SIZEOF_SHORT != SIZEOF_INT +/* -------------- SHORT --------------------- */ +# define GENERIC_TYPE short +# define TRANSPOSE_2D_ARRAY transpose_shorts +# define SUM_FUNCTION sum_shorts +# define SUM_RESULT_TYPE double +# define MIN_FUNCTION min_shorts +# define MAX_FUNCTION max_shorts +# include "slarrfun.inc" +/* -------------- UNSIGNED SHORT --------------------- */ +# define GENERIC_TYPE unsigned short +# define SUM_FUNCTION sum_ushorts +# define SUM_RESULT_TYPE double +# define MIN_FUNCTION min_ushorts +# define MAX_FUNCTION max_ushorts +# include "slarrfun.inc" +#else +# define transpose_shorts transpose_ints +# define sum_shorts sum_ints +# define sum_ushorts sum_uints +# define min_shorts min_ints +# define min_ushorts min_uints +# define max_shorts max_ints +# define max_ushorts max_uints +#endif + +/* -------------- CHAR --------------------- */ +#define GENERIC_TYPE char +#define TRANSPOSE_2D_ARRAY transpose_chars +#define SUM_FUNCTION sum_chars +#define SUM_RESULT_TYPE double +#define MIN_FUNCTION min_chars +#define MAX_FUNCTION max_chars +#include "slarrfun.inc" +/* -------------- UNSIGNED CHAR --------------------- */ +#define GENERIC_TYPE unsigned char +#define SUM_FUNCTION sum_uchars +#define SUM_RESULT_TYPE double +#define MIN_FUNCTION min_uchars +#define MAX_FUNCTION max_uchars +#include "slarrfun.inc" + +/* This routine works only with linear arrays */ +static SLang_Array_Type *transpose (SLang_Array_Type *at) +{ + int dims [SLARRAY_MAX_DIMS]; + int *max_dims; + unsigned int num_dims; + SLang_Array_Type *bt; + int i; + unsigned int sizeof_type; + int is_ptr; + char *b_data; + + max_dims = at->dims; + num_dims = at->num_dims; + + if ((at->num_elements == 0) + || (num_dims == 1)) + { + bt = SLang_duplicate_array (at); + if (num_dims == 1) bt->num_dims = 2; + goto transpose_dims; + } + + /* For numeric arrays skip the overhead below */ + if (num_dims == 2) + { + bt = allocate_transposed_array (at); + if (bt == NULL) return NULL; + + switch (at->data_type) + { + case SLANG_INT_TYPE: + case SLANG_UINT_TYPE: + return transpose_ints (at, bt); +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + return transpose_doubles (at, bt); + case SLANG_FLOAT_TYPE: + return transpose_floats (at, bt); +#endif + case SLANG_CHAR_TYPE: + case SLANG_UCHAR_TYPE: + return transpose_chars (at, bt); + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: + return transpose_longs (at, bt); + case SLANG_SHORT_TYPE: + case SLANG_USHORT_TYPE: + return transpose_shorts (at, bt); + } + } + else + { + bt = SLang_create_array (at->data_type, 0, NULL, max_dims, num_dims); + if (bt == NULL) return NULL; + } + + sizeof_type = at->sizeof_type; + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + + memset ((char *)dims, 0, sizeof(dims)); + + b_data = (char *) bt->data; + + do + { + if (-1 == _SLarray_aget_transfer_elem (at, dims, (VOID_STAR) b_data, + sizeof_type, is_ptr)) + { + SLang_free_array (bt); + return NULL; + } + b_data += sizeof_type; + } + while (0 == next_transposed_index (dims, max_dims, num_dims)); + + transpose_dims: + + num_dims = bt->num_dims; + for (i = 0; i < (int) num_dims; i++) + bt->dims[i] = max_dims [num_dims - i - 1]; + + return bt; +} + +static void array_transpose (SLang_Array_Type *at) +{ + if (NULL != (at = transpose (at))) + (void) SLang_push_array (at, 1); +} + +#if SLANG_HAS_FLOAT +static int get_inner_product_parms (SLang_Array_Type *a, int *dp, + unsigned int *loops, unsigned int *other) +{ + int num_dims; + int d; + + d = *dp; + + num_dims = (int)a->num_dims; + if (num_dims == 0) + { + SLang_verror (SL_INVALID_PARM, "Inner-product operation requires an array of at least 1 dimension."); + return -1; + } + + /* An index of -1 refers to last dimension */ + if (d == -1) + d += num_dims; + *dp = d; + + if (a->num_elements == 0) + { /* [] # [] ==> [] */ + *loops = *other = 0; + return 0; + } + + *loops = a->num_elements / a->dims[d]; + + if (d == 0) + { + *other = *loops; /* a->num_elements / a->dims[0]; */ + return 0; + } + + *other = a->dims[d]; + return 0; +} + +/* This routines takes two arrays A_i..j and B_j..k and produces a third + * via C_i..k = A_i..j B_j..k. + * + * If A is a vector, and B is a 2-d matrix, then regard A as a 2-d matrix + * with 1-column. + */ +static void do_inner_product (void) +{ + SLang_Array_Type *a, *b, *c; + void (*fun)(SLang_Array_Type *, SLang_Array_Type *, SLang_Array_Type *, + unsigned int, unsigned int, unsigned int, unsigned int, + unsigned int); + unsigned char c_type; + int dims[SLARRAY_MAX_DIMS]; + int status; + unsigned int a_loops, b_loops, b_inc, a_stride; + int ai_dims, i, j; + unsigned int num_dims, a_num_dims, b_num_dims; + int ai, bi; + + /* The result of a inner_product will be either a float, double, or + * a complex number. + * + * If an integer array is used, it will be promoted to a float. + */ + + switch (SLang_peek_at_stack1 ()) + { + case SLANG_DOUBLE_TYPE: + if (-1 == SLang_pop_array_of_type (&b, SLANG_DOUBLE_TYPE)) + return; + break; + +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + if (-1 == SLang_pop_array_of_type (&b, SLANG_COMPLEX_TYPE)) + return; + break; +#endif + case SLANG_FLOAT_TYPE: + default: + if (-1 == SLang_pop_array_of_type (&b, SLANG_FLOAT_TYPE)) + return; + break; + } + + switch (SLang_peek_at_stack1 ()) + { + case SLANG_DOUBLE_TYPE: + status = SLang_pop_array_of_type (&a, SLANG_DOUBLE_TYPE); + break; + +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + status = SLang_pop_array_of_type (&a, SLANG_COMPLEX_TYPE); + break; +#endif + case SLANG_FLOAT_TYPE: + default: + status = SLang_pop_array_of_type (&a, SLANG_FLOAT_TYPE); + break; + } + + if (status == -1) + { + SLang_free_array (b); + return; + } + + ai = -1; /* last index of a */ + bi = 0; /* first index of b */ + if ((-1 == get_inner_product_parms (a, &ai, &a_loops, &a_stride)) + || (-1 == get_inner_product_parms (b, &bi, &b_loops, &b_inc))) + { + SLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product"); + goto free_and_return; + } + + a_num_dims = a->num_dims; + b_num_dims = b->num_dims; + + /* Coerse a 1-d vector to 2-d */ + if ((a_num_dims == 1) + && (b_num_dims == 2) + && (a->num_elements)) + { + a_num_dims = 2; + ai = 1; + a_loops = a->num_elements; + a_stride = 1; + } + + if ((ai_dims = a->dims[ai]) != b->dims[bi]) + { + SLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product"); + goto free_and_return; + } + + num_dims = a_num_dims + b_num_dims - 2; + if (num_dims > SLARRAY_MAX_DIMS) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Inner-product result exceeds maximum allowed dimensions"); + goto free_and_return; + } + + if (num_dims) + { + j = 0; + for (i = 0; i < (int)a_num_dims; i++) + if (i != ai) dims [j++] = a->dims[i]; + for (i = 0; i < (int)b_num_dims; i++) + if (i != bi) dims [j++] = b->dims[i]; + } + else + { + /* a scalar */ + num_dims = 1; + dims[0] = 1; + } + + c_type = 0; fun = NULL; + switch (a->data_type) + { + case SLANG_FLOAT_TYPE: + switch (b->data_type) + { + case SLANG_FLOAT_TYPE: + c_type = SLANG_FLOAT_TYPE; + fun = innerprod_float_float; + break; + case SLANG_DOUBLE_TYPE: + c_type = SLANG_DOUBLE_TYPE; + fun = innerprod_float_double; + break; +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + c_type = SLANG_COMPLEX_TYPE; + fun = innerprod_float_complex; + break; +#endif + } + break; + case SLANG_DOUBLE_TYPE: + switch (b->data_type) + { + case SLANG_FLOAT_TYPE: + c_type = SLANG_DOUBLE_TYPE; + fun = innerprod_double_float; + break; + case SLANG_DOUBLE_TYPE: + c_type = SLANG_DOUBLE_TYPE; + fun = innerprod_double_double; + break; +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + c_type = SLANG_COMPLEX_TYPE; + fun = innerprod_double_complex; + break; +#endif + } + break; +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + c_type = SLANG_COMPLEX_TYPE; + switch (b->data_type) + { + case SLANG_FLOAT_TYPE: + fun = innerprod_complex_float; + break; + case SLANG_DOUBLE_TYPE: + fun = innerprod_complex_double; + break; + case SLANG_COMPLEX_TYPE: + fun = innerprod_complex_complex; + break; + } + break; +#endif + default: + break; + } + + if (NULL == (c = SLang_create_array (c_type, 0, NULL, dims, num_dims))) + goto free_and_return; + + (*fun)(a, b, c, a_loops, a_stride, b_loops, b_inc, ai_dims); + + (void) SLang_push_array (c, 1); + /* drop */ + + free_and_return: + SLang_free_array (a); + SLang_free_array (b); +} +#endif + +static int map_or_contract_array (SLCONST SLarray_Map_Type *c, int use_contraction, + int dim_specified, int *use_this_dim, + VOID_STAR clientdata) +{ + int k, use_all_dims; + SLang_Array_Type *at, *new_at; + int *old_dims; + int old_dims_buf[SLARRAY_MAX_DIMS]; + int sub_dims[SLARRAY_MAX_DIMS]; + int tmp_dims[SLARRAY_MAX_DIMS]; + unsigned int i, j, old_num_dims, sub_num_dims; + SLtype new_data_type, old_data_type; + char *old_data, *new_data; + int w[SLARRAY_MAX_DIMS], wk; + unsigned int old_sizeof_type, new_sizeof_type; + unsigned int dims_k; + int from_type; + SLCONST SLarray_Map_Type *csave; + SLarray_Map_Fun_Type *fmap; + SLarray_Contract_Fun_Type *fcon; + + use_all_dims = 1; + k = 0; + if (dim_specified) + { + if (use_this_dim != NULL) + { + k = *use_this_dim; + use_all_dims = 0; + } + } + else if (SLang_Num_Function_Args == 2) + { + if (-1 == SLang_pop_integer (&k)) + return -1; + + use_all_dims = 0; + } + + if (-1 == (from_type = SLang_peek_at_stack1 ())) + return -1; + + csave = c; + while (c->f != NULL) + { + if (c->from_type == (SLtype) from_type) + break; + c++; + } + + /* Look for a more generic version */ + if (c->f != NULL) + { + if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type)) + return -1; + } + else + { + /* Look for a wildcard match */ + c = csave; + while (c->f != NULL) + { + if (c->from_type == SLANG_VOID_TYPE) + break; + c++; + } + if (c->f == NULL) + { + SLang_verror (SL_TYPE_MISMATCH, "%s is not supported by this function", SLclass_get_datatype_name (from_type)); + return -1; + } + + /* Found it. So, typecast it to appropriate type */ + if (c->typecast_to_type == SLANG_VOID_TYPE) + { + if (-1 == SLang_pop_array (&at, 1)) + return -1; + } + else if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type)) + return -1; + } + + old_data_type = at->data_type; + if (SLANG_VOID_TYPE == (new_data_type = c->result_type)) + new_data_type = old_data_type; + + old_num_dims = at->num_dims; + + if (use_all_dims == 0) + { + if (k < 0) + k += old_num_dims; + + if ((k < 0) || (k >= (int)old_num_dims)) + { + SLang_verror (SL_INVALID_PARM, "Dimension %d is invalid for a %d-d array", + k, old_num_dims); + SLang_free_array (at); + return -1; + } + old_dims = at->dims; + } + else + { + old_dims = old_dims_buf; + old_dims[0] = at->num_elements; + old_num_dims = 1; + } + + fcon = (SLarray_Contract_Fun_Type *) c->f; + fmap = c->f; + + if (use_contraction + && (use_all_dims || (old_num_dims == 1))) + { + SLang_Class_Type *cl; + VOID_STAR buf; + int status = 0; + + cl = _SLclass_get_class (new_data_type); + buf = cl->cl_transfer_buf; + + if ((-1 == (*fcon) (at->data, 1, at->num_elements, buf)) + || (-1 == SLang_push_value (new_data_type, buf))) + status = -1; + + SLang_free_array (at); + return status; + } + + /* The offset for the index i_0,i_1,...i_{N-1} is + * i_0*W_0 + i_1*W_1 + ... i_{N-1}*W{N-1} + * where W_j = d_{j+1}d_{j+2}...d_{N-1} + * and d_k is the number of elements of the kth dimension. + * + * For a specified value of k, we + * So, summing over all elements in the kth dimension of the array + * means using the set of offsets given by + * + * i_k*W_k + sum(j!=k) i_j*W_j. + * + * So, we want to loop of all dimensions except for the kth using an + * offset given by sum(j!=k)i_jW_j, and an increment W_k between elements. + */ + + wk = 1; + i = old_num_dims; + while (i != 0) + { + i--; + w[i] = wk; + wk *= old_dims[i]; + } + wk = w[k]; + + /* Now set up the sub array */ + j = 0; + for (i = 0; i < old_num_dims; i++) + { + if (i == (unsigned int) k) + continue; + + sub_dims[j] = old_dims[i]; + w[j] = w[i]; + tmp_dims[j] = 0; + j++; + } + sub_num_dims = old_num_dims - 1; + + if (use_contraction) + new_at = SLang_create_array1 (new_data_type, 0, NULL, sub_dims, sub_num_dims, 1); + else + new_at = SLang_create_array1 (new_data_type, 0, NULL, old_dims, old_num_dims, 1); + + if (new_at == NULL) + { + SLang_free_array (at); + return -1; + } + + new_data = (char *)new_at->data; + old_data = (char *)at->data; + old_sizeof_type = at->sizeof_type; + new_sizeof_type = new_at->sizeof_type; + dims_k = old_dims[k] * wk; + + do + { + unsigned int offset = 0; + int status; + + for (i = 0; i < sub_num_dims; i++) + offset += w[i] * tmp_dims[i]; + + if (use_contraction) + { + status = (*fcon) ((VOID_STAR)(old_data + offset*old_sizeof_type), wk, + dims_k, (VOID_STAR) new_data); + new_data += new_sizeof_type; + } + else + { + status = (*fmap) (old_data_type, (VOID_STAR) (old_data + offset*old_sizeof_type), + wk, dims_k, + new_data_type, (VOID_STAR) (new_data + offset*new_sizeof_type), + clientdata); + } + + if (status == -1) + { + SLang_free_array (new_at); + SLang_free_array (at); + return -1; + } + } + while (-1 != _SLarray_next_index (tmp_dims, sub_dims, sub_num_dims)); + + SLang_free_array (at); + return SLang_push_array (new_at, 1); +} + + +int SLarray_map_array (SLCONST SLarray_Map_Type *m) +{ + return map_or_contract_array (m, 0, 0, NULL, NULL); +} + +int SLarray_map_array_1 (SLCONST SLarray_Map_Type *m, int *use_this_dim, + VOID_STAR clientdata) +{ + return map_or_contract_array (m, 0, 1, use_this_dim, clientdata); +} + +int SLarray_contract_array (SLCONST SLarray_Contract_Type *c) +{ + return map_or_contract_array ((SLarray_Map_Type *)c, 1, 0, NULL, NULL); +} + +#if SLANG_HAS_COMPLEX +static int sum_complex (VOID_STAR zp, unsigned int inc, unsigned int num, VOID_STAR sp) +{ + double *z, *zmax; + double sr, si; + double *s; + + z = (double *)zp; + zmax = z + 2*num; + inc *= 2; + sr = si = 0.0; + while (z < zmax) + { + sr += z[0]; + si += z[1]; + z += inc; + } + s = (double *)sp; + s[0] = sr; + s[1] = si; + return 0; +} + +static int cumsum_complex (SLtype xtype, VOID_STAR xp, unsigned int inc, + unsigned int num, + SLtype ytype, VOID_STAR yp, VOID_STAR clientdata) +{ + double *z, *zmax; + double cr, ci; + double *s; + + (void) xtype; (void) ytype; (void) clientdata; + z = (double *)xp; + zmax = z + 2*num; + s = (double *)yp; + inc *= 2; + cr = ci = 0.0; + while (z < zmax) + { + cr += z[0]; + ci += z[1]; + s[0] = cr; + s[1] = ci; + z += inc; + s += inc; + } + return 0; +} +#endif +#if SLANG_HAS_FLOAT +static SLCONST SLarray_Contract_Type Sum_Functions [] = +{ + {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_chars}, + {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_uchars}, + {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_shorts}, + {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_ushorts}, + {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_uints}, + {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_ints}, + {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_longs}, + {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_ulongs}, + {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Contract_Fun_Type *) sum_floats}, + {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_doubles}, +#if SLANG_HAS_COMPLEX + {SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, (SLarray_Contract_Fun_Type *) sum_complex}, +#endif + {0, 0, 0, NULL} +}; + +static void array_sum (void) +{ + (void) SLarray_contract_array (Sum_Functions); +} +#endif + +static SLCONST SLarray_Contract_Type Array_Min_Funs [] = +{ + {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) min_chars}, + {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, (SLarray_Contract_Fun_Type *) min_uchars}, + {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, (SLarray_Contract_Fun_Type *) min_shorts}, + {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, (SLarray_Contract_Fun_Type *) min_ushorts}, + {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_INT_TYPE, (SLarray_Contract_Fun_Type *) min_ints}, + {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_UINT_TYPE, (SLarray_Contract_Fun_Type *) min_uints}, + {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_LONG_TYPE, (SLarray_Contract_Fun_Type *) min_longs}, + {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, (SLarray_Contract_Fun_Type *) min_ulongs}, +#if SLANG_HAS_FLOAT + {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Contract_Fun_Type *) min_floats}, + {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) min_doubles}, +#endif + {0, 0, 0, NULL} +}; + +static void +array_min (void) +{ + (void) SLarray_contract_array (Array_Min_Funs); +} + +static SLCONST SLarray_Contract_Type Array_Max_Funs [] = +{ + {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) max_chars}, + {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, (SLarray_Contract_Fun_Type *) max_uchars}, + {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, (SLarray_Contract_Fun_Type *) max_shorts}, + {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, (SLarray_Contract_Fun_Type *) max_ushorts}, + {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_INT_TYPE, (SLarray_Contract_Fun_Type *) max_ints}, + {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_UINT_TYPE, (SLarray_Contract_Fun_Type *) max_uints}, + {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_LONG_TYPE, (SLarray_Contract_Fun_Type *) max_longs}, + {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, (SLarray_Contract_Fun_Type *) max_ulongs}, +#if SLANG_HAS_FLOAT + {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Contract_Fun_Type *) max_floats}, + {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) max_doubles}, +#endif + {0, 0, 0, NULL} +}; + +static void +array_max (void) +{ + (void) SLarray_contract_array (Array_Max_Funs); +} + + +static SLCONST SLarray_Map_Type CumSum_Functions [] = +{ + {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles}, + {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_ints}, + {SLANG_LONG_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles}, + {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats}, + {SLANG_UINT_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles}, + {SLANG_ULONG_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles}, + {SLANG_CHAR_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats}, + {SLANG_UCHAR_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats}, + {SLANG_SHORT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats}, + {SLANG_USHORT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats}, + {SLANG_VOID_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles}, +#if SLANG_HAS_COMPLEX + {SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, (SLarray_Map_Fun_Type *) cumsum_complex}, +#endif + {0, 0, 0, NULL} +}; + +static void array_cumsum (void) +{ + (void) SLarray_map_array (CumSum_Functions); +} + +static SLang_Intrin_Fun_Type Array_Fun_Table [] = +{ + MAKE_INTRINSIC_1("transpose", array_transpose, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +static SLang_Intrin_Fun_Type Array_Math_Fun_Table [] = +{ +#if SLANG_HAS_FLOAT + MAKE_INTRINSIC_0("sum", array_sum, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("cumsum", array_cumsum, SLANG_VOID_TYPE), +#endif + MAKE_INTRINSIC_0("min", array_min, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("max", array_max, SLANG_VOID_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +int SLang_init_array (void) +{ + if (-1 == SLadd_intrin_fun_table (Array_Fun_Table, "__SLARRAY__")) + return -1; +#if SLANG_HAS_FLOAT + _SLang_Matrix_Multiply = do_inner_product; +#endif + return 0; +} + +int SLang_init_array_extra (void) +{ + if (-1 == SLadd_intrin_fun_table (Array_Math_Fun_Table, "__SLARRAY__")) + return -1; + return 0; +} + diff --git a/libslang/src/slarrfun.inc b/libslang/src/slarrfun.inc new file mode 100644 index 0000000..5417b45 --- /dev/null +++ b/libslang/src/slarrfun.inc @@ -0,0 +1,370 @@ +/* -*- mode: C -*- */ + +/* Some "inline" functions for generic scalar types */ + +#ifdef TRANSPOSE_2D_ARRAY +static SLang_Array_Type *TRANSPOSE_2D_ARRAY (SLang_Array_Type *at, SLang_Array_Type *bt) +{ + GENERIC_TYPE *a_data, *b_data; + int nr, nc, i; + + nr = at->dims[0]; + nc = at->dims[1]; + + a_data = (GENERIC_TYPE *) at->data; + b_data = (GENERIC_TYPE *) bt->data; + + for (i = 0; i < nr; i++) + { + GENERIC_TYPE *offset = b_data + i; + int j; + for (j = 0; j < nc; j++) + { + *offset = *a_data++; + offset += nr; + } + } + return bt; +} +#undef TRANSPOSE_2D_ARRAY +#endif + + +#ifdef INNERPROD_FUNCTION + +static void INNERPROD_FUNCTION + (SLang_Array_Type *at, SLang_Array_Type *bt, SLang_Array_Type *ct, + unsigned int a_loops, unsigned int a_stride, + unsigned int b_loops, unsigned int b_inc, + unsigned int inner_loops) +{ + GENERIC_TYPE_A *a; + GENERIC_TYPE_B *b; + GENERIC_TYPE_C *c; + + c = (GENERIC_TYPE_C *) ct->data; + b = (GENERIC_TYPE_B *) bt->data; + a = (GENERIC_TYPE_A *) at->data; + + while (a_loops--) + { + GENERIC_TYPE_B *bb; + unsigned int j; + + bb = b; + + for (j = 0; j < inner_loops; j++) + { + double x = (double) a[j]; + + if (x != 0.0) + { + unsigned int k; + + for (k = 0; k < b_loops; k++) + c[k] += x * bb[k]; + } + bb += b_inc; + } + c += b_loops; + a += a_stride; + } +} +#undef INNERPROD_FUNCTION + +#undef GENERIC_TYPE_A +#undef GENERIC_TYPE_B +#undef GENERIC_TYPE_C +#endif + +#ifdef INNERPROD_COMPLEX_A +static void INNERPROD_COMPLEX_A + (SLang_Array_Type *at, SLang_Array_Type *bt, SLang_Array_Type *ct, + unsigned int a_loops, unsigned int a_stride, + unsigned int b_loops, unsigned int b_inc, + unsigned int inner_loops) +{ + double *a; + GENERIC_TYPE *b; + double *c; + + c = (double *) ct->data; + b = (GENERIC_TYPE *) bt->data; + a = (double *) at->data; + + a_stride *= 2; + + while (a_loops--) + { + GENERIC_TYPE *bb; + unsigned int bb_loops; + + bb = b; + bb_loops = b_loops; + + while (bb_loops--) + { + double real_sum; + double imag_sum; + unsigned int iloops; + double *aa; + GENERIC_TYPE *bbb; + + aa = a; + bbb = bb; + iloops = inner_loops; + + real_sum = 0.0; + imag_sum = 0.0; + while (iloops--) + { + real_sum += aa[0] * (double)bbb[0]; + imag_sum += aa[1] * (double)bbb[0]; + aa += 2; + bbb += b_inc; + } + + *c++ = real_sum; + *c++ = imag_sum; + bb++; + } + + a += a_stride; + } +} + +static void INNERPROD_A_COMPLEX + (SLang_Array_Type *at, SLang_Array_Type *bt, SLang_Array_Type *ct, + unsigned int a_loops, unsigned int a_stride, + unsigned int b_loops, unsigned int b_inc, + unsigned int inner_loops) +{ + GENERIC_TYPE *a; + double *b; + double *c; + + c = (double *) ct->data; + b = (double *) bt->data; + a = (GENERIC_TYPE *) at->data; + + b_inc *= 2; + + while (a_loops--) + { + double *bb; + unsigned int bb_loops; + + bb = b; + bb_loops = b_loops; + + while (bb_loops--) + { + double real_sum; + double imag_sum; + unsigned int iloops; + GENERIC_TYPE *aa; + double *bbb; + + aa = a; + bbb = bb; + iloops = inner_loops; + + real_sum = 0.0; + imag_sum = 0.0; + while (iloops--) + { + real_sum += (double)aa[0] * bbb[0]; + imag_sum += (double)aa[0] * bbb[1]; + aa += 1; + bbb += b_inc; + } + + *c++ = real_sum; + *c++ = imag_sum; + bb += 2; + } + + a += a_stride; + } +} + +#undef INNERPROD_A_COMPLEX +#undef INNERPROD_COMPLEX_A +#endif /* INNERPROD_COMPLEX_A */ + + +#ifdef INNERPROD_COMPLEX_COMPLEX +static void INNERPROD_COMPLEX_COMPLEX + (SLang_Array_Type *at, SLang_Array_Type *bt, SLang_Array_Type *ct, + unsigned int a_loops, unsigned int a_stride, + unsigned int b_loops, unsigned int b_inc, + unsigned int inner_loops) +{ + double *a; + double *b; + double *c; + + c = (double *) ct->data; + b = (double *) bt->data; + a = (double *) at->data; + + a_stride *= 2; + b_inc *= 2; + + while (a_loops--) + { + double *bb; + unsigned int bb_loops; + + bb = b; + bb_loops = b_loops; + + while (bb_loops--) + { + double real_sum; + double imag_sum; + unsigned int iloops; + double *aa; + double *bbb; + + aa = a; + bbb = bb; + iloops = inner_loops; + + real_sum = 0.0; + imag_sum = 0.0; + while (iloops--) + { + real_sum += aa[0]*bbb[0] - aa[1]*bbb[1]; + imag_sum += aa[0]*bbb[1] + aa[1]*bbb[0]; + aa += 2; + bbb += b_inc; + } + + *c++ = real_sum; + *c++ = imag_sum; + bb += 2; + } + + a += a_stride; + } +} +#undef INNERPROD_COMPLEX_COMPLEX +#endif + +#ifdef SUM_FUNCTION +#if SLANG_HAS_FLOAT +static int SUM_FUNCTION (VOID_STAR xp, unsigned int inc, unsigned int num, VOID_STAR yp) +{ + GENERIC_TYPE *x, *xmax; + double sum; + + sum = 0.0; + x = (GENERIC_TYPE *) xp; + xmax = x + num; +#if _SLANG_OPTIMIZE_FOR_SPEED + if (inc == 1) + { + while (x < xmax) + { + sum += (double) *x; + x++; + } + } + else +#endif + while (x < xmax) + { + sum += (double) *x; + x += inc; + } + *(SUM_RESULT_TYPE *)yp = (SUM_RESULT_TYPE) sum; + return 0; +} +#endif /* SLANG_HAS_FLOAT */ +#undef SUM_FUNCTION +#undef SUM_RESULT_TYPE +#endif + +#ifdef MIN_FUNCTION +static int +MIN_FUNCTION (VOID_STAR ip, unsigned int inc, unsigned int num, VOID_STAR sp) +{ + unsigned int n; + GENERIC_TYPE m; + GENERIC_TYPE *i = (GENERIC_TYPE *)ip; + + if (-1 == check_for_empty_array ("min", num)) + return -1; + + m = i[0]; + + for (n = inc; n < num; n += inc) + if (m > i[n]) m = i[n]; + + *(GENERIC_TYPE *)sp = m; + return 0; +} +#undef MIN_FUNCTION +#endif + +#ifdef MAX_FUNCTION +static int +MAX_FUNCTION (VOID_STAR ip, unsigned int inc, unsigned int num, VOID_STAR s) +{ + unsigned int n; + GENERIC_TYPE m; + GENERIC_TYPE *i = (GENERIC_TYPE *) ip; + + if (-1 == check_for_empty_array ("max", num)) + return -1; + + m = i[0]; + + for (n = inc; n < num; n += inc) + if (m < i[n]) m = i[n]; + + *(GENERIC_TYPE *)s = m; + return 0; +} +#undef MAX_FUNCTION +#endif + + +#ifdef CUMSUM_FUNCTION +#ifdef SLANG_HAS_FLOAT +static int +CUMSUM_FUNCTION (SLtype xtype, VOID_STAR xp, unsigned int inc, + unsigned int num, + SLtype ytype, VOID_STAR yp, VOID_STAR clientdata) +{ + GENERIC_TYPE *x, *xmax; + CUMSUM_RESULT_TYPE *y; + double c; + + (void) xtype; + (void) ytype; + (void) clientdata; + + x = (GENERIC_TYPE *) xp; + y = (CUMSUM_RESULT_TYPE *) yp; + xmax = x + num; + + c = 0.0; + while (x < xmax) + { + c += (double) *x; + *y = (CUMSUM_RESULT_TYPE) c; + x += inc; + y += inc; + } + return 0; +} +#endif /* SLANG_HAS_FLOAT */ +#undef CUMSUM_FUNCTION +#undef CUMSUM_RESULT_TYPE +#endif + +#ifdef GENERIC_TYPE +# undef GENERIC_TYPE +#endif diff --git a/libslang/src/slarrmis.c b/libslang/src/slarrmis.c new file mode 100644 index 0000000..7541966 --- /dev/null +++ b/libslang/src/slarrmis.c @@ -0,0 +1,38 @@ +/* Misc Array Functions */ +/* Copyright (c) 1997, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +int SLang_get_array_element (SLang_Array_Type *at, int *indices, VOID_STAR data) +{ + int is_ptr; + + if ((at == NULL) + || (indices == NULL) + || (data == NULL)) + return -1; + + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + if (is_ptr) *(VOID_STAR *) data = NULL; + return _SLarray_aget_transfer_elem (at, indices, data, at->sizeof_type, is_ptr); +} + +int SLang_set_array_element (SLang_Array_Type *at, int *indices, VOID_STAR data) +{ + if ((at == NULL) + || (indices == NULL) + || (data == NULL)) + return -1; + + return _SLarray_aput_transfer_elem (at, indices, data, at->sizeof_type, + at->flags & SLARR_DATA_VALUE_IS_POINTER); +} + diff --git a/libslang/src/slassoc.c b/libslang/src/slassoc.c new file mode 100644 index 0000000..51ed4df --- /dev/null +++ b/libslang/src/slassoc.c @@ -0,0 +1,732 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +/* #define SL_APP_WANTS_FOREACH */ +#include "slang.h" +#include "_slang.h" + +#define USE_NEW_ANYTYPE_CODE 1 + +typedef struct _SLAssoc_Array_Element_Type +{ + char *key; /* slstring */ + struct _SLAssoc_Array_Element_Type *next; + SLang_Object_Type value; +} +_SLAssoc_Array_Element_Type; + +typedef struct +{ + _SLAssoc_Array_Element_Type *elements[SLASSOC_HASH_TABLE_SIZE]; + SLang_Object_Type default_value; + unsigned int num_elements; +#define HAS_DEFAULT_VALUE 1 + unsigned int flags; + unsigned char type; +#if _SLANG_OPTIMIZE_FOR_SPEED + int is_scalar_type; +#endif +} +SLang_Assoc_Array_Type; + +#define USE_CACHED_STRING 1 + +#if USE_CACHED_STRING +static char *Cached_String; +static SLang_Object_Type *Cached_Obj; +static SLang_Assoc_Array_Type *Cached_Array; +#endif + +static SLang_Assoc_Array_Type *alloc_assoc_array (unsigned char type, int has_default_value) +{ + SLang_Assoc_Array_Type *a; + + a = (SLang_Assoc_Array_Type *)SLmalloc (sizeof (SLang_Assoc_Array_Type)); + if (a == NULL) + { + if (has_default_value) + SLdo_pop_n (1); + return NULL; + } + + memset ((char *) a, 0, sizeof (SLang_Assoc_Array_Type)); + a->type = type; +#if _SLANG_OPTIMIZE_FOR_SPEED + a->is_scalar_type = (SLANG_CLASS_TYPE_SCALAR == _SLang_get_class_type (type)); +#endif + + if (has_default_value) + { + if ( +#if USE_NEW_ANYTYPE_CODE + ((type != SLANG_ANY_TYPE) && (-1 == SLclass_typecast (type, 1, 1))) +#else + (-1 == SLclass_typecast (type, 1, 1)) +#endif + || (-1 == SLang_pop (&a->default_value))) + { + SLfree ((char *) a); + return NULL; + } + + a->flags |= HAS_DEFAULT_VALUE; + } + return a; +} + +static void free_element (_SLAssoc_Array_Element_Type *e) +{ + if (e == NULL) + return; + + SLang_free_object (&e->value); + SLang_free_slstring (e->key); +#if USE_CACHED_STRING + if (e->key == Cached_String) + Cached_String = NULL; +#endif + SLfree ((char *)e); +} + +static void delete_assoc_array (SLang_Assoc_Array_Type *a) +{ + unsigned int i; + + if (a == NULL) return; + + for (i = 0; i < SLASSOC_HASH_TABLE_SIZE; i++) + { + _SLAssoc_Array_Element_Type *e; + + e = a->elements[i]; + while (e != NULL) + { + _SLAssoc_Array_Element_Type *next_e; + + next_e = e->next; + free_element (e); + e = next_e; + } + } + if (a->flags & HAS_DEFAULT_VALUE) + SLang_free_object (&a->default_value); + + SLfree ((char *) a); +} + +_INLINE_ +static SLang_Object_Type * +find_element (SLang_Assoc_Array_Type *a, char *str, unsigned long hash) +{ + unsigned int h; + _SLAssoc_Array_Element_Type *e; + + h = (unsigned int) (hash % SLASSOC_HASH_TABLE_SIZE); + e = a->elements[h]; + + while (e != NULL) + { + if (str == e->key) /* slstrings can be compared this way */ + { +#if USE_CACHED_STRING + Cached_String = str; + Cached_Obj = &e->value; + Cached_Array = a; +#endif + return &e->value; + } + + e = e->next; + } + + return NULL; +} + +static _SLAssoc_Array_Element_Type * +create_element (SLang_Assoc_Array_Type *a, char *str, unsigned long hash) +{ + unsigned int h; + _SLAssoc_Array_Element_Type *e; + + e = (_SLAssoc_Array_Element_Type *) SLmalloc (sizeof (_SLAssoc_Array_Element_Type)); + if (e == NULL) + return NULL; + + memset ((char *) e, 0, sizeof (_SLAssoc_Array_Element_Type)); + h = (unsigned int) (hash % SLASSOC_HASH_TABLE_SIZE); + + if (NULL == (str = _SLstring_dup_hashed_string (str, hash))) + { + SLfree ((char *) e); + return NULL; + } + + e->key = str; + e->next = a->elements[h]; + a->elements[h] = e; + + a->num_elements += 1; +#if USE_CACHED_STRING + Cached_String = str; + Cached_Obj = &e->value; + Cached_Array = a; +#endif + return e; +} + +static int store_object (SLang_Assoc_Array_Type *a, char *s, SLang_Object_Type *obj) +{ + unsigned long hash; + SLang_Object_Type *v; + +#if USE_CACHED_STRING + if ((s == Cached_String) && (a == Cached_Array)) + { + v = Cached_Obj; + SLang_free_object (v); + } + else + { +#endif + hash = _SLcompute_string_hash (s); + if (NULL != (v = find_element (a, s, hash))) + SLang_free_object (v); + else + { + _SLAssoc_Array_Element_Type *e; + + e = create_element (a, s, hash); + if (e == NULL) + return -1; + + v = &e->value; + } +#if USE_CACHED_STRING + } +#endif + + *v = *obj; + + return 0; +} + +static void assoc_destroy (unsigned char type, VOID_STAR ptr) +{ + (void) type; + delete_assoc_array ((SLang_Assoc_Array_Type *) ptr); +} + +static int pop_index (unsigned int num_indices, + SLang_MMT_Type **mmt, + SLang_Assoc_Array_Type **a, + char **str) +{ + if (NULL == (*mmt = SLang_pop_mmt (SLANG_ASSOC_TYPE))) + { + *a = NULL; + *str = NULL; + return -1; + } + + if ((num_indices != 1) + || (-1 == SLang_pop_slstring (str))) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Assoc_Type arrays require a single string index"); + SLang_free_mmt (*mmt); + *mmt = NULL; + *a = NULL; + *str = NULL; + return -1; + } + + *a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (*mmt); + return 0; +} + +int _SLassoc_aget (SLtype type, unsigned int num_indices) +{ + SLang_MMT_Type *mmt; + char *str; + SLang_Assoc_Array_Type *a; + SLang_Object_Type *obj; + int ret; + + (void) type; + + if (-1 == pop_index (num_indices, &mmt, &a, &str)) + return -1; + +#if USE_CACHED_STRING + if ((str == Cached_String) && (a == Cached_Array)) + obj = Cached_Obj; + else +#endif + obj = find_element (a, str, _SLcompute_string_hash (str)); + + if ((obj == NULL) + && (a->flags & HAS_DEFAULT_VALUE)) + obj = &a->default_value; + + if (obj == NULL) + { + SLang_verror (SL_INTRINSIC_ERROR, + "No such element in Assoc Array: %s", str); + ret = -1; + } + else + { +#if _SLANG_OPTIMIZE_FOR_SPEED + if (a->is_scalar_type) + ret = SLang_push (obj); + else +#endif + ret = _SLpush_slang_obj (obj); + } + + SLang_free_slstring (str); + SLang_free_mmt (mmt); + return ret; +} + +int _SLassoc_aput (SLtype type, unsigned int num_indices) +{ + SLang_MMT_Type *mmt; + char *str; + SLang_Assoc_Array_Type *a; + SLang_Object_Type obj; + int ret; + + (void) type; + + if (-1 == pop_index (num_indices, &mmt, &a, &str)) + return -1; + + ret = -1; + + if (0 == SLang_pop (&obj)) + { + if ((obj.data_type != a->type) +#if USE_NEW_ANYTYPE_CODE + && (a->type != SLANG_ANY_TYPE) +#endif + ) + { + (void) SLang_push (&obj); + if ((-1 == SLclass_typecast (a->type, 1, 1)) + || (-1 == SLang_pop (&obj))) + goto the_return; + } + + if (-1 == store_object (a, str, &obj)) + SLang_free_object (&obj); + else + ret = 0; + } + + the_return: + SLang_free_slstring (str); + SLang_free_mmt (mmt); + return ret; +} + +static int assoc_anew (unsigned char type, unsigned int num_dims) +{ + SLang_MMT_Type *mmt; + SLang_Assoc_Array_Type *a; + int has_default_value; + + has_default_value = 0; + switch (num_dims) + { + case 0: + type = SLANG_ANY_TYPE; + break; + case 2: + (void) SLreverse_stack (2); + has_default_value = 1; + /* drop */ + case 1: + if (0 == SLang_pop_datatype (&type)) + break; + num_dims--; + /* drop */ + default: + SLdo_pop_n (num_dims); + SLang_verror (SL_SYNTAX_ERROR, "Usage: Assoc_Type [DataType_Type]"); + return -1; + } + + a = alloc_assoc_array (type, has_default_value); + if (a == NULL) + return -1; + + if (NULL == (mmt = SLang_create_mmt (SLANG_ASSOC_TYPE, (VOID_STAR) a))) + { + delete_assoc_array (a); + return -1; + } + + if (-1 == SLang_push_mmt (mmt)) + { + SLang_free_mmt (mmt); + return -1; + } + + return 0; +} + +static void assoc_get_keys (SLang_Assoc_Array_Type *a) +{ + SLang_Array_Type *at; + int num; + unsigned int i, j; + char **data; + + /* Note: If support for threads is added, then we need to modify this + * algorithm to prevent another thread from modifying the array. + * However, that should be handled in inner_interp. + */ + num = a->num_elements; + + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num, 1))) + return; + + data = (char **)at->data; + + i = 0; + for (j = 0; j < SLASSOC_HASH_TABLE_SIZE; j++) + { + _SLAssoc_Array_Element_Type *e; + + e = a->elements[j]; + while (e != NULL) + { + /* Next cannot fail because it is an slstring */ + data [i] = SLang_create_slstring (e->key); + e = e->next; + i++; + } + } + (void) SLang_push_array (at, 1); +} + +static int +transfer_element (SLang_Class_Type *cl, VOID_STAR dest_data, + SLang_Object_Type *obj) +{ + unsigned int sizeof_type; + VOID_STAR src_data; + +#if USE_NEW_ANYTYPE_CODE + if (cl->cl_data_type == SLANG_ANY_TYPE) + { + SLang_Any_Type *any; + + if ((-1 == _SLpush_slang_obj (obj)) + || (-1 == SLang_pop_anytype (&any))) + return -1; + + *(SLang_Any_Type **)dest_data = any; + return 0; + } +#endif + /* Optimize for scalar */ + if (cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + { + sizeof_type = cl->cl_sizeof_type; + memcpy ((char *) dest_data, (char *)&obj->v, sizeof_type); + return 0; + } + + src_data = _SLclass_get_ptr_to_value (cl, obj); + + if (-1 == (*cl->cl_acopy) (cl->cl_data_type, src_data, dest_data)) + return -1; + + return 0; +} + +static void assoc_get_values (SLang_Assoc_Array_Type *a) +{ + SLang_Array_Type *at; + int num; + unsigned int j; + char *dest_data; + unsigned char type; + SLang_Class_Type *cl; + unsigned int sizeof_type; + + /* Note: If support for threads is added, then we need to modify this + * algorithm to prevent another thread from modifying the array. + * However, that should be handled in inner_interp. + */ + num = a->num_elements; + type = a->type; + + cl = _SLclass_get_class (type); + sizeof_type = cl->cl_sizeof_type; + + if (NULL == (at = SLang_create_array (type, 0, NULL, &num, 1))) + return; + + dest_data = (char *)at->data; + + for (j = 0; j < SLASSOC_HASH_TABLE_SIZE; j++) + { + _SLAssoc_Array_Element_Type *e; + + e = a->elements[j]; + while (e != NULL) + { + if (-1 == transfer_element (cl, (VOID_STAR) dest_data, &e->value)) + { + SLang_free_array (at); + return; + } + + dest_data += sizeof_type; + e = e->next; + } + } + (void) SLang_push_array (at, 1); +} + +static int assoc_key_exists (SLang_Assoc_Array_Type *a, char *key) +{ + return (NULL != find_element (a, key, _SLcompute_string_hash (key))); +} + +static void assoc_delete_key (SLang_Assoc_Array_Type *a, char *key) +{ + unsigned int h; + _SLAssoc_Array_Element_Type *v, *v0; + + h = (unsigned int) (_SLcompute_string_hash (key) % SLASSOC_HASH_TABLE_SIZE); + + v0 = NULL; + v = a->elements[h]; + while (v != NULL) + { + if (v->key == key) + { + if (v0 != NULL) + v0->next = v->next; + else + a->elements[h] = v->next; + + free_element (v); + a->num_elements -= 1; + return; + } + v0 = v; + v = v->next; + } + + /* No such element. Let it pass with no error. */ +} + +#define A SLANG_ASSOC_TYPE +#define S SLANG_STRING_TYPE +static SLang_Intrin_Fun_Type Assoc_Table [] = +{ + MAKE_INTRINSIC_1("assoc_get_keys", assoc_get_keys, SLANG_VOID_TYPE, A), + MAKE_INTRINSIC_1("assoc_get_values", assoc_get_values, SLANG_VOID_TYPE, A), + MAKE_INTRINSIC_2("assoc_key_exists", assoc_key_exists, SLANG_INT_TYPE, A, S), + MAKE_INTRINSIC_2("assoc_delete_key", assoc_delete_key, SLANG_VOID_TYPE, A, S), + + SLANG_END_INTRIN_FUN_TABLE +}; +#undef A +#undef S + +static int assoc_length (unsigned char type, VOID_STAR v, unsigned int *len) +{ + SLang_Assoc_Array_Type *a; + + (void) type; + a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (*(SLang_MMT_Type **)v); + *len = a->num_elements; + return 0; +} + +struct _SLang_Foreach_Context_Type +{ + SLang_MMT_Type *mmt; + SLang_Assoc_Array_Type *a; + unsigned int this_hash_index; + unsigned int next_same_hash_index; +#define CTX_WRITE_KEYS 1 +#define CTX_WRITE_VALUES 2 + unsigned char flags; +#if _SLANG_OPTIMIZE_FOR_SPEED + int is_scalar; +#endif +}; + +static SLang_Foreach_Context_Type * +cl_foreach_open (unsigned char type, unsigned int num) +{ + SLang_Foreach_Context_Type *c; + unsigned char flags; + SLang_MMT_Type *mmt; + + (void) type; + + if (NULL == (mmt = SLang_pop_mmt (SLANG_ASSOC_TYPE))) + return NULL; + + flags = 0; + + while (num--) + { + char *s; + + if (-1 == SLang_pop_slstring (&s)) + { + SLang_free_mmt (mmt); + return NULL; + } + + if (0 == strcmp (s, "keys")) + flags |= CTX_WRITE_KEYS; + else if (0 == strcmp (s, "values")) + flags |= CTX_WRITE_VALUES; + else + { + SLang_verror (SL_NOT_IMPLEMENTED, + "using '%s' not supported by SLassoc_Type", + s); + SLang_free_slstring (s); + SLang_free_mmt (mmt); + return NULL; + } + + SLang_free_slstring (s); + } + + if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type)))) + { + SLang_free_mmt (mmt); + return NULL; + } + + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + + if (flags == 0) flags = CTX_WRITE_VALUES|CTX_WRITE_KEYS; + + c->flags = flags; + c->mmt = mmt; + c->a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (mmt); +#if _SLANG_OPTIMIZE_FOR_SPEED + c->is_scalar = (SLANG_CLASS_TYPE_SCALAR == _SLang_get_class_type (c->a->type)); +#endif + return c; +} + +static void cl_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + SLang_free_mmt (c->mmt); + SLfree ((char *) c); +} + +static int cl_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + SLang_Assoc_Array_Type *a; + _SLAssoc_Array_Element_Type *e; + unsigned int i, j; + + (void) type; + + if (c == NULL) + return -1; + + a = c->a; + + i = c->this_hash_index; + if (i >= SLASSOC_HASH_TABLE_SIZE) + return 0; + + e = a->elements[i]; + + j = c->next_same_hash_index; + c->next_same_hash_index = j + 1; + + while ((j > 0) && (e != NULL)) + { + j--; + e = e->next; + } + + if (e == NULL) + { + do + { + i++; + if (i >= SLASSOC_HASH_TABLE_SIZE) + return 0; /* no more */ + } + while (a->elements [i] == NULL); + + e = a->elements[i]; + c->this_hash_index = i; + c->next_same_hash_index = 1; + } + + if ((c->flags & CTX_WRITE_KEYS) + && (-1 == SLang_push_string (e->key))) + return -1; + + if (c->flags & CTX_WRITE_VALUES) + { +#if _SLANG_OPTIMIZE_FOR_SPEED + if (c->is_scalar) + { + if (-1 == SLang_push (&e->value)) + return -1; + } + else +#endif + if (-1 == _SLpush_slang_obj (&e->value)) + return -1; + } + + /* keep going */ + return 1; +} + +int SLang_init_slassoc (void) +{ + SLang_Class_Type *cl; + + if (SLclass_is_class_defined (SLANG_ASSOC_TYPE)) + return 0; + + if (NULL == (cl = SLclass_allocate_class ("Assoc_Type"))) + return -1; + + (void) SLclass_set_destroy_function (cl, assoc_destroy); + (void) SLclass_set_aput_function (cl, _SLassoc_aput); + (void) SLclass_set_aget_function (cl, _SLassoc_aget); + (void) SLclass_set_anew_function (cl, assoc_anew); + cl->cl_length = assoc_length; + cl->cl_foreach_open = cl_foreach_open; + cl->cl_foreach_close = cl_foreach_close; + cl->cl_foreach = cl_foreach; + + if (-1 == SLclass_register_class (cl, SLANG_ASSOC_TYPE, sizeof (SLang_Assoc_Array_Type), SLANG_CLASS_TYPE_MMT)) + return -1; + + if (-1 == SLadd_intrin_fun_table (Assoc_Table, "__SLASSOC__")) + return -1; + + return 0; +} + diff --git a/libslang/src/slbstr.c b/libslang/src/slbstr.c new file mode 100644 index 0000000..07322b2 --- /dev/null +++ b/libslang/src/slbstr.c @@ -0,0 +1,614 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +struct _SLang_BString_Type +{ + unsigned int num_refs; + unsigned int len; + int ptr_type; +#define IS_SLSTRING 1 +#define IS_MALLOCED 2 +#define IS_NOT_TO_BE_FREED 3 + union + { + unsigned char bytes[1]; + unsigned char *ptr; + } + v; +}; + +#define BS_GET_POINTER(b) ((b)->ptr_type ? (b)->v.ptr : (b)->v.bytes) + +static SLang_BString_Type *create_bstring_of_type (char *bytes, unsigned int len, int type) +{ + SLang_BString_Type *b; + unsigned int size; + + size = sizeof(SLang_BString_Type); + if (type == 0) + size += len; + + if (NULL == (b = (SLang_BString_Type *)SLmalloc (size))) + return NULL; + + b->len = len; + b->num_refs = 1; + b->ptr_type = type; + + switch (type) + { + case 0: + if (bytes != NULL) memcpy ((char *) b->v.bytes, bytes, len); + /* Now \0 terminate it because we want to also use it as a C string + * whenever possible. Note that sizeof(SLang_BString_Type) includes + * space for 1 character and we allocated len extra bytes. Thus, it is + * ok to add a \0 to the end. + */ + b->v.bytes[len] = 0; + break; + + case IS_SLSTRING: + if (NULL == (b->v.ptr = (unsigned char *)SLang_create_nslstring (bytes, len))) + { + SLfree ((char *) b); + return NULL; + } + break; + + case IS_MALLOCED: + case IS_NOT_TO_BE_FREED: + b->v.ptr = (unsigned char *)bytes; + bytes [len] = 0; /* NULL terminate */ + break; + } + + return b; +} + +SLang_BString_Type * +SLbstring_create (unsigned char *bytes, unsigned int len) +{ + return create_bstring_of_type ((char *)bytes, len, 0); +} + +/* Note that ptr must be len + 1 bytes long for \0 termination */ +SLang_BString_Type * +SLbstring_create_malloced (unsigned char *ptr, unsigned int len, int free_on_error) +{ + SLang_BString_Type *b; + + if (ptr == NULL) + return NULL; + + if (NULL == (b = create_bstring_of_type ((char *)ptr, len, IS_MALLOCED))) + { + if (free_on_error) + SLfree ((char *) ptr); + } + return b; +} + +SLang_BString_Type *SLbstring_create_slstring (char *s) +{ + if (s == NULL) + return NULL; + + return create_bstring_of_type (s, strlen (s), IS_SLSTRING); +} + +SLang_BString_Type *SLbstring_dup (SLang_BString_Type *b) +{ + if (b != NULL) + b->num_refs += 1; + + return b; +} + +unsigned char *SLbstring_get_pointer (SLang_BString_Type *b, unsigned int *len) +{ + if (b == NULL) + { + *len = 0; + return NULL; + } + *len = b->len; + return BS_GET_POINTER(b); +} + +void SLbstring_free (SLang_BString_Type *b) +{ + if (b == NULL) + return; + + if (b->num_refs > 1) + { + b->num_refs -= 1; + return; + } + + switch (b->ptr_type) + { + case 0: + case IS_NOT_TO_BE_FREED: + default: + break; + + case IS_SLSTRING: + SLang_free_slstring ((char *)b->v.ptr); + break; + + case IS_MALLOCED: + SLfree ((char *)b->v.ptr); + break; + } + + SLfree ((char *) b); +} + +int SLang_pop_bstring (SLang_BString_Type **b) +{ + return SLclass_pop_ptr_obj (SLANG_BSTRING_TYPE, (VOID_STAR *)b); +} + +int SLang_push_bstring (SLang_BString_Type *b) +{ + if (b == NULL) + return SLang_push_null (); + + b->num_refs += 1; + + if (0 == SLclass_push_ptr_obj (SLANG_BSTRING_TYPE, (VOID_STAR)b)) + return 0; + + b->num_refs -= 1; + return -1; +} + +static int +bstring_bstring_bin_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) a; + (void) b; + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + *c = SLANG_BSTRING_TYPE; + break; + + case SLANG_GT: + case SLANG_GE: + case SLANG_LT: + case SLANG_LE: + case SLANG_EQ: + case SLANG_NE: + *c = SLANG_CHAR_TYPE; + break; + } + return 1; +} + +static int compare_bstrings (SLang_BString_Type *a, SLang_BString_Type *b) +{ + unsigned int len; + int ret; + + len = a->len; + if (b->len < len) len = b->len; + + ret = memcmp ((char *)BS_GET_POINTER(b), (char *)BS_GET_POINTER(a), len); + if (ret != 0) + return ret; + + if (a->len > b->len) + return 1; + if (a->len == b->len) + return 0; + + return -1; +} + +static SLang_BString_Type * +concat_bstrings (SLang_BString_Type *a, SLang_BString_Type *b) +{ + unsigned int len; + SLang_BString_Type *c; + char *bytes; + + len = a->len + b->len; + + if (NULL == (c = SLbstring_create (NULL, len))) + return NULL; + + bytes = (char *)BS_GET_POINTER(c); + + memcpy (bytes, (char *)BS_GET_POINTER(a), a->len); + memcpy (bytes + a->len, (char *)BS_GET_POINTER(b), b->len); + + return c; +} + +static void free_n_bstrings (SLang_BString_Type **a, unsigned int n) +{ + unsigned int i; + + if (a == NULL) return; + + for (i = 0; i < n; i++) + { + SLbstring_free (a[i]); + a[i] = NULL; + } +} + +static int +bstring_bstring_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + SLang_BString_Type **a, **b, **c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + if (na == 1) da = 0; else da = 1; + if (nb == 1) db = 0; else db = 1; + + if (na > nb) n_max = na; else n_max = nb; + + a = (SLang_BString_Type **) ap; + b = (SLang_BString_Type **) bp; + for (n = 0; n < n_max; n++) + { + if ((*a == NULL) || (*b == NULL)) + { + SLang_verror (SL_VARIABLE_UNINITIALIZED, + "Binary string element[%u] not initialized for binary operation", n); + return -1; + } + a += da; b += db; + } + + a = (SLang_BString_Type **) ap; + b = (SLang_BString_Type **) bp; + ic = (char *) cp; + c = NULL; + + switch (op) + { + case SLANG_PLUS: + /* Concat */ + c = (SLang_BString_Type **) cp; + for (n = 0; n < n_max; n++) + { + if (NULL == (c[n] = concat_bstrings (*a, *b))) + goto return_error; + + a += da; b += db; + } + break; + + case SLANG_NE: + for (n = 0; n < n_max; n++) + { + ic [n] = (0 != compare_bstrings (*a, *b)); + a += da; + b += db; + } + break; + case SLANG_GT: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) > 0); + a += da; + b += db; + } + break; + case SLANG_GE: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) >= 0); + a += da; + b += db; + } + break; + case SLANG_LT: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) < 0); + a += da; + b += db; + } + break; + case SLANG_LE: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) <= 0); + a += da; + b += db; + } + break; + case SLANG_EQ: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) == 0); + a += da; + b += db; + } + break; + } + return 1; + + return_error: + if (c != NULL) + { + free_n_bstrings (c, n); + while (n < n_max) + { + c[n] = NULL; + n++; + } + } + return -1; +} + +/* If preserve_ptr, then use a[i] as the bstring data. See how this function + * is called by the binary op routines for why. + */ +static SLang_BString_Type ** +make_n_bstrings (SLang_BString_Type **b, char **a, unsigned int n, int ptr_type) +{ + unsigned int i; + int malloc_flag; + + malloc_flag = 0; + if (b == NULL) + { + b = (SLang_BString_Type **) SLmalloc ((n + 1) * sizeof (SLang_BString_Type *)); + if (b == NULL) + return NULL; + malloc_flag = 1; + } + + for (i = 0; i < n; i++) + { + char *s = a[i]; + + if (s == NULL) + { + b[i] = NULL; + continue; + } + + if (NULL == (b[i] = create_bstring_of_type (s, strlen(s), ptr_type))) + { + free_n_bstrings (b, i); + if (malloc_flag) SLfree ((char *) b); + return NULL; + } + } + + return b; +} + +static int +bstring_string_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + SLang_BString_Type **b; + int ret; + + if (NULL == (b = make_n_bstrings (NULL, (char **)bp, nb, IS_NOT_TO_BE_FREED))) + return -1; + + b_type = SLANG_BSTRING_TYPE; + ret = bstring_bstring_bin_op (op, + a_type, ap, na, + b_type, (VOID_STAR) b, nb, + cp); + free_n_bstrings (b, nb); + SLfree ((char *) b); + return ret; +} + +static int +string_bstring_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + SLang_BString_Type **a; + int ret; + + if (NULL == (a = make_n_bstrings (NULL, (char **)ap, na, IS_NOT_TO_BE_FREED))) + return -1; + + a_type = SLANG_BSTRING_TYPE; + ret = bstring_bstring_bin_op (op, + a_type, (VOID_STAR) a, na, + b_type, bp, nb, + cp); + free_n_bstrings (a, na); + SLfree ((char *) a); + + return ret; +} + +static void bstring_destroy (unsigned char unused, VOID_STAR s) +{ + (void) unused; + SLbstring_free (*(SLang_BString_Type **) s); +} + +static int bstring_push (unsigned char unused, VOID_STAR sptr) +{ + (void) unused; + + return SLang_push_bstring (*(SLang_BString_Type **) sptr); +} + +static int string_to_bstring (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + char **s; + SLang_BString_Type **b; + + (void) a_type; + (void) b_type; + + s = (char **) ap; + b = (SLang_BString_Type **) bp; + + if (NULL == make_n_bstrings (b, s, na, IS_SLSTRING)) + return -1; + + return 1; +} + +static int bstring_to_string (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + char **s; + unsigned int i; + SLang_BString_Type **a; + + (void) a_type; + (void) b_type; + + s = (char **) bp; + a = (SLang_BString_Type **) ap; + + for (i = 0; i < na; i++) + { + SLang_BString_Type *ai = a[i]; + + if (ai == NULL) + { + s[i] = NULL; + continue; + } + + if (NULL == (s[i] = SLang_create_slstring ((char *)BS_GET_POINTER(ai)))) + { + while (i != 0) + { + i--; + SLang_free_slstring (s[i]); + s[i] = NULL; + } + return -1; + } + } + + return 1; +} + +static char *bstring_string (unsigned char type, VOID_STAR v) +{ + SLang_BString_Type *s; + unsigned char buf[128]; + unsigned char *bytes, *bytes_max; + unsigned char *b, *bmax; + + (void) type; + + s = *(SLang_BString_Type **) v; + bytes = BS_GET_POINTER(s); + bytes_max = bytes + s->len; + + b = buf; + bmax = buf + (sizeof (buf) - 4); + + while (bytes < bytes_max) + { + unsigned char ch = *bytes; + + if ((ch < 32) || (ch >= 127) || (ch == '\\')) + { + if (b + 4 > bmax) + break; + + sprintf ((char *) b, "\\%03o", ch); + b += 4; + } + else + { + if (b == bmax) + break; + + *b++ = ch; + } + + bytes++; + } + + if (bytes < bytes_max) + { + *b++ = '.'; + *b++ = '.'; + *b++ = '.'; + } + *b = 0; + + return SLmake_string ((char *)buf); +} + +static unsigned int bstrlen_cmd (SLang_BString_Type *b) +{ + return b->len; +} + +static SLang_Intrin_Fun_Type BString_Table [] = /*{{{*/ +{ + MAKE_INTRINSIC_1("bstrlen", bstrlen_cmd, SLANG_UINT_TYPE, SLANG_BSTRING_TYPE), + MAKE_INTRINSIC_0("pack", _SLpack, SLANG_VOID_TYPE), + MAKE_INTRINSIC_2("unpack", _SLunpack, SLANG_VOID_TYPE, SLANG_STRING_TYPE, SLANG_BSTRING_TYPE), + MAKE_INTRINSIC_1("pad_pack_format", _SLpack_pad_format, SLANG_VOID_TYPE, SLANG_STRING_TYPE), + MAKE_INTRINSIC_1("sizeof_pack", _SLpack_compute_size, SLANG_UINT_TYPE, SLANG_STRING_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +int _SLang_init_bstring (void) +{ + SLang_Class_Type *cl; + + if (NULL == (cl = SLclass_allocate_class ("BString_Type"))) + return -1; + (void) SLclass_set_destroy_function (cl, bstring_destroy); + (void) SLclass_set_push_function (cl, bstring_push); + (void) SLclass_set_string_function (cl, bstring_string); + + if (-1 == SLclass_register_class (cl, SLANG_BSTRING_TYPE, sizeof (char *), + SLANG_CLASS_TYPE_PTR)) + return -1; + + if ((-1 == SLclass_add_typecast (SLANG_BSTRING_TYPE, SLANG_STRING_TYPE, bstring_to_string, 1)) + || (-1 == SLclass_add_typecast (SLANG_STRING_TYPE, SLANG_BSTRING_TYPE, string_to_bstring, 1)) + || (-1 == SLclass_add_binary_op (SLANG_STRING_TYPE, SLANG_BSTRING_TYPE, string_bstring_bin_op, bstring_bstring_bin_op_result)) + || (-1 == SLclass_add_binary_op (SLANG_BSTRING_TYPE, SLANG_STRING_TYPE, bstring_string_bin_op, bstring_bstring_bin_op_result)) + || (-1 == SLclass_add_binary_op (SLANG_BSTRING_TYPE, SLANG_BSTRING_TYPE, bstring_bstring_bin_op, bstring_bstring_bin_op_result))) + return -1; + + if (-1 == SLadd_intrin_fun_table (BString_Table, NULL)) + return -1; + + return 0; +} + diff --git a/libslang/src/slclass.c b/libslang/src/slclass.c new file mode 100644 index 0000000..7d6d5b5 --- /dev/null +++ b/libslang/src/slclass.c @@ -0,0 +1,1418 @@ +/* User defined objects */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +/* #define SL_APP_WANTS_FOREACH */ +#include "slang.h" +#include "_slang.h" + +static SLang_Class_Type *Registered_Types[256]; +SLang_Class_Type *_SLclass_get_class (unsigned char type) +{ + SLang_Class_Type *cl; + + cl = Registered_Types [type]; + if (cl == NULL) + SLang_exit_error ("Application error: Type %d not registered", (int) type); + + return cl; +} + +int SLclass_is_class_defined (unsigned char type) +{ + return (NULL != Registered_Types[type]); +} + +VOID_STAR _SLclass_get_ptr_to_value (SLang_Class_Type *cl, + SLang_Object_Type *obj) +{ + VOID_STAR p; + + switch (cl->cl_class_type) + { + case SLANG_CLASS_TYPE_MMT: + case SLANG_CLASS_TYPE_PTR: + case SLANG_CLASS_TYPE_SCALAR: + p = (VOID_STAR) &obj->v; + break; + + case SLANG_CLASS_TYPE_VECTOR: + p = obj->v.ptr_val; + break; + + default: + p = NULL; + } + return p; +} + +char *SLclass_get_datatype_name (unsigned char stype) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (stype); + return cl->cl_name; +} + +static int method_undefined_error (unsigned char type, char *method, char *name) +{ + if (name == NULL) name = SLclass_get_datatype_name (type); + + SLang_verror (SL_TYPE_MISMATCH, "%s method not defined for %s", + method, name); + return -1; +} + +static int +scalar_vector_bin_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) a; (void) b; + switch (op) + { + case SLANG_NE: + case SLANG_EQ: + *c = SLANG_INT_TYPE; + return 1; + } + return 0; +} + +static int +scalar_vector_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + int *c; + char *a, *b; + unsigned int da, db; + unsigned int n, n_max; + unsigned int data_type_len; + SLang_Class_Type *cl; + + (void) b_type; + cl = _SLclass_get_class (a_type); + + data_type_len = cl->cl_sizeof_type; + + a = (char *) ap; + b = (char *) bp; + c = (int *) cp; + + if (na == 1) da = 0; else da = data_type_len; + if (nb == 1) db = 0; else db = data_type_len; + if (na > nb) n_max = na; else n_max = nb; + + switch (op) + { + default: + return 0; + + case SLANG_NE: + for (n = 0; n < n_max; n++) + { + c[n] = (0 != SLMEMCMP(a, b, data_type_len)); + a += da; b += db; + } + break; + + case SLANG_EQ: + for (n = 0; n < n_max; n++) + { + c[n] = (0 == SLMEMCMP(a, b, data_type_len)); + a += da; b += db; + } + break; + } + return 1; +} + +static int scalar_fread (unsigned char type, FILE *fp, VOID_STAR ptr, + unsigned int desired, unsigned int *actual) +{ + unsigned int n; + + n = fread ((char *) ptr, _SLclass_get_class (type)->cl_sizeof_type, + desired, fp); + *actual = n; + return 0; +} + +static int scalar_fwrite (unsigned char type, FILE *fp, VOID_STAR ptr, + unsigned int desired, unsigned int *actual) +{ + unsigned int n; + + n = fwrite ((char *) ptr, _SLclass_get_class (type)->cl_sizeof_type, + desired, fp); + *actual = n; + return 0; +} + +static int vector_apush (unsigned char type, VOID_STAR ptr) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + return (*cl->cl_push)(type, (VOID_STAR) &ptr); +} + +static int vector_apop (unsigned char type, VOID_STAR ptr) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + return (*cl->cl_pop)(type, (VOID_STAR) &ptr); +} + +static int default_push_mmt (unsigned char type_unused, VOID_STAR ptr) +{ + SLang_MMT_Type *ref; + + (void) type_unused; + ref = *(SLang_MMT_Type **) ptr; + return SLang_push_mmt (ref); +} + +static void default_destroy_simple (unsigned char type_unused, VOID_STAR ptr_unused) +{ + (void) type_unused; + (void) ptr_unused; +} + +static void default_destroy_user (unsigned char type, VOID_STAR ptr) +{ + (void) type; + SLang_free_mmt (*(SLang_MMT_Type **) ptr); +} + +static int default_pop (unsigned char type, VOID_STAR ptr) +{ + return SLclass_pop_ptr_obj (type, (VOID_STAR *) ptr); +} + +static int default_datatype_deref (unsigned char type) +{ + return method_undefined_error (type, "datatype_deref", NULL); +} + +static int default_acopy (unsigned char type, VOID_STAR from, VOID_STAR to) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + if (-1 == (*cl->cl_apush) (type, from)) + return -1; + return (*cl->cl_apop) (type, to); +} + +static int scalar_acopy (SLtype type, VOID_STAR from, VOID_STAR to) +{ + memcpy ((char *)to, (char *)from, _SLclass_get_class (type)->cl_sizeof_type); + return 0; +} + +int SLclass_dup_object (SLtype type, VOID_STAR from, VOID_STAR to) +{ + SLang_Class_Type *cl = _SLclass_get_class (type); + return cl->cl_acopy (type, from, to); +} + +static int default_dereference_object (unsigned char type, VOID_STAR ptr) +{ + (void) ptr; + return method_undefined_error (type, "dereference", NULL); +} + +static char *default_string (unsigned char stype, VOID_STAR v) +{ + char buf [256]; + char *s; +#if SLANG_HAS_COMPLEX + double *cplx; +#endif + s = buf; + + switch (stype) + { + case SLANG_STRING_TYPE: + s = *(char **) v; + break; + + case SLANG_NULL_TYPE: + s = "NULL"; + break; + + case SLANG_DATATYPE_TYPE: + s = SLclass_get_datatype_name ((unsigned char) *(int *)v); + break; + +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + cplx = *(double **) v; + if (cplx[1] < 0) + sprintf (s, "(%g - %gi)", cplx [0], -cplx [1]); + else + sprintf (s, "(%g + %gi)", cplx [0], cplx [1]); + break; +#endif + default: + s = SLclass_get_datatype_name (stype); + } + + return SLmake_string (s); +} + +static int +use_cmp_bin_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + if (a != b) + return 0; + switch (op) + { + case SLANG_NE: + case SLANG_EQ: + case SLANG_LT: + case SLANG_LE: + case SLANG_GT: + case SLANG_GE: + *c = SLANG_INT_TYPE; + return 1; + } + return 0; +} + +static int +use_cmp_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + int *c; + char *a, *b; + unsigned int da, db; + unsigned int n, n_max; + unsigned int data_type_len; + SLang_Class_Type *cl; + int (*cmp)(unsigned char, VOID_STAR, VOID_STAR, int *); + + (void) b_type; + cl = _SLclass_get_class (a_type); + cmp = cl->cl_cmp; + data_type_len = cl->cl_sizeof_type; + + a = (char *) ap; + b = (char *) bp; + c = (int *) cp; + + if (na == 1) da = 0; else da = data_type_len; + if (nb == 1) db = 0; else db = data_type_len; + if (na > nb) n_max = na; else n_max = nb; + + switch (op) + { + int result; + + default: + return 0; + + case SLANG_NE: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result != 0); + a += da; b += db; + } + break; + + case SLANG_EQ: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result == 0); + a += da; b += db; + } + break; + + case SLANG_GT: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result > 0); + a += da; b += db; + } + break; + case SLANG_GE: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result >= 0); + a += da; b += db; + } + break; + case SLANG_LT: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result < 0); + a += da; b += db; + } + break; + case SLANG_LE: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result <= 0); + a += da; b += db; + } + break; + } + return 1; +} + + +int SLclass_get_class_id (SLang_Class_Type *cl) +{ + if (cl == NULL) + return -1; + return (int) cl->cl_data_type; +} + +SLang_Class_Type *SLclass_allocate_class (char *name) +{ + SLang_Class_Type *cl; + unsigned int i; + + for (i = 0; i < 256; i++) + { + cl = Registered_Types [i]; + if ((cl != NULL) + && (0 == strcmp (cl->cl_name, name))) + { + SLang_verror (SL_DUPLICATE_DEFINITION, "Type name %s already exists", name); + return NULL; + } + } + + cl = (SLang_Class_Type *) SLmalloc (sizeof (SLang_Class_Type)); + if (cl == NULL) return NULL; + + SLMEMSET ((char *) cl, 0, sizeof (SLang_Class_Type)); + + if (NULL == (cl->cl_name = SLang_create_slstring (name))) + { + SLfree ((char *) cl); + return NULL; + } + + return cl; +} + +static int DataType_Ids [256]; + +int SLang_push_datatype (unsigned char data_type) +{ + /* This data type could be a copy of another type, e.g., short and + * int if they are the same size (Int16 == Short). So, make sure + * we push the original and not the copy. + */ + data_type = _SLclass_get_class (data_type)->cl_data_type; + return SLclass_push_int_obj (SLANG_DATATYPE_TYPE, (int) data_type); +} + +static int datatype_deref (unsigned char type, VOID_STAR ptr) +{ + SLang_Class_Type *cl; + int status; + + /* The parser generated code for this as if a function call were to be + * made. However, we are calling the deref object routine + * instead of the function call. So, I must simulate the function call. + */ + if (-1 == _SL_increment_frame_pointer ()) + return -1; + + type = (unsigned char) *(int *) ptr; + cl = _SLclass_get_class (type); + status = (*cl->cl_datatype_deref) (type); + + (void) _SL_decrement_frame_pointer (); + return status; +} + +static int datatype_push (unsigned char type_unused, VOID_STAR ptr) +{ + (void) type_unused; + return SLang_push_datatype (*(int *) ptr); +} + +int SLang_pop_datatype (unsigned char *type) +{ + int i; + + if (-1 == SLclass_pop_int_obj (SLANG_DATATYPE_TYPE, &i)) + return -1; + + *type = (unsigned char) i; + return 0; +} + +static int datatype_pop (unsigned char type, VOID_STAR ptr) +{ + if (-1 == SLang_pop_datatype (&type)) + return -1; + + *(int *) ptr = type; + return 0; +} + +int _SLclass_init (void) +{ + SLang_Class_Type *cl; + + /* First initialize the container classes. This is so binary operations + * added later will work with them. + */ + if (-1 == _SLarray_init_slarray ()) + return -1; + + /* DataType_Type */ + if (NULL == (cl = SLclass_allocate_class ("DataType_Type"))) + return -1; + cl->cl_pop = datatype_pop; + cl->cl_push = datatype_push; + cl->cl_dereference = datatype_deref; + if (-1 == SLclass_register_class (cl, SLANG_DATATYPE_TYPE, sizeof(int), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + + return 0; +} + +static int register_new_datatype (char *name, unsigned char type) +{ + DataType_Ids [type] = type; + return SLadd_intrinsic_variable (name, (VOID_STAR) (DataType_Ids + type), + SLANG_DATATYPE_TYPE, 1); +} + +int SLclass_create_synonym (char *name, unsigned char type) +{ + if (NULL == _SLclass_get_class (type)) + return -1; + + return register_new_datatype (name, type); +} + +int _SLclass_copy_class (unsigned char to, unsigned char from) +{ + SLang_Class_Type *cl = _SLclass_get_class (from); + + if (Registered_Types[to] != NULL) + SLang_exit_error ("Application error: Class already exists"); + + Registered_Types[to] = cl; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (to != SLANG_UNDEFINED_TYPE) + _SLang_set_class_type(to, cl->cl_class_type); +#endif + return 0; +} + +int SLclass_register_class (SLang_Class_Type *cl, unsigned char type, unsigned int type_size, unsigned char class_type) +{ + char *name; + unsigned int i; + int can_binop = 1; /* scalar_vector_bin_op should work + * for all data types. + */ + + if (type == SLANG_VOID_TYPE) for (i = _SLANG_MIN_UNUSED_TYPE; i < 256; i++) + { + if (Registered_Types[i] == NULL) + { + type = (unsigned char) i; + break; + } + } + + if ((NULL != Registered_Types [type]) + || (type == SLANG_VOID_TYPE)) + { + SLang_verror (SL_APPLICATION_ERROR, "Class type %d already in use", (int) type); + return -1; + } + + cl->cl_data_type = type; + cl->cl_class_type = class_type; + name = cl->cl_name; + + switch (class_type) + { + case SLANG_CLASS_TYPE_MMT: + if (cl->cl_push == NULL) cl->cl_push = default_push_mmt; + if (cl->cl_destroy == NULL) + return method_undefined_error (type, "destroy", name); + cl->cl_user_destroy_fun = cl->cl_destroy; + cl->cl_destroy = default_destroy_user; + type_size = sizeof (VOID_STAR); + break; + + case SLANG_CLASS_TYPE_SCALAR: + if (cl->cl_destroy == NULL) cl->cl_destroy = default_destroy_simple; + if ((type_size == 0) + || (type_size > sizeof (_SL_Object_Union_Type))) + { + SLang_verror (SL_INVALID_PARM, + "Type size for %s not appropriate for SCALAR type", + name); + return -1; + } + if (cl->cl_pop == NULL) + return method_undefined_error (type, "pop", name); + if (cl->cl_fread == NULL) cl->cl_fread = scalar_fread; + if (cl->cl_fwrite == NULL) cl->cl_fwrite = scalar_fwrite; + if (cl->cl_acopy == NULL) cl->cl_acopy = scalar_acopy; + + can_binop = 1; + break; + + case SLANG_CLASS_TYPE_PTR: + if (cl->cl_destroy == NULL) + return method_undefined_error (type, "destroy", name); + type_size = sizeof (VOID_STAR); + break; + + case SLANG_CLASS_TYPE_VECTOR: + if (cl->cl_destroy == NULL) + return method_undefined_error (type, "destroy", name); + if (cl->cl_pop == NULL) + return method_undefined_error (type, "pop", name); + cl->cl_apop = vector_apop; + cl->cl_apush = vector_apush; + cl->cl_adestroy = default_destroy_simple; + if (cl->cl_fread == NULL) cl->cl_fread = scalar_fread; + if (cl->cl_fwrite == NULL) cl->cl_fwrite = scalar_fwrite; + if (cl->cl_acopy == NULL) cl->cl_acopy = scalar_acopy; + can_binop = 1; + break; + + default: + SLang_verror (SL_INVALID_PARM, "%s: unknown class type (%d)", name, class_type); + return -1; + } + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (type != SLANG_UNDEFINED_TYPE) + _SLang_set_class_type (type, class_type); +#endif + + if (type_size == 0) + { + SLang_verror (SL_INVALID_PARM, "type size must be non-zero for %s", name); + return -1; + } + + if (cl->cl_string == NULL) cl->cl_string = default_string; + if (cl->cl_acopy == NULL) cl->cl_acopy = default_acopy; + if (cl->cl_datatype_deref == NULL) cl->cl_datatype_deref = default_datatype_deref; + + if (cl->cl_pop == NULL) cl->cl_pop = default_pop; + + if (cl->cl_push == NULL) + return method_undefined_error (type, "push", name); + + if (cl->cl_byte_code_destroy == NULL) + cl->cl_byte_code_destroy = cl->cl_destroy; + if (cl->cl_push_literal == NULL) + cl->cl_push_literal = cl->cl_push; + + if (cl->cl_dereference == NULL) + cl->cl_dereference = default_dereference_object; + + if (cl->cl_apop == NULL) cl->cl_apop = cl->cl_pop; + if (cl->cl_apush == NULL) cl->cl_apush = cl->cl_push; + if (cl->cl_adestroy == NULL) cl->cl_adestroy = cl->cl_destroy; + if (cl->cl_push_intrinsic == NULL) cl->cl_push_intrinsic = cl->cl_push; + + if ((cl->cl_foreach == NULL) + || (cl->cl_foreach_open == NULL) + || (cl->cl_foreach_close == NULL)) + { + cl->cl_foreach = _SLarray_cl_foreach; + cl->cl_foreach_open = _SLarray_cl_foreach_open; + cl->cl_foreach_close = _SLarray_cl_foreach_close; + } + + cl->cl_sizeof_type = type_size; + + if (NULL == (cl->cl_transfer_buf = (VOID_STAR) SLmalloc (type_size))) + return -1; + + Registered_Types[type] = cl; + + if (-1 == register_new_datatype (name, type)) + return -1; + + if (cl->cl_cmp != NULL) + { + if (-1 == SLclass_add_binary_op (type, type, use_cmp_bin_op, use_cmp_bin_op_result)) + return -1; + } + else if (can_binop + && (-1 == SLclass_add_binary_op (type, type, scalar_vector_bin_op, scalar_vector_bin_op_result))) + return -1; + + cl->cl_anytype_typecast = _SLanytype_typecast; + + return 0; +} + +int SLclass_add_math_op (unsigned char type, + int (*handler)(int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*result) (int, unsigned char, unsigned char *)) +{ + SLang_Class_Type *cl = _SLclass_get_class (type); + + cl->cl_math_op = handler; + cl->cl_math_op_result_type = result; + return 0; +} + +int SLclass_add_binary_op (unsigned char a, unsigned char b, + int (*f) (int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*r) (int, unsigned char, unsigned char, unsigned char *)) +{ + SLang_Class_Type *cl; + SL_OOBinary_Type *ab; + + if ((f == NULL) || (r == NULL)) + { + SLang_verror (SL_INVALID_PARM, "SLclass_add_binary_op"); + return -1; + } + + cl = _SLclass_get_class (a); + (void) _SLclass_get_class (b); + + if (NULL == (ab = (SL_OOBinary_Type *) SLmalloc (sizeof(SL_OOBinary_Type)))) + return -1; + + ab->data_type = b; + ab->binary_function = f; + ab->binary_result = r; + ab->next = cl->cl_binary_ops; + cl->cl_binary_ops = ab; + + if ((a != SLANG_ARRAY_TYPE) + && (b != SLANG_ARRAY_TYPE)) + { + if ((-1 == _SLarray_add_bin_op (a)) + || (-1 == _SLarray_add_bin_op (b))) + return -1; + } + + return 0; +} + +int SLclass_add_unary_op (unsigned char type, + int (*f)(int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*r)(int, unsigned char, unsigned char *)) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + if ((f == NULL) || (r == NULL)) + { + SLang_verror (SL_INVALID_PARM, "SLclass_add_unary_op"); + return -1; + } + + cl->cl_unary_op = f; + cl->cl_unary_op_result_type = r; + + return 0; +} + +int SLclass_add_app_unary_op (unsigned char type, + int (*f)(int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*r)(int, unsigned char, unsigned char *)) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + if ((f == NULL) || (r == NULL)) + { + SLang_verror (SL_INVALID_PARM, "SLclass_add_app_unary_op"); + return -1; + } + + cl->cl_app_unary_op = f; + cl->cl_app_unary_op_result_type = r; + + return 0; +} + +int SLclass_set_pop_function (SLang_Class_Type *cl, int (*f)(unsigned char, VOID_STAR)) +{ + if (cl == NULL) return -1; + cl->cl_pop = f; + + return 0; +} + +int SLclass_set_push_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR)) +{ + if (cl == NULL) return -1; + cl->cl_push = f; + + return 0; +} + +int SLclass_set_apush_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR)) +{ + if (cl == NULL) return -1; + cl->cl_apush = f; + + return 0; +} + +int SLclass_set_acopy_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR, VOID_STAR)) +{ + if (cl == NULL) return -1; + cl->cl_acopy = f; + + return 0; +} + +int SLclass_set_string_function (SLang_Class_Type *cl, char *(*f)(unsigned char, VOID_STAR)) +{ + if (cl == NULL) return -1; + + cl->cl_string = f; + return 0; +} + +int SLclass_set_destroy_function (SLang_Class_Type *cl, void (*f)(unsigned char, VOID_STAR)) +{ + if (cl == NULL) return -1; + + cl->cl_destroy = f; + return 0; +} + +int SLclass_set_sget_function (SLang_Class_Type *cl, int (*f)(unsigned char, char *)) +{ + if (cl == NULL) return -1; + cl->cl_sget = f; + return 0; +} + +int SLclass_set_sput_function (SLang_Class_Type *cl, int (*f)(unsigned char, char *)) +{ + if (cl == NULL) return -1; + cl->cl_sput = f; + return 0; +} + +int SLclass_set_aget_function (SLang_Class_Type *cl, int (*f)(unsigned char, unsigned int)) +{ + if (cl == NULL) return -1; + cl->cl_aget = f; + return 0; +} + +int SLclass_set_aput_function (SLang_Class_Type *cl, int (*f)(unsigned char, unsigned int)) +{ + if (cl == NULL) return -1; + cl->cl_aput = f; + return 0; +} + +int SLclass_set_anew_function (SLang_Class_Type *cl, int (*f)(unsigned char, unsigned int)) +{ + if (cl == NULL) return -1; + cl->cl_anew = f; + return 0; +} + +/* Misc */ +void _SLclass_type_mismatch_error (unsigned char a, unsigned char b) +{ + SLang_verror (SL_TYPE_MISMATCH, "Expecting %s, found %s", + SLclass_get_datatype_name (a), + SLclass_get_datatype_name (b)); +} + +/* */ + +static int null_binary_fun (int op, + unsigned char a, VOID_STAR ap, unsigned int na, + unsigned char b, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + int *ic; + unsigned int i; + int c; + + (void) ap; (void) bp; + + switch (op) + { + case SLANG_EQ: + c = (a == b); + break; + + case SLANG_NE: + c = (a != b); + break; + + default: + return 0; + } + + if (na > nb) nb = na; + ic = (int *) cp; + for (i = 0; i < nb; i++) + ic[i] = c; + + return 1; +} + +static char *get_binary_op_string (int op) +{ + static char *ops[SLANG_MOD] = + { + "+", "=", "*", "/", "==", "!=", ">", ">=", "<", "<=", "^", + "or", "and", "&", "|", "xor", "shl", "shr", "mod" + }; + + if ((op > SLANG_MOD) || (op <= 0)) + return "- ?? -"; /* Note: -??- is a trigraph (sigh) */ + return ops[op - 1]; +} + +int (*_SLclass_get_binary_fun (int op, + SLang_Class_Type *a_cl, SLang_Class_Type *b_cl, + SLang_Class_Type **c_cl, int do_error)) +(int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR) +{ + SL_OOBinary_Type *bt; + unsigned char a, b, c; + + a = a_cl->cl_data_type; + b = b_cl->cl_data_type; + + if ((a == SLANG_NULL_TYPE) || (b == SLANG_NULL_TYPE)) + { + *c_cl = _SLclass_get_class (SLANG_INT_TYPE); + return null_binary_fun; + } + + bt = a_cl->cl_binary_ops; + + while (bt != NULL) + { + if (bt->data_type == b) + { + if (1 != (*bt->binary_result)(op, a, b, &c)) + break; + + if (c == a) *c_cl = a_cl; + else if (c == b) *c_cl = b_cl; + else *c_cl = _SLclass_get_class (c); + + return bt->binary_function; + } + + bt = bt->next; + } + + if (do_error) + SLang_verror (SL_TYPE_MISMATCH, "%s %s %s is not possible", + a_cl->cl_name, get_binary_op_string (op), b_cl->cl_name); + + *c_cl = NULL; + return NULL; +} + +int (*_SLclass_get_unary_fun (int op, + SLang_Class_Type *a_cl, + SLang_Class_Type **b_cl, + int utype)) +(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR) +{ + int (*f)(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); + int (*r)(int, unsigned char, unsigned char *); + unsigned char a; + unsigned char b; + + switch (utype) + { + case _SLANG_BC_UNARY: + f = a_cl->cl_unary_op; + r = a_cl->cl_unary_op_result_type; + break; + + case _SLANG_BC_MATH_UNARY: + f = a_cl->cl_math_op; + r = a_cl->cl_math_op_result_type; + break; + + case _SLANG_BC_APP_UNARY: + f = a_cl->cl_app_unary_op; + r = a_cl->cl_app_unary_op_result_type; + break; + + default: + f = NULL; + r = NULL; + } + + a = a_cl->cl_data_type; + if ((f != NULL) && (r != NULL) && (1 == (*r) (op, a, &b))) + { + if (a == b) + *b_cl = a_cl; + else + *b_cl = _SLclass_get_class (b); + return f; + } + + SLang_verror (SL_TYPE_MISMATCH, "undefined unary operation/function on %s", + a_cl->cl_name); + + *b_cl = NULL; + + return NULL; +} + +int +SLclass_typecast (unsigned char to_type, int is_implicit, int allow_array) +{ + unsigned char from_type; + SLang_Class_Type *cl_to, *cl_from; + SLang_Object_Type obj; + VOID_STAR ap; + VOID_STAR bp; + int status; + + if (-1 == SLang_pop (&obj)) + return -1; + + from_type = obj.data_type; + if (from_type == to_type) + { + SLang_push (&obj); + return 0; + } + + cl_from = _SLclass_get_class (from_type); + + /* Since the typecast functions are designed to work on arrays, + * get the pointer to the value instead of just &obj.v. + */ + ap = _SLclass_get_ptr_to_value (cl_from, &obj); + + if ((from_type == SLANG_ARRAY_TYPE) + && (allow_array || (to_type != SLANG_ANY_TYPE))) + { + if (allow_array == 0) + goto return_error; + + cl_to = _SLclass_get_class (SLANG_ARRAY_TYPE); + bp = cl_to->cl_transfer_buf; + status = _SLarray_typecast (from_type, ap, 1, to_type, bp, is_implicit); + } + else + { + int (*t) (unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR); + + if (NULL == (t = _SLclass_get_typecast (from_type, to_type, is_implicit))) + { + SLang_free_object (&obj); + return -1; + } + + cl_to = _SLclass_get_class (to_type); + bp = cl_to->cl_transfer_buf; + status = (*t) (from_type, ap, 1, to_type, bp); + } + + if (1 == status) + { + /* AnyType apush will do a reference, which is undesirable here. + * So, to avoid that, perform push instead of apush. Yes, this is + * an ugly hack. + */ + if (to_type == SLANG_ANY_TYPE) + status = (*cl_to->cl_push)(to_type, bp); + else + status = (*cl_to->cl_apush)(to_type, bp); + + if (status == -1) + { + (*cl_to->cl_adestroy) (to_type, bp); + SLang_free_object (&obj); + return -1; + } + + /* cl_apush will push a copy, so destry this one */ + (*cl_to->cl_adestroy) (to_type, bp); + SLang_free_object (&obj); + return 0; + } + + return_error: + + SLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s", + cl_from->cl_name, + SLclass_get_datatype_name (to_type)); + SLang_free_object (&obj); + return -1; +} + +int (*_SLclass_get_typecast (unsigned char from, unsigned char to, int is_implicit)) +(unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR) +{ + SL_Typecast_Type *t; + SLang_Class_Type *cl_from; + + cl_from = _SLclass_get_class (from); + + t = cl_from->cl_typecast_funs; + while (t != NULL) + { + if (t->data_type != to) + { + t = t->next; + continue; + } + + if (is_implicit && (t->allow_implicit == 0)) + break; + + return t->typecast; + } + + if (to == SLANG_ANY_TYPE) + return _SLanytype_typecast; + + if ((is_implicit == 0) + && (cl_from->cl_void_typecast != NULL)) + return cl_from->cl_void_typecast; + + SLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s", + cl_from->cl_name, + SLclass_get_datatype_name (to)); + + return NULL; +} + +int +SLclass_add_typecast (unsigned char from, unsigned char to, + int (*f)_PROTO((unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR)), + int allow_implicit) +{ + SL_Typecast_Type *t; + SLang_Class_Type *cl; + + cl = _SLclass_get_class (from); + if (to == SLANG_VOID_TYPE) + { + cl->cl_void_typecast = f; + return 0; + } + + (void) _SLclass_get_class (to); + + if (NULL == (t = (SL_Typecast_Type *) SLmalloc (sizeof (SL_Typecast_Type)))) + return -1; + + SLMEMSET((char *) t, 0, sizeof(SL_Typecast_Type)); + t->data_type = to; + t->next = cl->cl_typecast_funs; + t->typecast = f; + t->allow_implicit = allow_implicit; + + cl->cl_typecast_funs = t; + + return 0; +} + +SLang_MMT_Type *SLang_pop_mmt (unsigned char type) /*{{{*/ +{ + SLang_MMT_Type *mmt; + + if (-1 == SLclass_pop_ptr_obj (type, (VOID_STAR *) &mmt)) + mmt = NULL; + return mmt; + +#if 0 + SLang_Object_Type obj; + SLang_Class_Type *cl; + + if (_SLang_pop_object_of_type (type, &obj)) + return NULL; + + cl = _SLclass_get_class (type); + if ((cl->cl_class_type == SLANG_CLASS_TYPE_MMT) + && (obj.data_type == type)) + { + return obj.v.ref; + } + + _SLclass_type_mismatch_error (type, obj.data_type); + SLang_free_object (&obj); + return NULL; +#endif +} + +/*}}}*/ + +int SLang_push_mmt (SLang_MMT_Type *ref) /*{{{*/ +{ + if (ref == NULL) + return SLang_push_null (); + + ref->count += 1; + + if (0 == SLclass_push_ptr_obj (ref->data_type, (VOID_STAR) ref)) + return 0; + + ref->count -= 1; + return -1; +} + +/*}}}*/ + +void SLang_inc_mmt (SLang_MMT_Type *ref) +{ + if (ref != NULL) + ref->count += 1; +} + +VOID_STAR SLang_object_from_mmt (SLang_MMT_Type *ref) +{ + if (ref == NULL) + return NULL; + + return ref->user_data; +} + +SLang_MMT_Type *SLang_create_mmt (unsigned char t, VOID_STAR p) +{ + SLang_MMT_Type *ref; + + (void) _SLclass_get_class (t); /* check to see if it is registered */ + + if (NULL == (ref = (SLang_MMT_Type *) SLmalloc (sizeof (SLang_MMT_Type)))) + return NULL; + + SLMEMSET ((char *) ref, 0, sizeof (SLang_MMT_Type)); + + ref->data_type = t; + ref->user_data = p; + /* FIXME!! To be consistent with other types, the reference count should + * be set to 1 here. However, doing so will require other code changes + * involving the use of MMTs. For instance, SLang_free_mmt would have + * to be called after every push of the MMT. + */ + return ref; +} + +void SLang_free_mmt (SLang_MMT_Type *ref) +{ + unsigned char type; + SLang_Class_Type *cl; + + if (ref == NULL) + return; + + /* This can be zero if SLang_create_mmt is called followed + * by this routine before anything gets a chance to attach itself + * to it. + */ + if (ref->count > 1) + { + ref->count -= 1; + return; + } + + type = ref->data_type; + cl = _SLclass_get_class (type); + (*cl->cl_user_destroy_fun) (type, ref->user_data); + SLfree ((char *)ref); +} + +int SLang_push_value (unsigned char type, VOID_STAR v) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + return (*cl->cl_apush)(type, v); +} + +int SLang_pop_value (unsigned char type, VOID_STAR v) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + return (*cl->cl_apop)(type, v); +} + +void SLang_free_value (unsigned char type, VOID_STAR v) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + (*cl->cl_adestroy) (type, v); +} + +/* These routines are very low-level and are designed for application data + * types to access the stack from their push/pop methods. The int and + * pointer versions are in slang.c + */ +#if SLANG_HAS_FLOAT +int SLclass_push_float_obj (unsigned char type, float x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.float_val = x; + return SLang_push (&obj); +} +#endif + +int SLclass_push_long_obj (unsigned char type, long x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.long_val = x; + return SLang_push (&obj); +} + +int SLclass_push_short_obj (unsigned char type, short x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.short_val = x; + return SLang_push (&obj); +} + +int SLclass_push_char_obj (unsigned char type, char x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.char_val = x; + return SLang_push (&obj); +} + +#if SLANG_HAS_FLOAT +int SLclass_pop_double_obj (unsigned char type, double *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.double_val; + return 0; +} + +int SLclass_pop_float_obj (unsigned char type, float *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.float_val; + return 0; +} +#endif + +int SLclass_pop_long_obj (unsigned char type, long *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.long_val; + return 0; +} + +int SLclass_pop_int_obj (unsigned char type, int *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.int_val; + return 0; +} + +int SLclass_pop_short_obj (unsigned char type, short *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.short_val; + return 0; +} + +int SLclass_pop_char_obj (unsigned char type, char *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.char_val; + return 0; +} + +int SLclass_pop_ptr_obj (unsigned char type, VOID_STAR *s) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + { + *s = (VOID_STAR) NULL; + return -1; + } + *s = obj.v.ptr_val; + return 0; +} + diff --git a/libslang/src/slcmd.c b/libslang/src/slcmd.c new file mode 100644 index 0000000..cef45b9 --- /dev/null +++ b/libslang/src/slcmd.c @@ -0,0 +1,351 @@ +/* cmd line facility for slang */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#if SLANG_HAS_FLOAT +# include +#endif + +#include "slang.h" +#include "_slang.h" + +#ifndef HAVE_STDLIB_H +/* Oh dear. Where is the prototype for atof? If not in stdlib, then + * I do not know where. Not in math.h onsome systems either. + */ +extern double atof (); +#endif + +static SLcmd_Cmd_Type *SLcmd_find_command (char *s, SLcmd_Cmd_Type *cmd) +{ + char *cmdstr; + char chs = *s++, ch; + + while ((cmd->cmdfun != NULL) + && (NULL != (cmdstr = cmd->cmd)) + && (0 != (ch = *cmdstr++))) + { + if ((ch == chs) && !strcmp (s, cmdstr)) return cmd; + cmd++; + } + return NULL; +} + +static int extract_token (char **strptr, char *buf) +{ + char *s, *b; + char ch, quote; + + *buf = 0; + + s = *strptr; + while (((ch = *s) != 0) + && ((ch == ' ') || (ch == '\t') || (ch == '\n'))) + s++; + + *strptr = s; + + if (ch == 0) return 0; + if (ch == '%') return 0; + + b = buf; + + *b++ = ch; + s++; + + if ((ch == '\'') || (ch == '"')) + { + quote = ch; + while ((ch = *s) != 0) + { + s++; + *b++ = ch; + if (ch == quote) + break; + + if (ch == '\\') + { + if (0 == (ch = *s)) + break; + *b++ = ch; + s++; + } + } + *strptr = s; + *b = 0; + return 1; + } + + while (((ch = *s) != 0) + && (ch != ' ') + && (ch != '\t') + && (ch != '\n') + && (ch != '%')) + *b++ = *s++; + + *strptr = s; + *b = 0; + return 1; +} + +static int allocate_arg_space (SLcmd_Cmd_Table_Type *table, int argc, unsigned int *space_ptr) +{ + unsigned int space = *space_ptr; + char *p; + + if (argc + 1 < (int) space) + return 0; + + if (space > 128) + { + if (space > 1024) space += 1024; + else space += 128; + } + else space += 32; + + if (NULL == (p = SLrealloc ((char *)table->string_args, space * sizeof (char *)))) + return -1; + table->string_args = (char **)p; + table->string_args [argc] = NULL; + + if (NULL == (p = SLrealloc ((char *)table->int_args, space * sizeof (int)))) + return -1; + table->int_args = (int *)p; + + if (NULL == (p = SLrealloc ((char *)table->double_args, space * sizeof (double)))) + return -1; + table->double_args = (double *)p; + + if (NULL == (p = SLrealloc ((char *)table->arg_type, space * sizeof (unsigned char)))) + return -1; + table->arg_type = (unsigned char *)p; + + *space_ptr = space; + return 0; +} + +int SLcmd_execute_string (char *str, SLcmd_Cmd_Table_Type *table) +{ + char *s, *arg_type, *last_str, *cmd_name; + SLcmd_Cmd_Type *cmd; + char *buf; + int token_present; + int i; + int status; + unsigned int len; + int argc; + unsigned int space; + + table->argc = 0; + table->string_args = NULL; + table->int_args = NULL; + table->double_args = NULL; + table->arg_type = NULL; + + buf = SLmake_string (str); + if (buf == NULL) + return -1; + + status = extract_token (&str, buf); + if (status <= 0) + { + SLfree (buf); + return status; + } + + if (((len = strlen (buf)) >= 32) + || (NULL == (cmd = SLcmd_find_command (buf, table->table)))) + { + SLang_verror (SL_UNDEFINED_NAME,"%s: invalid command", buf); + SLfree (buf); + return -1; + } + + if (NULL == (cmd_name = SLmake_string (buf))) + { + SLfree (buf); + return -1; + } + + space = 0; + argc = 0; + if (-1 == allocate_arg_space (table, argc, &space)) + { + SLfree (buf); + return -1; + } + table->arg_type[argc] = SLANG_STRING_TYPE; + table->string_args[argc++] = cmd_name; + + arg_type = cmd->arg_type; + status = -1; + while (*arg_type) + { + int guess_type = 0; + + last_str = str; + + if (-1 == allocate_arg_space (table, argc, &space)) + goto error; + + if (-1 == (token_present = extract_token (&str, buf))) + goto error; + + table->string_args[argc] = NULL; + + if (token_present) + { + char *b = buf; + len = strlen (b); + + if ((*b == '"') && (len > 1)) + { + b++; + len -= 2; + b[len] = 0; + guess_type = SLANG_STRING_TYPE; + SLexpand_escaped_string (buf, b, b + len); + len = strlen (buf); + } + else if ((*b == '\'') && (len > 1)) + { + char ch; + b++; + len -= 2; + b[len] = 0; + guess_type = SLANG_INT_TYPE; + ch = *b; + if (ch == '\\') + (void) _SLexpand_escaped_char (b, &ch); + sprintf (buf, "%d", (unsigned char) ch); + len = strlen (buf); + } + else guess_type = SLang_guess_type (buf); + } + + switch (*arg_type++) + { + /* variable argument number */ + case 'v': + if (token_present == 0) break; + case 'V': + if (token_present == 0) + { + SLang_verror (SL_INVALID_PARM, "%s: Expecting argument", cmd_name); + goto error; + } + + while (*last_str == ' ') last_str++; + len = strlen (last_str); + str = last_str + len; + + s = SLmake_nstring (last_str, len); + if (s == NULL) goto error; + + table->arg_type[argc] = SLANG_STRING_TYPE; + table->string_args[argc++] = s; + break; + + case 's': + if (token_present == 0) break; + case 'S': + if (token_present == 0) + { + SLang_verror (SL_TYPE_MISMATCH, "%s: Expecting string argument", cmd_name); + goto error; + } + + s = SLmake_nstring (buf, len); + if (s == NULL) goto error; + table->arg_type[argc] = SLANG_STRING_TYPE; + table->string_args[argc++] = s; + break; + + /* integer argument */ + case 'i': + if (token_present == 0) break; + case 'I': + if ((token_present == 0) || (SLANG_INT_TYPE != guess_type)) + { + SLang_verror (SL_TYPE_MISMATCH, "%s: Expecting integer argument", cmd_name); + goto error; + } + + table->arg_type[argc] = SLANG_INT_TYPE; + table->int_args[argc++] = SLatoi((unsigned char *) buf); + break; + + /* floating point arg */ +#if SLANG_HAS_FLOAT + case 'f': + if (token_present == 0) break; + case 'F': + if ((token_present == 0) || (SLANG_STRING_TYPE == guess_type)) + { + SLang_verror (SL_TYPE_MISMATCH, "%s: Expecting double argument", cmd_name); + goto error; + } + table->arg_type[argc] = SLANG_DOUBLE_TYPE; + table->double_args[argc++] = atof(buf); + break; +#endif + /* Generic type */ + case 'g': + if (token_present == 0) break; + case 'G': + if (token_present == 0) + { + SLang_verror (SL_TYPE_MISMATCH, "%s: Expecting argument", cmd_name); + goto error; + } + + switch (guess_type) + { + case SLANG_INT_TYPE: + table->arg_type[argc] = SLANG_INT_TYPE; + table->int_args[argc++] = SLatoi((unsigned char *) buf); + break; + + case SLANG_STRING_TYPE: + s = SLmake_nstring (buf, len); + if (s == NULL) goto error; + + table->arg_type[argc] = SLANG_STRING_TYPE; + table->string_args[argc++] = s; + break; +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + table->arg_type[argc] = SLANG_DOUBLE_TYPE; + table->double_args[argc++] = atof(buf); +#endif + } + break; + } + } + + /* call function */ + status = (*cmd->cmdfun)(argc, table); + + error: + if (table->string_args != NULL) for (i = 0; i < argc; i++) + { + if (NULL != table->string_args[i]) + { + SLfree (table->string_args[i]); + table->string_args[i] = NULL; + } + } + SLfree ((char *)table->string_args); table->string_args = NULL; + SLfree ((char *)table->double_args); table->double_args = NULL; + SLfree ((char *)table->int_args); table->int_args = NULL; + SLfree ((char *)table->arg_type); table->arg_type = NULL; + + SLfree (buf); + return status; +} + diff --git a/libslang/src/slcmplex.c b/libslang/src/slcmplex.c new file mode 100644 index 0000000..dffa79a --- /dev/null +++ b/libslang/src/slcmplex.c @@ -0,0 +1,1142 @@ +/* Complex Data Type definition for S-Lang */ +/* Copyright (c) 1997, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* The rest of the file is enclosed in this #if */ +#if SLANG_HAS_COMPLEX + +#if SLANG_HAS_FLOAT +# include +#endif + +#ifdef PI +# undef PI +#endif +#define PI 3.14159265358979323846 + +int SLang_pop_complex (double *r, double *i) +{ + double *c; + + switch (SLang_peek_at_stack ()) + { + case SLANG_COMPLEX_TYPE: + if (-1 == SLclass_pop_ptr_obj (SLANG_COMPLEX_TYPE, (VOID_STAR *)&c)) + return -1; + *r = c[0]; + *i = c[1]; + SLfree ((char *) c); + break; + + default: + *i = 0.0; + if (-1 == SLang_pop_double (r, NULL, NULL)) + return -1; + break; + + case -1: + return -1; + } + return 0; +} + +int SLang_push_complex (double r, double i) +{ + double *c; + + c = (double *) SLmalloc (2 * sizeof (double)); + if (c == NULL) + return -1; + + c[0] = r; + c[1] = i; + + if (-1 == SLclass_push_ptr_obj (SLANG_COMPLEX_TYPE, (VOID_STAR) c)) + { + SLfree ((char *) c); + return -1; + } + return 0; +} + +double *SLcomplex_times (double *c, double *a, double *b) +{ + double a_real, b_real, a_imag, b_imag; + + a_real = a[0]; + b_real = b[0]; + a_imag = a[1]; + b_imag = b[1]; + + c[0] = a_real * b_real - a_imag * b_imag; + c[1] = a_imag * b_real + a_real * b_imag; + + return c; +} + +double *SLcomplex_divide (double *c, double *a, double *b) +{ + double a_real, b_real, a_imag, b_imag; + double ratio, invden; + + a_real = a[0]; + b_real = b[0]; + a_imag = a[1]; + b_imag = b[1]; + + /* Do it this way to avoid overflow in the denom */ + if (fabs(b_real) > fabs(b_imag)) + { + ratio = b_imag / b_real; + invden = 1.0 / (b_real + b_imag * ratio); + c[0] = (a_real + ratio * a_imag) * invden; + c[1] = (a_imag - a_real * ratio) * invden; + } + else + { + ratio = b_real / b_imag; + invden = 1.0 / (b_real * ratio + b_imag); + c[0] = (a_real * ratio + a_imag) * invden; + c[1] = (a_imag * ratio - a_real) * invden; + } + return c; +} + +/* a^b = exp (b log a); */ +double *SLcomplex_pow (double *c, double *a, double *b) +{ + return SLcomplex_exp (c, SLcomplex_times (c, b, SLcomplex_log (c, a))); +} + +static double *complex_dpow (double *c, double *a, double b) +{ + SLcomplex_log (c, a); + c[0] *= b; + c[1] *= b; + return SLcomplex_exp (c, c); +} + +static double *dcomplex_pow (double *c, double a, double *b) +{ + a = log (a); + c[0] = a * b[0]; + c[1] = a * b[1]; + return SLcomplex_exp (c, c); +} + +double SLcomplex_abs (double *z) +{ + return SLmath_hypot (z[0], z[1]); +} + +/* It appears that FORTRAN assumes that the branch cut for the log function + * is along the -x axis. So, use this for atan2: + */ +static double my_atan2 (double y, double x) +{ + double val; + + val = atan (y/x); + + if (x >= 0) + return val; /* I, IV */ + + if (y <= 0) /* III */ + return val - PI; + + return PI + val; /* II */ +} + +static void polar_form (double *r, double *theta, double *z) +{ + double x, y; + + *r = SLcomplex_abs (z); + + x = z[0]; + y = z[1]; + + if (x == 0.0) + { + if (y >= 0) + *theta = 0.5 * PI; + else + *theta = 1.5 * PI; + } + else *theta = my_atan2 (y, x); +} + +double *SLcomplex_sin (double *sinz, double *z) +{ + double x, y; + + x = z[0]; y = z[1]; + sinz[0] = sin (x) * cosh (y); + sinz[1] = cos (x) * sinh (y); + return sinz; +} + +double *SLcomplex_cos (double *cosz, double *z) +{ + double x, y; + + x = z[0]; y = z[1]; + cosz[0] = cos (x) * cosh (y); + cosz[1] = -sin (x) * sinh (y); + return cosz; +} + +double *SLcomplex_exp (double *expz, double *z) +{ + double r, i; + + r = exp (z[0]); + i = z[1]; + expz[0] = r * cos (i); + expz[1] = r * sin (i); + return expz; +} + +double *SLcomplex_log (double *logz, double *z) +{ + double r, theta; + + polar_form (&r, &theta, z); /* log R.e^(ix) = log R + ix */ + logz[0] = log(r); + logz[1] = theta; + return logz; +} + +double *SLcomplex_log10 (double *log10z, double *z) +{ + double l10 = log (10.0); + (void) SLcomplex_log (log10z, z); + log10z[0] = log10z[0] / l10; + log10z[1] = log10z[1] / l10; + return log10z; +} + +double *SLcomplex_sqrt (double *sqrtz, double *z) +{ + double r, x, y; + + x = z[0]; + y = z[1]; + + r = SLmath_hypot (x, y); + + if (r == 0.0) + { + sqrtz [0] = sqrtz [1] = 0.0; + return sqrtz; + } + + if (x >= 0.0) + { + x = sqrt (0.5 * (r + x)); + y = 0.5 * y / x; + } + else + { + r = sqrt (0.5 * (r - x)); + x = 0.5 * y / r; + y = r; + + if (x < 0.0) + { + x = -x; + y = -y; + } + } + + sqrtz[0] = x; + sqrtz[1] = y; + + return sqrtz; +} + +double *SLcomplex_tan (double *tanz, double *z) +{ + double x, y, invden; + + x = 2 * z[0]; + y = 2 * z[1]; + invden = 1.0 / (cos (x) + cosh (y)); + tanz[0] = invden * sin (x); + tanz[1] = invden * sinh (y); + return tanz; +} + +/* Utility Function */ +static void compute_alpha_beta (double *z, double *alpha, double *beta) +{ + double x, y, a, b; + + x = z[0]; + y = z[1]; + a = 0.5 * SLmath_hypot (x + 1, y); + b = 0.5 * SLmath_hypot (x - 1, y); + + *alpha = a + b; + *beta = a - b; +} + +double *SLcomplex_asin (double *asinz, double *z) +{ + double alpha, beta; + + compute_alpha_beta (z, &alpha, &beta); + asinz[0] = asin (beta); + asinz[1] = log (alpha + sqrt (alpha * alpha - 1)); + return asinz; +} + +double *SLcomplex_acos (double *acosz, double *z) +{ + double alpha, beta; + + compute_alpha_beta (z, &alpha, &beta); + acosz[0] = acos (beta); + acosz[1] = -log (alpha + sqrt (alpha * alpha - 1)); + return acosz; +} + +double *SLcomplex_atan (double *atanz, double *z) +{ + double x, y; + double z1[2], z2[2]; + + x = z[0]; y = z[1]; + z1[0] = x; + z1[1] = 1 + y; + z2[0] = -x; + z2[1] = 1 - y; + + SLcomplex_log (z1, SLcomplex_divide (z2, z1, z2)); + atanz[0] = -0.5 * z1[1]; + atanz[1] = 0.5 * z1[0]; + + return atanz; +} + +double *SLcomplex_sinh (double *sinhz, double *z) +{ + double x, y; + x = z[0]; y = z[1]; + sinhz[0] = sinh (x) * cos (y); + sinhz[1] = cosh (x) * sin (y); + return sinhz; +} + +double *SLcomplex_cosh (double *coshz, double *z) +{ + double x, y; + x = z[0]; y = z[1]; + coshz[0] = cosh (x) * cos (y); + coshz[1] = sinh (x) * sin (y); + return coshz; +} + +double *SLcomplex_tanh (double *tanhz, double *z) +{ + double x, y, invden; + x = 2 * z[0]; + y = 2 * z[1]; + invden = 1.0 / (cosh (x) + cos (y)); + tanhz[0] = invden * sinh (x); + tanhz[1] = invden * sin (y); + return tanhz; +} +#if 0 +static double *not_implemented (char *fun, double *p) +{ + SLang_verror (SL_NOT_IMPLEMENTED, "%s for complex numbers has not been implemented", + fun); + *p = -1.0; + return p; +} +#endif +/* Use: asinh(z) = -i asin(iz) */ +double *SLcomplex_asinh (double *asinhz, double *z) +{ + double iz[2]; + + iz[0] = -z[1]; + iz[1] = z[0]; + + (void) SLcomplex_asin (iz, iz); + asinhz[0] = iz[1]; + asinhz[1] = -iz[0]; + + return asinhz; +} + +/* Use: acosh (z) = i acos(z) */ +double *SLcomplex_acosh (double *acoshz, double *z) +{ + double iz[2]; + + (void) SLcomplex_acos (iz, z); + acoshz[0] = -iz[1]; + acoshz[1] = iz[0]; + + return acoshz; +} + +/* Use: atanh(z) = -i atan(iz) */ +double *SLcomplex_atanh (double *atanhz, double *z) +{ + double iz[2]; + + iz[0] = -z[1]; + iz[1] = z[0]; + + (void) SLcomplex_atan (iz, iz); + atanhz[0] = iz[1]; + atanhz[1] = -iz[0]; + + return atanhz; +} + +static int complex_binary_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) a; (void) b; + + switch (op) + { + default: + case SLANG_POW: + case SLANG_PLUS: + case SLANG_MINUS: + case SLANG_TIMES: + case SLANG_DIVIDE: + *c = SLANG_COMPLEX_TYPE; + break; + + case SLANG_EQ: + case SLANG_NE: + *c = SLANG_CHAR_TYPE; + break; + } + return 1; +} + +static int complex_complex_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + double *a, *b, *c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + a = (double *) ap; + b = (double *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = 2; + if (nb == 1) db = 0; else db = 2; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] + b[0]; + c[n + 1] = a[1] + b[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] - b[0]; + c[n + 1] = a[1] - b[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + SLcomplex_times (c + n, a, b); + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + if ((b[0] == 0.0) && (b[1] == 0.0)) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + SLcomplex_divide (c + n, a, b); + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] == b[0]) && (a[1] == b[1])); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] != b[0]) || (a[1] != b[1])); + a += da; b += db; + } + break; + + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + SLcomplex_pow (c + n, a, b); + a += da; b += db; + } + break; + + } + + return 1; +} + +static int complex_double_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + double *a, *b, *c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + a = (double *) ap; + b = (double *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = 2; + if (nb == 1) db = 0; else db = 1; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] + b[0]; + c[n + 1] = a[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] - b[0]; + c[n + 1] = a[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + double b0 = b[0]; + c[n] = a[0] * b0; + c[n + 1] = a[1] * b0; + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + double b0 = b[0]; + if (b0 == 0.0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = a[0] / b0; + c[n + 1] = a[1] / b0; + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] == b[0]) && (a[1] == 0.0)); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] != b[0]) || (a[1] != 0.0)); + a += da; b += db; + } + break; + + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + complex_dpow (c + n, a, b[0]); + a += da; b += db; + } + break; + } + + return 1; +} + +static int double_complex_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + double *a, *b, *c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + a = (double *) ap; + b = (double *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = 1; + if (nb == 1) db = 0; else db = 2; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] + b[0]; + c[n + 1] = b[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] - b[0]; + c[n + 1] = -b[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + double a0 = a[0]; + c[n] = a0 * b[0]; + c[n + 1] = a0 * b[1]; + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + double z[2]; + if ((b[0] == 0.0) && (b[1] == 0.0)) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + z[0] = a[0]; + z[1] = 0.0; + SLcomplex_divide (c + n, z, b); + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] == b[0]) && (0.0 == b[1])); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] != b[0]) || (0.0 != b[1])); + a += da; b += db; + } + break; + + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + dcomplex_pow (c + n, a[0], b); + a += da; b += db; + } + break; + } + + return 1; +} + +static int complex_generic_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + char *b; + double *a, *c; + unsigned int n, n_max; + unsigned int da, db; + unsigned int sizeof_b; + SLang_To_Double_Fun_Type to_double; + + if (NULL == (to_double = SLarith_get_to_double_fun (b_type, &sizeof_b))) + return 0; + + (void) a_type; + + a = (double *) ap; + b = (char *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = 2; + if (nb == 1) db = 0; else db = sizeof_b; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + complex_dpow (c + n, a, to_double((VOID_STAR)b)); + a += da; b += db; + } + break; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] + to_double((VOID_STAR)b); + c[n + 1] = a[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] - to_double((VOID_STAR)b); + c[n + 1] = a[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + double b0 = to_double((VOID_STAR)b); + c[n] = a[0] * b0; + c[n + 1] = a[1] * b0; + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + double b0 = to_double((VOID_STAR)b); + if (b0 == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = a[0] / b0; + c[n + 1] = a[1] / b0; + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] == to_double((VOID_STAR)b)) && (a[1] == 0.0)); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] != to_double((VOID_STAR)b)) || (a[1] != 0.0)); + a += da; b += db; + } + break; + } + + return 1; +} + +static int generic_complex_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + double *b, *c; + char *a, *ic; + unsigned int n, n_max; + unsigned int da, db; + unsigned int sizeof_a; + SLang_To_Double_Fun_Type to_double; + + if (NULL == (to_double = SLarith_get_to_double_fun (a_type, &sizeof_a))) + return 0; + + (void) b_type; + + a = (char *) ap; + b = (double *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = sizeof_a; + if (nb == 1) db = 0; else db = 2; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + dcomplex_pow (c + n, to_double((VOID_STAR)a), b); + a += da; b += db; + } + break; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = to_double((VOID_STAR)a) + b[0]; + c[n + 1] = b[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = to_double((VOID_STAR)a) - b[0]; + c[n + 1] = -b[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + double a0 = to_double((VOID_STAR)a); + c[n] = a0 * b[0]; + c[n + 1] = a0 * b[1]; + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + double z[2]; + if ((b[0] == 0.0) && (b[1] == 0.0)) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + z[0] = to_double((VOID_STAR)a); + z[1] = 0.0; + SLcomplex_divide (c + n, z, b); + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((to_double((VOID_STAR)a) == b[0]) && (0.0 == b[1])); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((to_double((VOID_STAR)a) != b[0]) || (0.0 != b[1])); + a += da; b += db; + } + break; + } + + return 1; +} + +static int complex_unary_result (int op, unsigned char a, unsigned char *b) +{ + (void) a; + + switch (op) + { + default: + return 0; + + case SLANG_PLUSPLUS: + case SLANG_MINUSMINUS: + case SLANG_CHS: + case SLANG_MUL2: + *b = SLANG_COMPLEX_TYPE; + break; + + case SLANG_SQR: /* |Real|^2 + |Imag|^2 ==> double */ + case SLANG_ABS: /* |z| ==> double */ + *b = SLANG_DOUBLE_TYPE; + break; + + case SLANG_SIGN: + *b = SLANG_INT_TYPE; + break; + } + return 1; +} + +static int complex_unary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + unsigned int n; + double *a, *b; + int *ic; + + (void) a_type; + + a = (double *) ap; + b = (double *) bp; + ic = (int *) bp; + + na = 2 * na; + + switch (op) + { + default: + return 0; + + case SLANG_PLUSPLUS: + for (n = 0; n < na; n += 2) b[n] = (a[n] + 1); + break; + case SLANG_MINUSMINUS: + for (n = 0; n < na; n += 2) b[n] = (a[n] - 1); + break; + case SLANG_CHS: + for (n = 0; n < na; n += 2) + { + b[n] = -(a[n]); + b[n + 1] = -(a[n + 1]); + } + break; + case SLANG_SQR: /* |Real|^2 + |Imag|^2 ==> double */ + for (n = 0; n < na; n += 2) + b[n/2] = (a[n] * a[n] + a[n + 1] * a[n + 1]); + break; + + case SLANG_MUL2: + for (n = 0; n < na; n += 2) + { + b[n] = (2 * a[n]); + b[n + 1] = (2 * a[n + 1]); + } + break; + + case SLANG_ABS: /* |z| ==> double */ + for (n = 0; n < na; n += 2) + b[n/2] = SLcomplex_abs (a + n); + break; + + case SLANG_SIGN: + /* Another creative extension. Lets return an integer which indicates + * whether the complex number is in the upperhalf plane or not. + */ + for (n = 0; n < na; n += 2) + { + if (a[n + 1] < 0.0) ic[n/2] = -1; + else if (a[n + 1] > 0.0) ic[n/2] = 1; + else ic[n/2] = 0; + } + break; + } + + return 1; +} + +static int +complex_typecast (unsigned char from_type, VOID_STAR from, unsigned int num, + unsigned char to_type, VOID_STAR to) +{ + double *z; + double *d; + char *i; + unsigned int n; + unsigned int sizeof_i; + SLang_To_Double_Fun_Type to_double; + + (void) to_type; + + z = (double *) to; + + switch (from_type) + { + default: + if (NULL == (to_double = SLarith_get_to_double_fun (from_type, &sizeof_i))) + return 0; + i = (char *) from; + for (n = 0; n < num; n++) + { + *z++ = to_double ((VOID_STAR) i); + *z++ = 0.0; + + i += sizeof_i; + } + break; + + case SLANG_DOUBLE_TYPE: + d = (double *) from; + for (n = 0; n < num; n++) + { + *z++ = d[n]; + *z++ = 0.0; + } + break; + } + + return 1; +} + +static void complex_destroy (unsigned char type, VOID_STAR ptr) +{ + (void) type; + SLfree ((char *)*(double **) ptr); +} + +static int complex_push (unsigned char type, VOID_STAR ptr) +{ + double *z; + + (void) type; + z = *(double **) ptr; + return SLang_push_complex (z[0], z[1]); +} + +static int complex_pop (unsigned char type, VOID_STAR ptr) +{ + double *z; + + (void) type; + z = *(double **) ptr; + return SLang_pop_complex (&z[0], &z[1]); +} + +int _SLinit_slcomplex (void) +{ + SLang_Class_Type *cl; + unsigned char *types; + + if (NULL == (cl = SLclass_allocate_class ("Complex_Type"))) + return -1; + + (void) SLclass_set_destroy_function (cl, complex_destroy); + (void) SLclass_set_push_function (cl, complex_push); + (void) SLclass_set_pop_function (cl, complex_pop); + + if (-1 == SLclass_register_class (cl, SLANG_COMPLEX_TYPE, 2 * sizeof (double), + SLANG_CLASS_TYPE_VECTOR)) + return -1; + + types = _SLarith_Arith_Types; + while (*types != SLANG_DOUBLE_TYPE) + { + unsigned char t = *types++; + + if ((-1 == SLclass_add_binary_op (t, SLANG_COMPLEX_TYPE, generic_complex_binary, complex_binary_result)) + || (-1 == SLclass_add_binary_op (SLANG_COMPLEX_TYPE, t, complex_generic_binary, complex_binary_result)) + || (-1 == (SLclass_add_typecast (t, SLANG_COMPLEX_TYPE, complex_typecast, 1)))) + return -1; + } + + if ((-1 == (SLclass_add_binary_op (SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, complex_complex_binary, complex_binary_result))) + || (-1 == (SLclass_add_binary_op (SLANG_COMPLEX_TYPE, SLANG_DOUBLE_TYPE, complex_double_binary, complex_binary_result))) + || (-1 == (SLclass_add_binary_op (SLANG_DOUBLE_TYPE, SLANG_COMPLEX_TYPE, double_complex_binary, complex_binary_result))) + || (-1 == (SLclass_add_unary_op (SLANG_COMPLEX_TYPE, complex_unary, complex_unary_result))) + || (-1 == (SLclass_add_typecast (SLANG_DOUBLE_TYPE, SLANG_COMPLEX_TYPE, complex_typecast, 1)))) + return -1; + + return 0; +} + +#endif /* if SLANG_HAS_COMPLEX */ + diff --git a/libslang/src/slcompat.c b/libslang/src/slcompat.c new file mode 100644 index 0000000..4f4f654 --- /dev/null +++ b/libslang/src/slcompat.c @@ -0,0 +1,34 @@ +/* These functions are provided for backward compatibility and are obsolete. + * Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* Compatibility */ +int SLang_init_slunix (void) +{ + if ((-1 == SLang_init_posix_dir ()) + || (-1 == SLang_init_posix_process ()) + || (-1 == SLdefine_for_ifdef ("__SLUNIX__"))) + return -1; + + return 0; +} + +int SLang_init_slfile (void) +{ + if ((-1 == SLang_init_stdio ()) + || (-1 == SLang_init_posix_dir ()) + || (-1 == SLdefine_for_ifdef("__SLFILE__"))) + return -1; + + return 0; +} + diff --git a/libslang/src/slconfig.h b/libslang/src/slconfig.h new file mode 100644 index 0000000..fd23847 --- /dev/null +++ b/libslang/src/slconfig.h @@ -0,0 +1,239 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* This configuration file is for all non-Unix OS */ +#define _SLANG_SOURCE_ 1 + +#ifdef VMS +# ifdef __DECC +# define HAVE_STDLIB_H +# endif +/* Borland's compiler complains about long constants, so I will work + * around it as follows: + */ +# define VMS_VERSION_602 60200000 +# define VMS_VERSION_700 70000000 +# if __VMS_VER >= VMS_VERSION_602 +# define HAVE_UNISTD_H +# endif +#endif + +/* [JMS:BC5] The Borland v5.x compiler defines some things that other versions, + * and MSC don't, so we can check for those using ifdef __BORLAND_V5__ + */ + +#if defined(__BORLANDC__) && ((__BORLANDC__>>8) == 0x5) +# define __BORLAND_V5__ +#endif + + +#if defined(__WATCOMC__) && defined(__DOS__) +# define DOS386 +#endif + +/* Set of the various defines for pc systems. This includes OS/2 */ + +/* DJGPP has a split personality. It tries implement a unix like environment + * under MSDOS. Unfortunately, the personalities clash. + */ +#ifdef __GO32__ +# ifndef __DJGPP__ +# define __DJGPP__ 1 +# endif +#endif + +#if defined(__DJGPP__) || defined(__CYGWIN32__) || defined(__MINGW32__) +# ifdef REAL_UNIX_SYSTEM +# undef REAL_UNIX_SYSTEM +# endif +#endif + +#if defined(__MSDOS__) || defined(__DOS__) +# ifndef __MSDOS__ +# define __MSDOS__ +# endif +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif + +#if defined(OS2) || defined(__OS2__) +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +# ifndef __os2__ +# define __os2__ +# endif +#endif + +#if defined(__CYGWIN32__) || defined(__MINGW32__) +# ifndef __WIN32__ +# define __WIN32__ +# endif +#endif + +#if defined(WIN32) || defined(__WIN32__) +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +# ifndef __WIN32__ +# define __WIN32__ +# endif +#endif + +#if defined(__MSDOS__) && !defined(__GO32__) && !defined(DOS386) && !defined(__WIN32__) +# ifndef __MSDOS_16BIT__ +# define __MSDOS_16BIT__ 1 +# endif +#endif + +#if defined(MSWINDOWS) +# ifndef __WIN16__ +# define __WIN16__ +# endif +#endif + +#if defined(__WIN16__) || defined(__MSDOS_16BIT__) +# define __16_BIT_SYSTEM__ 1 +#endif + +#if defined(__WATCOMC__) && !defined(__QNX__) +# undef unix +# undef __unix__ +#endif /* __WATCOMC__ */ + +#ifdef IBMPC_SYSTEM +# define HAVE_STDLIB_H +# define HAVE_PUTENV +# if defined(__GO32__) || defined(__MINGW32__) || defined(__CYGWIN32__) +# define HAVE_UNISTD_H +# endif +#endif + +#ifdef VMS +# if __VMS_VER >= VMS_VERSION_700 +# define HAVE_MEMORY_H +# endif +#else +# if !defined(__WATCOMC__) +# define HAVE_MEMORY_H +# endif +#endif + +#define HAVE_MEMCPY +#define HAVE_MEMSET + +#if !defined(VMS) || (__VMS_VER >= VMS_VERSION_700) +# define HAVE_MEMCMP +# define HAVE_MEMCHR +# define HAVE_FCNTL_H +#endif + +#define HAVE_GETCWD 1 + +#ifndef VMS +# define HAVE_VFSCANF 1 +# define HAVE_STRTOD 1 +#endif + + +/* Does VMS have this??? */ +#if !defined(VMS) && !defined(_MSC_VER) && (!defined(__WATCOMC__) || defined(__QNX__)) +# define HAVE_DIRENT_H 1 +#endif + +#if defined(VMS) || (defined(__WATCOMC__) && !defined(__QNX__)) +# define HAVE_DIRECT_H 1 +#endif + +#if defined(__unix__) || (defined(VMS) && (__VMS_VER >= VMS_VERSION_700)) +# define HAVE_KILL 1 +# define HAVE_CHOWN 1 +#endif + +#define HAVE_ATEXIT 1 + +/* Do these systems have these functions? For now, assume the worst */ +#undef HAVE_GETPPID +#undef HAVE_GETGID +#undef HAVE_GETEGID +#undef HAVE_GETEUID +#undef HAVE_SETGID +#undef HAVE_SETPGID +#undef HAVE_SETUID +#undef HAVE_ISSETUGID + +/* Needed for tic/toc */ +#undef HAVE_TIMES +#undef HAVE_SYS_TIMES_H + +#undef HAVE_GMTIME +#ifdef __unix__ +# define HAVE_GMTIME 1 +#endif + +#undef HAVE_READLINK +#undef HAVE_UNAME + +#undef HAVE_POPEN + +/* Define if you have the vsnprintf, snprintf functions and they return + * EOF upon failure. + */ +#undef HAVE_VSNPRINTF +#undef HAVE_SNPRINTF + +#if defined(__unix__) || defined(__DECC) || defined(__BORLAND_V5__) +#else +# define mode_t int +# define pid_t int +# define uid_t int +# define gid_t int +#endif + +#if defined (__EMX__) || defined(__BORLANDC__) || defined(__IBMC__) || defined(_MSC_VER) +# define HAVE_IO_H +#endif + +#if defined(_MSC_VER) || defined(__IBMC__) || defined(__BORLANDC__) || defined(__MINGW32__) +# define HAVE_PROCESS_H +#endif + +#ifdef _MSC_VER +# define HAVE_POPEN 1 +# define popen _popen +# define pclose _pclose +#endif + +#ifdef VMS +# define SIZEOF_SHORT 2 +# define SIZEOF_INT 4 +# if defined(__alpha__) || defined(__ALPHA__) || defined(__alpha) +/* Apparantly, when compaq bought digital, the size of the long was reduced + * to 4 bytes for the alpha on VMS. On unix it is still 8 bytes. + */ +# define SIZEOF_LONG 4 +# else +# define SIZEOF_LONG 4 +# endif +# define SIZEOF_FLOAT 4 +# define SIZEOF_DOUBLE 8 + +#else /* NOT VMS */ + +# define SIZEOF_SHORT 2 +# if defined(__WIN16__) || defined(__MSDOS_16BIT__) +# define SIZEOF_INT 2 +#else +# define SIZEOF_INT 4 +#endif +#define SIZEOF_LONG 4 +#define SIZEOF_FLOAT 4 +#define SIZEOF_DOUBLE 8 + +#endif /* ifdef VMS */ + diff --git a/libslang/src/slcurses.c b/libslang/src/slcurses.c new file mode 100644 index 0000000..7329189 --- /dev/null +++ b/libslang/src/slcurses.c @@ -0,0 +1,1021 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include +#include + +#include "slang.h" +#include "_slang.h" +#include "slcurses.h" + +/* This file is meant to implement a primitive curses implementation in + * terms of SLsmg calls. The fact is that the interfaces are sufficiently + * different that a 100% emulation is not possible. + */ + +SLcurses_Window_Type *SLcurses_Stdscr; +int SLcurses_Esc_Delay = 150; /* 0.15 seconds */ +SLtt_Char_Type SLcurses_Acs_Map [128]; +int SLcurses_Is_Endwin = 1; +int SLcurses_Num_Colors = 8; + +static void blank_line (SLsmg_Char_Type *b, unsigned int len, SLsmg_Char_Type color) +{ + SLsmg_Char_Type *bmax; + + bmax = b + len; + color = SLSMG_BUILD_CHAR(' ', color); + + while (b < bmax) *b++ = color; +} + +static int va_mvprintw (SLcurses_Window_Type *w, int r, int c, int do_move, + char *fmt, va_list ap) +{ + char buf[1024]; + + if (do_move) SLcurses_wmove (w, r, c); + + (void) _SLvsnprintf (buf, sizeof(buf), fmt, ap); + + SLcurses_waddnstr (w, buf, -1); + return 0; +} + +int SLcurses_mvprintw (int r, int c, char *fmt, ...) +{ + va_list ap; + + va_start(ap, fmt); + va_mvprintw (SLcurses_Stdscr, r, c, 1, fmt, ap); + va_end(ap); + + return 0; +} + +int SLcurses_mvwprintw (SLcurses_Window_Type *w, int r, int c, char *fmt, ...) +{ + va_list ap; + + va_start(ap, fmt); + va_mvprintw (w, r, c, 1, fmt, ap); + va_end(ap); + + return 0; +} + +int SLcurses_wprintw (SLcurses_Window_Type *w, char *fmt, ...) +{ + va_list ap; + + va_start(ap, fmt); + va_mvprintw (w, 0, 0, 0, fmt, ap); + va_end(ap); + + return 0; +} + +int SLcurses_printw (char *fmt, ...) +{ + va_list ap; + + va_start(ap, fmt); + va_mvprintw (SLcurses_Stdscr, 0, 0, 0, fmt, ap); + va_end(ap); + + return 0; +} + +int SLcurses_nil (void) +{ + return 0; +} + +int SLcurses_has_colors(void) +{ + return SLtt_Use_Ansi_Colors; +} + +int SLcurses_nodelay (SLcurses_Window_Type *w, int onoff) +{ + w->delay_off = (onoff ? 0 : -1); + return 0; +} + +static unsigned char Keyboard_Buffer[256]; +static unsigned char *Keyboard_Buffer_Start = Keyboard_Buffer; +static unsigned char *Keyboard_Buffer_Stop = Keyboard_Buffer; + +static int getkey_function (void) +{ + int ch; + + ch = SLang_getkey (); + if (ch != SLANG_GETKEY_ERROR) + { + *Keyboard_Buffer_Stop++ = (unsigned char) ch; + if (Keyboard_Buffer_Stop == Keyboard_Buffer + sizeof (Keyboard_Buffer)) + Keyboard_Buffer_Stop = Keyboard_Buffer; + } + + return ch; +} + +static int get_buffered_key (void) +{ + int ch; + + if (Keyboard_Buffer_Stop == Keyboard_Buffer_Start) + return SLANG_GETKEY_ERROR; + + ch = *Keyboard_Buffer_Start++; + if (Keyboard_Buffer_Start == Keyboard_Buffer + sizeof (Keyboard_Buffer)) + Keyboard_Buffer_Start = Keyboard_Buffer; + + return ch; +} + +static int get_keypad_key (void) +{ + int ch; + + if (Keyboard_Buffer_Stop != Keyboard_Buffer_Start) + return get_buffered_key (); + + ch = SLang_getkey (); + if (ch == '\033') + { + if (0 == SLang_input_pending (ESCDELAY / 100)) + return ch; + } + else if (ch == SLANG_GETKEY_ERROR) return ERR; + SLang_ungetkey (ch); + ch = SLkp_getkey (); + if (ch == SL_KEY_ERR) + ch = get_buffered_key (); + else + Keyboard_Buffer_Stop = Keyboard_Buffer_Start; + return ch; +} + +int SLcurses_wgetch (SLcurses_Window_Type *w) +{ + if (w == NULL) + return ERR; + + SLcurses_wrefresh (w); + + if ((Keyboard_Buffer_Start != Keyboard_Buffer_Stop) + || (w->delay_off == -1) + || SLang_input_pending (w->delay_off)) + { + if (w->use_keypad) + return get_keypad_key (); + + return SLang_getkey (); + } + + return ERR; +} + +int SLcurses_getch (void) +{ + return SLcurses_wgetch (SLcurses_Stdscr); +} + +/* This is a super hack. That fact is that SLsmg and curses + * are incompatible. + */ +static unsigned char Color_Objects[256]; + +static unsigned int map_attr_to_object (SLtt_Char_Type attr) +{ + unsigned int obj; + SLtt_Char_Type at; + + obj = (attr >> 8) & 0xFF; + + if (SLtt_Use_Ansi_Colors) + { + if (Color_Objects[obj] != 0) return obj; + + at = SLtt_get_color_object (obj & 0xF); + + if (attr & A_BOLD) at |= SLTT_BOLD_MASK; + if (attr & A_UNDERLINE) at |= SLTT_ULINE_MASK; + if (attr & A_REVERSE) at |= SLTT_REV_MASK; + + SLtt_set_color_object (obj, at); + + Color_Objects[obj] = 1; + } + else obj = obj & 0xF0; + + return obj; + +} + +int SLcurses_start_color (void) +{ + int f, b; + int obj; + + if (SLtt_Use_Ansi_Colors == 0) return -1; + + obj = 0; + for (f = 0; f < 16; f++) + { + for (b = 0; b < 16; b++) + { + obj++; + SLtt_set_color_fgbg (obj, f, b); + } + } + return 0; +} + +#ifdef SIGINT +static void sigint_handler (int sig) +{ + SLang_reset_tty (); + SLsmg_reset_smg (); + exit (sig); +} +#endif + +/* Values are assumed to be 0, 1, 2. This fact is exploited */ +static int TTY_State; + +static int init_tty (int suspend_ok) +{ + if (-1 == SLang_init_tty (-1, 1, 0)) + return -1; + +#ifdef REAL_UNIX_SYSTEM + if (suspend_ok) SLtty_set_suspend_state (1); +#endif + return 0; +} + +int SLcurses_raw (void) +{ + TTY_State = 1; + return init_tty (0); +} + +int SLcurses_cbreak (void) +{ + TTY_State = 2; + return init_tty (1); +} + +#if defined(SIGTSTP) && defined(SIGSTOP) +static void sigtstp_handler (int sig) +{ + sig = errno; + + SLsmg_suspend_smg (); + + if (TTY_State) + SLang_reset_tty (); + + kill(getpid(),SIGSTOP); + + SLsmg_resume_smg (); + + if (TTY_State) init_tty (TTY_State - 1); + + signal (SIGTSTP, sigtstp_handler); + errno = sig; +} +#endif + +SLcurses_Window_Type *SLcurses_initscr (void) +{ + SLcurses_Is_Endwin = 0; + SLsmg_Newline_Behavior = SLSMG_NEWLINE_MOVES; + SLtt_get_terminfo (); + +#if !defined(IBMPC_SYSTEM) && !defined(VMS) + if (-1 == (SLcurses_Num_Colors = SLtt_tgetnum ("Co"))) +#endif + SLcurses_Num_Colors = 8; + + if ((-1 == SLkp_init ()) + || (-1 == SLcurses_cbreak ()) + || (NULL == (SLcurses_Stdscr = SLcurses_newwin (0, 0, 0, 0))) + || (-1 == SLsmg_init_smg ())) + { + SLang_doerror (NULL); + SLang_exit_error ("SLcurses_initscr: init failed\n"); + return NULL; + } + SLkp_set_getkey_function (getkey_function); + +#ifdef SIGINT + signal (SIGINT, sigint_handler); +#endif + +#if defined(SIGTSTP) && defined(SIGSTOP) + signal (SIGTSTP, sigtstp_handler); +#endif + + SLtt_set_mono (A_BOLD >> 8, NULL, SLTT_BOLD_MASK); + SLtt_set_mono (A_UNDERLINE >> 8, NULL, SLTT_ULINE_MASK); + SLtt_set_mono (A_REVERSE >> 8, NULL, SLTT_REV_MASK); + /* SLtt_set_mono (A_BLINK >> 8, NULL, SLTT_BLINK_MASK); */ + SLtt_set_mono ((A_BOLD|A_UNDERLINE) >> 8, NULL, SLTT_ULINE_MASK|SLTT_BOLD_MASK); + SLtt_set_mono ((A_REVERSE|A_UNDERLINE) >> 8, NULL, SLTT_ULINE_MASK|SLTT_REV_MASK); + + if (SLtt_Has_Alt_Charset) + { + SLcurses_Acs_Map[SLSMG_ULCORN_CHAR] = SLSMG_ULCORN_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_URCORN_CHAR] = SLSMG_URCORN_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_LLCORN_CHAR] = SLSMG_LLCORN_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_LRCORN_CHAR] = SLSMG_LRCORN_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_UTEE_CHAR] = SLSMG_UTEE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_DTEE_CHAR] = SLSMG_DTEE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_LTEE_CHAR] = SLSMG_LTEE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_RTEE_CHAR] = SLSMG_RTEE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_VLINE_CHAR] = SLSMG_VLINE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_HLINE_CHAR] = SLSMG_HLINE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_PLUS_CHAR] = SLSMG_PLUS_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_CKBRD_CHAR] = SLSMG_CKBRD_CHAR | A_ALTCHARSET; + } + else + { + /* ugly defaults to use on terminals which don't support graphics */ + SLcurses_Acs_Map[SLSMG_ULCORN_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_URCORN_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_LLCORN_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_LRCORN_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_UTEE_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_DTEE_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_LTEE_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_RTEE_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_VLINE_CHAR] = '|'; + SLcurses_Acs_Map[SLSMG_HLINE_CHAR] = '-'; + SLcurses_Acs_Map[SLSMG_PLUS_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_CKBRD_CHAR] = '#'; + } + + return SLcurses_Stdscr; +} + +int SLcurses_wattrset (SLcurses_Window_Type *w, SLtt_Char_Type ch) +{ + unsigned int obj; + + obj = map_attr_to_object (ch); + w->color = obj; + w->attr = ch; + return 0; +} + +int SLcurses_wattroff (SLcurses_Window_Type *w, SLtt_Char_Type ch) +{ + if (SLtt_Use_Ansi_Colors) + return SLcurses_wattrset (w, 0); + + w->attr &= ~ch; + return SLcurses_wattrset (w, w->attr); +} + +int SLcurses_wattron (SLcurses_Window_Type *w, SLtt_Char_Type ch) +{ + if (SLtt_Use_Ansi_Colors) + return SLcurses_wattrset (w, ch); + + w->attr |= ch; + return SLcurses_wattrset (w, w->attr); +} + +int SLcurses_delwin (SLcurses_Window_Type *w) +{ + if (w == NULL) return 0; + if (w->lines != NULL) + { + SLsmg_Char_Type **lines = w->lines; + if (w->is_subwin == 0) + { + unsigned int r, rmax; + + rmax = w->nrows; + for (r = 0; r < rmax; r++) + { + SLfree ((char *)lines[r]); + } + } + + SLfree ((char *)lines); + } + + SLfree ((char *)w); + if (w == SLcurses_Stdscr) + SLcurses_Stdscr = NULL; + return 0; +} + +SLcurses_Window_Type *SLcurses_newwin (unsigned int nrows, unsigned int ncols, + unsigned int r, unsigned int c) +{ + SLcurses_Window_Type *win; + SLsmg_Char_Type **lines; + + if (r >= (unsigned int) SLtt_Screen_Rows) + return NULL; + if (c >= (unsigned int) SLtt_Screen_Cols) + return NULL; + + if (NULL == (win = (SLcurses_Window_Type *) SLmalloc (sizeof (SLcurses_Window_Type)))) + return NULL; + + SLMEMSET ((char *) win, 0, sizeof (SLcurses_Window_Type)); + + if (nrows == 0) + nrows = (unsigned int) SLtt_Screen_Rows - r; + if (ncols == 0) + ncols = (unsigned int) SLtt_Screen_Cols - c; + + lines = (SLsmg_Char_Type **) SLmalloc (nrows * sizeof (SLsmg_Char_Type *)); + if (lines == NULL) + { + SLcurses_delwin (win); + return NULL; + } + + SLMEMSET ((char *) lines, 0, nrows * sizeof (SLsmg_Char_Type *)); + + win->lines = lines; + win->scroll_max = win->nrows = nrows; + win->ncols = ncols; + win->_begy = r; + win->_begx = c; + win->_maxx = (c + ncols) - 1; + win->_maxy = (r + nrows) - 1; + win->modified = 1; + win->delay_off = -1; + + for (r = 0; r < nrows; r++) + { + SLsmg_Char_Type *b; + + b = (SLsmg_Char_Type *) SLmalloc (ncols * sizeof (SLsmg_Char_Type)); + if (b == NULL) + { + SLcurses_delwin (win); + return NULL; + } + lines [r] = b; + blank_line (b, ncols, 0); + } + + return win; +} + +int SLcurses_wmove (SLcurses_Window_Type *win, unsigned int r, unsigned int c) +{ + if (win == NULL) return -1; + win->_cury = r; + win->_curx = c; + win->modified = 1; + return 0; +} + +static int do_newline (SLcurses_Window_Type *w) +{ + w->_curx = 0; + w->_cury += 1; + if (w->_cury >= w->scroll_max) + { + w->_cury = w->scroll_max - 1; + if (w->scroll_ok) + SLcurses_wscrl (w, 1); + } + + return 0; +} + +int SLcurses_waddch (SLcurses_Window_Type *win, SLtt_Char_Type attr) +{ + SLsmg_Char_Type *b, ch; + SLsmg_Char_Type color; + + if (win == NULL) return -1; + + if (win->_cury >= win->nrows) + { + /* Curses seems to move current postion to top of window. */ + win->_cury = win->_curx = 0; + return -1; + } + + win->modified = 1; + + ch = SLSMG_EXTRACT_CHAR(attr); + + if (attr == ch) + color = win->color; + else + { + /* hack to pick up the default color for graphics chars */ + if (((attr & A_COLOR) == 0) && ((attr & A_ALTCHARSET) != 0)) + { + /* FIXME: priority=medium: Use SLSMG_?? instead of << */ + attr |= win->color << 8; + } + color = map_attr_to_object (attr); + } + + if (ch < ' ') + { + if (ch == '\n') + { + SLcurses_wclrtoeol (win); + return do_newline (win); + } + + if (ch == '\r') + { + win->_curx = 0; + return 0; + } + + if (ch == '\b') + { + if (win->_curx > 0) + win->_curx--; + + return 0; + } + + /* HACK HACK!!!! */ + if (ch == '\t') ch = ' '; + } + + if (win->_curx >= win->ncols) + do_newline (win); + + b = win->lines[win->_cury] + win->_curx; + *b = SLSMG_BUILD_CHAR(ch,color); + win->_curx++; + + return 0; +} + +int SLcurses_wnoutrefresh (SLcurses_Window_Type *w) +{ + unsigned int len; + unsigned int r, c; + unsigned int i, imax; + + if (SLcurses_Is_Endwin) + { + if (TTY_State) init_tty (TTY_State - 1); + SLsmg_resume_smg (); + SLcurses_Is_Endwin = 0; + } + + if (w == NULL) + { + SLsmg_refresh (); + return -1; + } + + if (w->modified == 0) + return 0; + + r = w->_begy; + c = w->_begx; + + len = w->ncols; + imax = w->nrows; + + for (i = 0; i < imax; i++) + { + SLsmg_gotorc (r, c); + SLsmg_write_color_chars (w->lines[i], len); + r++; + } + + if (w->has_box) + SLsmg_draw_box(w->_begy, w->_begx, w->nrows, w->ncols); + + SLsmg_gotorc (w->_begy + w->_cury, w->_begx + w->_curx); + w->modified = 0; + return 0; +} + +int SLcurses_wrefresh (SLcurses_Window_Type *w) +{ + if (w == NULL) + return -1; + + if (w->modified == 0) + return 0; + + SLcurses_wnoutrefresh (w); + SLsmg_refresh (); + return 0; +} + +int SLcurses_wclrtoeol (SLcurses_Window_Type *w) +{ + SLsmg_Char_Type *b, *bmax; + SLsmg_Char_Type blank; + + if (w == NULL) return -1; + if (w->_cury >= w->nrows) + return 0; + + w->modified = 1; + + blank = SLSMG_BUILD_CHAR(' ',w->color); + + b = w->lines[w->_cury]; + bmax = b + w->ncols; + b += w->_curx; + + while (b < bmax) *b++ = blank; + return 0; +} + +int SLcurses_wclrtobot (SLcurses_Window_Type *w) +{ + SLsmg_Char_Type *b, *bmax; + SLsmg_Char_Type blank; + unsigned int r; + + if (w == NULL) return -1; + + w->modified = 1; + blank = SLSMG_BUILD_CHAR(' ',w->color); + SLcurses_wclrtoeol (w); + for (r = w->_cury + 1; r < w->nrows; r++) + { + b = w->lines [r]; + bmax = b + w->ncols; + + while (b < bmax) *b++ = blank; + } + + return 0; +} + +int SLcurses_wscrl (SLcurses_Window_Type *w, int n) +{ + SLsmg_Char_Type **lines; + unsigned int r, rmax, rmin, ncols; + SLsmg_Char_Type color; + + if ((w == NULL) || (w->scroll_ok == 0)) + return -1; + + w->modified = 1; +#if 0 + if (w->is_subwin) + { + SLang_reset_tty (); + SLsmg_reset_smg (); + fprintf (stderr, "\rAttempt to scroll a subwindow\n"); + exit (1); + } +#endif + + color = w->color; + ncols = w->ncols; + lines = w->lines; + rmax = w->scroll_max; + rmin = w->scroll_min; + if (rmax > w->nrows) + rmax = w->nrows; + if (rmin >= rmax) + return 0; + + while (n > 0) + { + for (r = rmin + 1; r < rmax; r++) + { + /* lines[r - 1] = lines[r]; */ + memcpy ((char *)lines[r - 1], (char *)lines[r], + sizeof (SLsmg_Char_Type) * ncols); + } + blank_line (lines[rmax - 1], ncols, color); + n--; + } + + rmax--; + while (n < 0) + { + for (r = rmax; r > rmin; r--) + { + memcpy ((char *)lines[r], (char *)lines[r - 1], + sizeof (SLsmg_Char_Type) * ncols); + } + blank_line (lines[rmin], ncols, color); + n++; + } + + /* wmove (w, w->nrows - 1, 0); */ + /* wclrtobot (w); */ + return 0; +} + +/* Note: if len is < 0, entire string will be used. + */ +int SLcurses_waddnstr (SLcurses_Window_Type *w, char *str, int len) +{ + SLsmg_Char_Type *b; + SLsmg_Char_Type color; + unsigned char ch; + unsigned int nrows, ncols, crow, ccol; + + if ((w == NULL) + || (str == NULL)) + return -1; + + w->modified = 1; + nrows = w->nrows; + ncols = w->ncols; + crow = w->_cury; + ccol = w->_curx; + color = w->color; + + if (w->scroll_max <= nrows) + nrows = w->scroll_max; + + if (crow >= nrows) + crow = 0; /* wrap back to top */ + + b = w->lines [crow] + ccol; + + while (len && ((ch = (unsigned char) *str++) != 0)) + { + len--; + + if (ch == '\n') + { + w->_cury = crow; + w->_curx = ccol; + SLcurses_wclrtoeol (w); + do_newline (w); + crow = w->_cury; + ccol = w->_curx; + b = w->lines[crow]; + continue; + } + + if (ccol >= ncols) + { + ccol = 0; + crow++; + if (crow >= nrows) + { + w->_curx = 0; + w->_cury = crow; + do_newline (w); + crow = w->_cury; + ccol = w->_curx; + } + + b = w->lines [crow]; + } + + if (ch == '\t') + { + unsigned int n = ccol; + n += SLsmg_Tab_Width; + n = SLsmg_Tab_Width - (n % SLsmg_Tab_Width); + if (ccol + n > ncols) n = ncols - len; + ccol += n; + while (n--) + *b++ = SLSMG_BUILD_CHAR(' ',color); + continue; + } + + *b++ = SLSMG_BUILD_CHAR(ch, color); + ccol++; + } + + w->_curx = ccol; + w->_cury = crow; + + return 0; +} + +/* This routine IS NOT CORRECT. It needs to compute the proper overlap + * and copy accordingly. Here, I just assume windows are same size. + */ +#if 0 +int SLcurses_overlay (SLcurses_Window_Type *swin, SLcurses_Window_Type *dwin) +{ + SLsmg_Char_Type *s, *smax, *d, *dmax; + + if ((swin == NULL) || (dwin == NULL)) + return -1; + + s = swin->buf; + smax = swin->bufmax; + d = dwin->buf; + dmax = dwin->bufmax; + + while ((s < smax) && (d < dmax)) + { + SLsmg_Char_Type ch = *s++; + if (SLSMG_EXTRACT_CHAR(ch) != ' ') + *d = ch; + d++; + } + + return -1; /* not implemented */ +} + +#endif + +SLcurses_Window_Type *SLcurses_subwin (SLcurses_Window_Type *orig, + unsigned int nlines, unsigned int ncols, + unsigned int begin_y, unsigned int begin_x) +{ + SLcurses_Window_Type *sw; + int r, c; + unsigned int i; + + if (orig == NULL) + return NULL; + + sw = (SLcurses_Window_Type *) SLmalloc (sizeof (SLcurses_Window_Type)); + if (sw == NULL) + return NULL; + + SLMEMSET ((char *)sw, 0, sizeof (SLcurses_Window_Type)); +#if 1 + r = begin_y - orig->_begy; +#else + r = 1 + ((int)orig->nrows - (int)nlines) / 2; +#endif + if (r < 0) r = 0; + if (r + nlines > orig->nrows) nlines = orig->nrows - r; + + c = ((int)orig->ncols - (int)ncols) / 2; + if (c < 0) c = 0; + if (c + ncols > orig->ncols) ncols = orig->ncols - c; + + sw->scroll_min = 0; + sw->scroll_max = sw->nrows = nlines; + sw->ncols = ncols; + sw->_begy = begin_y; + sw->_begx = begin_x; + sw->_maxx = (begin_x + ncols) - 1; + sw->_maxy = (begin_y + nlines) - 1; + + sw->lines = (SLsmg_Char_Type **) SLmalloc (nlines * sizeof (SLsmg_Char_Type *)); + if (sw->lines == NULL) + { + SLcurses_delwin (sw); + return NULL; + } + + for (i = 0; i < nlines; i++) + { + sw->lines [i] = orig->lines [r + i] + c; + } + + sw->is_subwin = 1; + return sw; +} + +int SLcurses_wclear (SLcurses_Window_Type *w) +{ + unsigned int i; + + if (w != NULL) w->modified = 1; + for (i=0; i < w->nrows; i++) + blank_line (w->lines[i], w->ncols, w->color); + return 0; +} + +int SLcurses_wdelch (SLcurses_Window_Type *w) +{ + SLsmg_Char_Type *p, *p1, *pmax; + + p = w->lines[w->_cury]; + pmax = p + w->ncols; + p += w->_curx; + p1 = p + 1; + + while (p1 < pmax) + { + *p = *p1; + p = p1; + p1++; + } + + if (p < pmax) + *p = SLSMG_BUILD_CHAR(' ',w->color); + + w->modified = 1; + return 0; +} + +int SLcurses_winsch (SLcurses_Window_Type *w, int ch) +{ + SLsmg_Char_Type *p, *p1, *pmax; + + p = w->lines[w->_cury]; + pmax = p + w->ncols; + p += w->_curx; + p1 = pmax - 1; + + while (pmax > p) + { + *pmax = *p1; + pmax = p1; + p1--; + } + + if (p < pmax) + *p = SLSMG_BUILD_CHAR(ch, w->color); + + w->modified = 1; + return 0; +} + +int SLcurses_endwin (void) +{ + SLcurses_Is_Endwin = 1; + SLsmg_suspend_smg (); + SLang_reset_tty (); + return 0; +} + +#if 0 +int SLcurses_mvwscanw (SLcurses_Window_Type *w, unsigned int r, unsigned int c, + char *fmt, ...) +{ +#if HAVE_VFSCANF + int ret; + va_list ap; + + SLcurses_wmove (w, r, c); + SLcurses_wrefresh (w); + + va_start(ap, fmt); + ret = vfscanf (stdin, fmt, ap); + va_end(ap); + return ret; +#else + return 0; +#endif +} + +int SLcurses_wscanw (SLcurses_Window_Type *w, char *fmt, ...) +{ +#if HAVE_VFSCANF + va_list ap; + int ret; + + SLcurses_wrefresh (w); + + va_start(ap, fmt); + ret = vfscanf (stdin, fmt, ap); + va_end(ap); + + return ret; +#else + return 0; +#endif +} + +int SLcurses_scanw (char *fmt, ...) +{ +#ifdef HAVE_VFSCANF + va_list ap; + int ret; + + SLcurses_wrefresh (SLcurses_Stdscr); + + va_start(ap, fmt); + ret = vfscanf (stdin, fmt, ap); + va_end(ap); + + return ret; +#else + return 0; +#endif +} +#endif + +int SLcurses_clearok (SLcurses_Window_Type *w, int bf) +{ + if (bf) + { + SLsmg_cls (); + w->modified = 1; + } + return 0; +} diff --git a/libslang/src/slcurses.h b/libslang/src/slcurses.h new file mode 100644 index 0000000..dd6d674 --- /dev/null +++ b/libslang/src/slcurses.h @@ -0,0 +1,356 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include + +#ifndef SLANG_VERSION +# include +#endif + +/* This is a temporary hack until lynx is fixed to not include this file. */ +#ifndef LYCURSES_H + +typedef struct +{ + unsigned int _begy, _begx, _maxy, _maxx; + unsigned int _curx, _cury; + unsigned int nrows, ncols; + unsigned int scroll_min, scroll_max; + SLsmg_Char_Type **lines; + SLsmg_Char_Type color; + int is_subwin; + SLtt_Char_Type attr; + int delay_off; + int scroll_ok; + int modified; + int has_box; + int use_keypad; +} +SLcurses_Window_Type; + +extern int SLcurses_wclrtobot (SLcurses_Window_Type *); +extern int SLcurses_wscrl (SLcurses_Window_Type *, int); +extern int SLcurses_wrefresh (SLcurses_Window_Type *); +extern int SLcurses_delwin (SLcurses_Window_Type *); +extern int SLcurses_wprintw (SLcurses_Window_Type *, char *, ...); +extern SLcurses_Window_Type *SLcurses_newwin (unsigned int, unsigned int, + unsigned int, unsigned int); + +extern SLcurses_Window_Type *SLcurses_subwin (SLcurses_Window_Type *, + unsigned int, unsigned int, + unsigned int, unsigned int); + +extern int SLcurses_wnoutrefresh (SLcurses_Window_Type *); +extern int SLcurses_wclrtoeol (SLcurses_Window_Type *); + +extern int SLcurses_wmove (SLcurses_Window_Type *, unsigned int, unsigned int); +extern int SLcurses_waddch (SLcurses_Window_Type *, SLtt_Char_Type); +extern int SLcurses_waddnstr (SLcurses_Window_Type *, char *, int); + +#define waddnstr SLcurses_waddnstr +#define waddch SLcurses_waddch +#define waddstr(w,s) waddnstr((w),(s),-1) +#define addstr(x) waddstr(stdscr, (x)) +#define addnstr(s,n) waddnstr(stdscr,(s),(n)) +#define addch(ch) waddch(stdscr,(ch)) + +#define mvwaddnstr(w,y,x,s,n) \ + (-1 == wmove((w),(y),(x)) ? -1 : waddnstr((w),(s),(n))) +#define mvwaddstr(w,y,x,s) \ + (-1 == wmove((w),(y),(x)) ? -1 : waddnstr((w),(s), -1)) +#define mvaddnstr(y,x,s,n) mvwaddnstr(stdscr,(y),(x),(s),(n)) +#define mvaddstr(y,x,s) mvwaddstr(stdscr,(y),(x),(s)) +#define mvwaddch(w,y,x,c) \ + ((-1 == wmove((w),(y),(x))) ? -1 : waddch((w),(c))) +#define mvaddch(y,x,c) mvwaddch(stdscr,(y),(x),(c)) + +extern int SLcurses_wclear (SLcurses_Window_Type *w); +extern int SLcurses_printw (char *, ...); + +#if 0 +/* Why are these functions part of curses??? */ +extern int SLcurses_mvwscanw (SLcurses_Window_Type *, unsigned int, unsigned int, + char *, ...); +extern int SLcurses_wscanw (SLcurses_Window_Type *, char *, ...); +extern int SLcurses_scanw (char *, ...); +#define mvwscanw SLcurses_mvwscanw +#define wscanw SLcurses_wscanw +#define scanw SLcurses_scanw +#endif + +extern SLcurses_Window_Type *SLcurses_Stdscr; +#define WINDOW SLcurses_Window_Type +#define stdscr SLcurses_Stdscr + +#define subwin SLcurses_subwin +#define wclrtobot SLcurses_wclrtobot +#define wscrl SLcurses_wscrl +#define scrl(n) wscrl(stdscr,(n)) +#define scroll(w) wscrl((w),1) +#define wrefresh SLcurses_wrefresh +#define delwin SLcurses_delwin +#define wmove SLcurses_wmove +#define newwin SLcurses_newwin +#define wnoutrefresh SLcurses_wnoutrefresh +#define werase(w) SLcurses_wmove((w),0,0); SLcurses_wclrtobot(w) +#define wclear(w) SLcurses_wmove((w),0,0); SLcurses_wclrtobot(w) +#define wprintw SLcurses_wprintw +#define mvwprintw SLcurses_mvwprintw + +#define winch(w) \ + ((((w)->_cury < (w)->nrows) && ((w)->_curx < (w)->ncols)) \ + ? ((w)->lines[(w)->_cury][(w)->_curx]) : 0) + +#define inch() winch(stdscr) +#define mvwinch(w,x,y) \ + ((-1 != wmove((w),(x),(y))) ? winch(w) : (-1)) +#define doupdate SLsmg_refresh + +#define mvwin(w,a,b) ((w)->_begy = (a), (w)->_begx = (b)) + +extern int SLcurses_mvprintw (int, int, char *, ...); +extern int SLcurses_mvwprintw (SLcurses_Window_Type *, int, int, char *, ...); +extern int SLcurses_has_colors(void); +extern int SLcurses_nil (void); +extern int SLcurses_wgetch (SLcurses_Window_Type *); +extern int SLcurses_getch (void); + +extern int SLcurses_wattrset (SLcurses_Window_Type *, SLtt_Char_Type); +extern int SLcurses_wattron (SLcurses_Window_Type *, SLtt_Char_Type); +extern int SLcurses_wattroff (SLcurses_Window_Type *, SLtt_Char_Type); +#define attrset(x) SLcurses_wattrset(stdscr, (x)) +#define attron(x) SLcurses_wattron(stdscr, (x)) +#define attroff(x) SLcurses_wattroff(stdscr, (x)) +#define wattrset(w, x) SLcurses_wattrset((w), (x)) +#define wattron(w, x) SLcurses_wattron((w), (x)) +#define wattroff(w, x) SLcurses_wattroff((w), (x)) +#define wattr_get(w) ((w)->color << 8) +#define attr_get() wattr_get(stdscr) + +#define COLOR_PAIR(x) ((x) << 8) + +extern int SLcurses_start_color (void); +#define start_color SLcurses_start_color + +#define ERR 0xFFFF +#define wgetch SLcurses_wgetch +#define getch SLcurses_getch + +extern int SLcurses_nodelay (SLcurses_Window_Type *, int); +extern SLcurses_Window_Type *SLcurses_initscr (void); +#define initscr SLcurses_initscr + +extern int SLcurses_cbreak (void); +extern int SLcurses_raw (void); +#define cbreak SLcurses_cbreak +#define crmode SLcurses_cbreak +#define raw SLcurses_raw +#define noraw SLang_reset_tty +#define nocbreak SLang_reset_tty + +#define mvprintw SLcurses_mvprintw +#define has_colors SLcurses_has_colors +#define nodelay SLcurses_nodelay + +#define ungetch SLang_ungetkey + +#define COLS SLtt_Screen_Cols +#define LINES SLtt_Screen_Rows + +#define move(x,y) SLcurses_wmove(stdscr, (x), (y)) +#define wclrtoeol SLcurses_wclrtoeol +#define clrtoeol() SLcurses_wclrtoeol(stdscr) +#define clrtobot() SLcurses_wclrtobot(stdscr) + +#define printw SLcurses_printw +#define mvprintw SLcurses_mvprintw +#define wstandout(w) SLcurses_wattrset((w),A_STANDOUT) +#define wstandend(w) SLcurses_wattrset((w),A_NORMAL) +#define standout() SLcurses_wattrset(stdscr,A_STANDOUT) +#define standend() SLcurses_wattrset(stdscr,A_NORMAL) + +#define refresh() SLcurses_wrefresh(stdscr) +#define clear() SLcurses_wclear(stdscr) +#define erase() werase(stdscr) +#define touchline SLsmg_touch_lines +#define resetterm SLang_reset_tty + +extern int SLcurses_endwin (void); +#define endwin SLcurses_endwin +extern int SLcurses_Is_Endwin; +#define isendwin() SLcurses_Is_Endwin + +#define keypad(w,x) ((w)->use_keypad = (x)) + +#define KEY_MIN SL_KEY_UP +#define KEY_DOWN SL_KEY_DOWN +#define KEY_UP SL_KEY_UP +#define KEY_LEFT SL_KEY_LEFT +#define KEY_RIGHT SL_KEY_RIGHT +#define KEY_A1 SL_KEY_A1 +#define KEY_B1 SL_KEY_B1 +#define KEY_C1 SL_KEY_C1 +#define KEY_A2 SL_KEY_A2 +#define KEY_B2 SL_KEY_B2 +#define KEY_C2 SL_KEY_C2 +#define KEY_A3 SL_KEY_A3 +#define KEY_B3 SL_KEY_B3 +#define KEY_C3 SL_KEY_C3 +#define KEY_REDO SL_KEY_REDO +#define KEY_UNDO SL_KEY_UNDO +#define KEY_BACKSPACE SL_KEY_BACKSPACE +#define KEY_PPAGE SL_KEY_PPAGE +#define KEY_NPAGE SL_KEY_NPAGE +#define KEY_HOME SL_KEY_HOME +#define KEY_END SL_KEY_END +#define KEY_F0 SL_KEY_F0 +#define KEY_F SL_KEY_F +#define KEY_ENTER SL_KEY_ENTER +#define KEY_MAX 0xFFFF + +/* Ugly Hacks that may not work */ +#define flushinp SLcurses_nil +#define winsertln(w) \ + ((w)->scroll_min=(w)->_cury, \ + (w)->scroll_max=(w)->nrows, \ + wscrl((w), -1)) + +extern SLtt_Char_Type SLcurses_Acs_Map [128]; +#define acs_map SLcurses_Acs_Map + +#define ACS_ULCORNER (acs_map[SLSMG_ULCORN_CHAR]) +#define ACS_URCORNER (acs_map[SLSMG_URCORN_CHAR]) +#define ACS_LRCORNER (acs_map[SLSMG_LRCORN_CHAR]) +#define ACS_LLCORNER (acs_map[SLSMG_LLCORN_CHAR]) +#define ACS_TTEE (acs_map[SLSMG_UTEE_CHAR]) +#define ACS_LTEE (acs_map[SLSMG_LTEE_CHAR]) +#define ACS_RTEE (acs_map[SLSMG_RTEE_CHAR]) +#define ACS_BTEE (acs_map[SLSMG_DTEE_CHAR]) +#define ACS_PLUS (acs_map[SLSMG_PLUS_CHAR]) +#define ACS_VLINE (acs_map[SLSMG_VLINE_CHAR]) +#define ACS_HLINE (acs_map[SLSMG_HLINE_CHAR]) +#define ACS_S1 '-' +#define ACS_S9 '-' +#define ACS_DIAMOND '&' +#define ACS_CKBOARD (acs_map[SLSMG_CKBRD_CHAR]) +#define ACS_DEGREE 'o' +#define ACS_PLMINUS '+' +#define ACS_BULLET '*' +#define ACS_LARROW '<' +#define ACS_RARROW '>' +#define ACS_DARROW 'v' +#define ACS_UARROW '^' +#define ACS_BOARD '#' +#define ACS_LANTERN '#' +#define ACS_BLOCK '#' + +#if 1 +#define hline(x,y) SLcurses_nil () +#define vline(x,y) SLcurses_nil () +#endif + +#define A_CHARTEXT 0x00FF +#define A_NORMAL 0 +#define A_BOLD 0x1000 +#define A_REVERSE 0x2000 +#define A_STANDOUT A_REVERSE +#define A_UNDERLINE 0x4000 +#define A_BLINK 0 +#define A_COLOR 0x0700 +#define A_ALTCHARSET 0x8000 +#define A_DIM 0 +#define A_PROTECT 0 +#define A_INVIS 0 + +#define COLOR_BLACK SLSMG_COLOR_BLACK +#define COLOR_RED SLSMG_COLOR_RED +#define COLOR_GREEN SLSMG_COLOR_GREEN +#define COLOR_YELLOW SLSMG_COLOR_BROWN +#define COLOR_BLUE SLSMG_COLOR_BLUE +#define COLOR_MAGENTA SLSMG_COLOR_MAGENTA +#define COLOR_CYAN SLSMG_COLOR_CYAN +#define COLOR_WHITE SLSMG_COLOR_LGRAY + +extern int SLcurses_Num_Colors; +#define COLORS SLcurses_Num_Colors +#define COLOR_PAIRS (SLcurses_Num_Colors*SLcurses_Num_Colors) + +#define init_pair(_x,_f,_b) \ + SLtt_set_color_object((_x), ((_f) == (_b) ? 0x0700 : ((_f) | ((_b) << 8)) << 8)) + +#define scrollok(a,b) ((a)->scroll_ok = (b)) +#define getyx(a,y,x) (y=(a)->_cury, x=(a)->_curx) +#define getmaxyx(a,y,x) (y=(a)->nrows, x=(a)->ncols) +#ifdef napms +# undef napms +#endif +#define napms(x) usleep(1000 * (x)) +typedef SLtt_Char_Type chtype; +#define beep SLtt_beep +#define curs_set(x) SLtt_set_cursor_visibility(x) +#define touchwin(x) SLsmg_touch_lines((x)->_begy, (x)->nrows) +#define flash SLtt_beep + +#define wsetscrreg(w,a,b) ((w)->scroll_min = (a), (w)->scroll_max = (b)) + +#define wtimeout(a,b) (a)->delay_off = ((b >= 0) ? (b) / 100 : -1) +#define timeout(a) wtimeout(stdscr, a) +extern int SLcurses_wdelch (SLcurses_Window_Type *); +#define wdelch SLcurses_wdelch +#define delch() wdelch(stdscr) + +extern int SLcurses_winsch (SLcurses_Window_Type *, int); +#define winsch SLcurses_winsch + +extern int SLcurses_Esc_Delay;/* ESC expire time in milliseconds (ncurses compatible) */ +#define ESCDELAY SLcurses_Esc_Delay + +extern int SLcurses_clearok (SLcurses_Window_Type *, int); +#define clearok SLcurses_clearok + +/* Functions that have not been implemented. */ +#define copywin(w,v,a,b,c,d,e,f,g) SLcurses_nil() +#define wdeleteln(win) SLcurses_nil() +#define resetty SLcurses_nil +#define savetty SLcurses_nil +#define overlay(u,v) SLcurses_nil() + +/* These functions do nothing */ +#define savetty SLcurses_nil +#define nonl SLcurses_nil +#define echo SLcurses_nil +#define noecho SLcurses_nil +#define saveterm SLcurses_nil +#define box(w,y,z) ((w)->has_box = 1, (w)->modified = 1) +#define leaveok(a,b) SLcurses_nil() +#define nl() SLcurses_nil() +#define trace(x) SLcurses_nil() +#define tigetstr(x) NULL + +/* These have no place in C */ +#define TRUE 1 +#define FALSE 0 +#define bool int + +/* Lynx compatability */ +#else + +#define stdscr NULL +#define COLS SLtt_Screen_Cols +#define LINES SLtt_Screen_Rows +#define move SLsmg_gotorc +#define addstr SLsmg_write_string +#define clear SLsmg_cls +#define standout SLsmg_reverse_video +#define standend SLsmg_normal_video +#define clrtoeol SLsmg_erase_eol +#define scrollok(a,b) SLsmg_Newline_Moves = ((b) ? 1 : -1) +#define addch SLsmg_write_char +#define echo() +#define printw SLsmg_printf +#define endwin SLsmg_reset_smg(),SLang_reset_tty + +#endif diff --git a/libslang/src/sldisply.c b/libslang/src/sldisply.c new file mode 100644 index 0000000..9778d98 --- /dev/null +++ b/libslang/src/sldisply.c @@ -0,0 +1,2699 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include +#include + +#if !defined(VMS) || (__VMS_VER >= 70000000) +# include +# ifdef __QNX__ +# include +# endif +# include +#endif + +#ifdef __BEOS__ +/* Prototype for select */ +# include +#endif + +#ifdef HAVE_TERMIOS_H +# include +#endif + +#ifdef VMS +# include +# include +# include +# include +# include +# include +#else +# if !defined(sun) +# include +# endif +#endif + +#ifdef SYSV +# include +# include +# include +# include +#endif + +#if defined (_AIX) && !defined (FD_SET) +# include /* for FD_ISSET, FD_SET, FD_ZERO */ +#endif + +#include + +#if defined(__DECC) && defined(VMS) +/* These get prototypes for write an sleep */ +# include +#endif +#include + +#include "slang.h" +#include "_slang.h" + +/* Colors: These definitions are used for the display. However, the + * application only uses object handles which get mapped to this + * internal representation. The mapping is performed by the Color_Map + * structure below. */ + +#define CHAR_MASK 0x000000FF +#define FG_MASK 0x0000FF00 +#define BG_MASK 0x00FF0000 +#define ATTR_MASK 0x1F000000 +#define BGALL_MASK 0x0FFF0000 + +/* The 0x10000000 bit represents the alternate character set. BGALL_MASK does + * not include this attribute. + */ + +#define GET_FG(color) ((color & FG_MASK) >> 8) +#define GET_BG(color) ((color & BG_MASK) >> 16) +#define MAKE_COLOR(fg, bg) (((fg) | ((bg) << 8)) << 8) + +int SLtt_Screen_Cols; +int SLtt_Screen_Rows; +int SLtt_Term_Cannot_Insert; +int SLtt_Term_Cannot_Scroll; +int SLtt_Use_Ansi_Colors; +int SLtt_Blink_Mode = 1; +int SLtt_Use_Blink_For_ACS = 0; +int SLtt_Newline_Ok = 0; +int SLtt_Has_Alt_Charset = 0; +int SLtt_Force_Keypad_Init = 0; + +void (*_SLtt_color_changed_hook)(void); + +#if SLTT_HAS_NON_BCE_SUPPORT +static int Bce_Color_Offset = 0; +#endif +static int Can_Background_Color_Erase = 1; + +/* -1 means unknown */ +int SLtt_Has_Status_Line = -1; /* hs */ +int SLang_TT_Write_FD = -1; + +static int Automatic_Margins; +/* static int No_Move_In_Standout; */ +static int Worthless_Highlight; +#define HP_GLITCH_CODE +#ifdef HP_GLITCH_CODE +/* This glitch is exclusive to HP term. Basically it means that to clear + * attributes, one has to erase to the end of the line. + */ +static int Has_HP_Glitch; +#endif + +static char *Reset_Color_String; +static int Is_Color_Terminal = 0; + +static int Linux_Console; + +/* It is crucial that JMAX_COLORS must be less than 128 since the high bit + * is used to indicate a character from the ACS (alt char set). The exception + * to this rule is if SLtt_Use_Blink_For_ACS is true. This means that of + * the highbit is set, we interpret that as a blink character. This is + * exploited by DOSemu. + */ +#define JMAX_COLORS 256 +#define JNORMAL_COLOR 0 + +typedef struct +{ + SLtt_Char_Type fgbg; + SLtt_Char_Type mono; + char *custom_esc; +} +Ansi_Color_Type; + +#define RGB1(r, g, b) ((r) | ((g) << 1) | ((b) << 2)) +#define RGB(r, g, b, br, bg, bb) ((RGB1(r, g, b) << 8) | (RGB1(br, bg, bb) << 16)) + +static Ansi_Color_Type Ansi_Color_Map[JMAX_COLORS] = +{ + {RGB(1, 1, 1, 0, 0, 0), 0x00000000, NULL}, /* white/black */ + {RGB(0, 1, 0, 0, 0, 0), SLTT_REV_MASK, NULL}, /* green/black */ + {RGB(1, 0, 1, 0, 0, 0), SLTT_REV_MASK, NULL}, /* magenta/black */ + {RGB(0, 1, 1, 0, 0, 0), SLTT_REV_MASK, NULL}, /* cyan/black */ + {RGB(1, 0, 0, 0, 0, 0), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 0, 0, 1), SLTT_REV_MASK, NULL}, + {RGB(1, 0, 0, 0, 0, 1), SLTT_REV_MASK, NULL}, + {RGB(1, 0, 0, 0, 1, 0), SLTT_REV_MASK, NULL}, + {RGB(0, 0, 1, 1, 0, 0), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 0, 0), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 1, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(1, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(1, 0, 1, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 0, 0, 0, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL} +}; + +/* 0 if least significant bit is blue, not red */ +static int Is_Fg_BGR = 0; +static int Is_Bg_BGR = 0; +#define COLOR_ARG(color, is_bgr) ((is_bgr) ? RGB_to_BGR[(color)&0x7] : (color)) +static SLCONST int RGB_to_BGR[] = +{ + 0, 4, 2, 6, 1, 5, 3, 7 +}; + + +static char *Color_Fg_Str = "\033[3%dm"; +static char *Color_Bg_Str = "\033[4%dm"; +static char *Default_Color_Fg_Str = "\033[39m"; +static char *Default_Color_Bg_Str = "\033[49m"; + +static int Max_Terminfo_Colors = 8; /* termcap Co */ + +char *SLtt_Graphics_Char_Pairs; /* ac termcap string -- def is vt100 */ + +/* 1 if terminal lacks the ability to go into insert mode or into delete + mode. Currently controlled by S-Lang but later perhaps termcap. */ + +static char *UnderLine_Vid_Str; +static char *Blink_Vid_Str; +static char *Bold_Vid_Str; +static char *Ins_Mode_Str; /* = "\033[4h"; */ /* ins mode (im) */ +static char *Eins_Mode_Str; /* = "\033[4l"; */ /* end ins mode (ei) */ +static char *Scroll_R_Str; /* = "\033[%d;%dr"; */ /* scroll region */ +static char *Cls_Str; /* = "\033[2J\033[H"; */ /* cl termcap STR for ansi terminals */ +static char *Rev_Vid_Str; /* = "\033[7m"; */ /* mr,so termcap string */ +static char *Norm_Vid_Str; /* = "\033[m"; */ /* me,se termcap string */ +static char *Del_Eol_Str; /* = "\033[K"; */ /* ce */ +static char *Del_Bol_Str; /* = "\033[1K"; */ /* cb */ +static char *Del_Char_Str; /* = "\033[P"; */ /* dc */ +static char *Del_N_Lines_Str; /* = "\033[%dM"; */ /* DL */ +static char *Add_N_Lines_Str; /* = "\033[%dL"; */ /* AL */ +static char *Rev_Scroll_Str; +static char *Curs_Up_Str; +static char *Curs_F_Str; /* RI termcap string */ +static char *Cursor_Visible_Str; /* ve termcap string */ +static char *Cursor_Invisible_Str; /* vi termcap string */ +#if 0 +static char *Start_Mouse_Rpt_Str; /* Start mouse reporting mode */ +static char *End_Mouse_Rpt_Str; /* End mouse reporting mode */ +#endif +static char *Start_Alt_Chars_Str; /* as */ +static char *End_Alt_Chars_Str; /* ae */ +static char *Enable_Alt_Char_Set; /* eA */ + +static char *Term_Init_Str; +static char *Keypad_Init_Str; +static char *Term_Reset_Str; +static char *Keypad_Reset_Str; + +/* status line functions */ +static char *Disable_Status_line_Str; /* ds */ +static char *Return_From_Status_Line_Str; /* fs */ +static char *Goto_Status_Line_Str; /* ts */ +static int Num_Status_Line_Columns; /* ws */ +/* static int Status_Line_Esc_Ok; */ /* es */ + +/* static int Len_Curs_F_Str = 5; */ + +/* cm string has %i%d since termcap numbers columns from 0 */ +/* char *CURS_POS_STR = "\033[%d;%df"; ansi-- hor and vert pos */ +static char *Curs_Pos_Str; /* = "\033[%i%d;%dH";*/ /* cm termcap string */ + +/* scrolling region */ +static int Scroll_r1 = 0, Scroll_r2 = 23; +static int Cursor_r, Cursor_c; /* 0 based */ + +/* current attributes --- initialized to impossible value */ +static SLtt_Char_Type Current_Fgbg = 0xFFFFFFFFU; + +static int Cursor_Set; /* 1 if cursor position known, 0 + * if not. -1 if only row is known + */ + +#define MAX_OUTPUT_BUFFER_SIZE 4096 + +static unsigned char Output_Buffer[MAX_OUTPUT_BUFFER_SIZE]; +static unsigned char *Output_Bufferp = Output_Buffer; + +unsigned long SLtt_Num_Chars_Output; + +int _SLusleep (unsigned long usecs) +{ +#if !defined(VMS) || (__VMS_VER >= 70000000) + struct timeval tv; + tv.tv_sec = usecs / 1000000; + tv.tv_usec = usecs % 1000000; + return select(0, NULL, NULL, NULL, &tv); +#else + return 0; +#endif +} + +int SLtt_flush_output (void) +{ + int nwrite = 0; + unsigned int total; + int n = (int) (Output_Bufferp - Output_Buffer); + + SLtt_Num_Chars_Output += n; + + total = 0; + while (n > 0) + { + nwrite = write (SLang_TT_Write_FD, (char *) Output_Buffer + total, n); + if (nwrite == -1) + { + nwrite = 0; +#ifdef EAGAIN + if (errno == EAGAIN) + { + _SLusleep (100000); /* 1/10 sec */ + continue; + } +#endif +#ifdef EWOULDBLOCK + if (errno == EWOULDBLOCK) + { + _SLusleep (100000); + continue; + } +#endif +#ifdef EINTR + if (errno == EINTR) continue; +#endif + break; + } + n -= nwrite; + total += nwrite; + } + Output_Bufferp = Output_Buffer; + return n; +} + +int SLtt_Baud_Rate; +static void tt_write(char *str, unsigned int n) +{ + static unsigned long last_time; + static int total; + unsigned long now; + unsigned int ndiff; + + if ((str == NULL) || (n == 0)) return; + total += n; + + while (1) + { + ndiff = MAX_OUTPUT_BUFFER_SIZE - (int) (Output_Bufferp - Output_Buffer); + if (ndiff < n) + { + SLMEMCPY ((char *) Output_Bufferp, (char *) str, ndiff); + Output_Bufferp += ndiff; + SLtt_flush_output (); + n -= ndiff; + str += ndiff; + } + else + { + SLMEMCPY ((char *) Output_Bufferp, str, n); + Output_Bufferp += n; + break; + } + } + + if (((SLtt_Baud_Rate > 150) && (SLtt_Baud_Rate <= 9600)) + && (10 * total > SLtt_Baud_Rate)) + { + total = 0; + if ((now = (unsigned long) time(NULL)) - last_time <= 1) + { + SLtt_flush_output (); + sleep((unsigned) 1); + } + last_time = now; + } +} + +static void tt_write_string (char *str) +{ + if (str != NULL) tt_write(str, strlen(str)); +} + +void SLtt_write_string (char *str) +{ + tt_write_string (str); + Cursor_Set = 0; +} + +void SLtt_putchar (char ch) +{ + SLtt_normal_video (); + if (Cursor_Set == 1) + { + if (ch >= ' ') Cursor_c++; + else if (ch == '\b') Cursor_c--; + else if (ch == '\r') Cursor_c = 0; + else Cursor_Set = 0; + + if ((Cursor_c + 1 == SLtt_Screen_Cols) + && Automatic_Margins) Cursor_Set = 0; + } + + if (Output_Bufferp < Output_Buffer + MAX_OUTPUT_BUFFER_SIZE) + { + *Output_Bufferp++ = (unsigned char) ch; + } + else tt_write (&ch, 1); +} + +static unsigned int tt_sprintf(char *buf, char *fmt, int x, int y) +{ + char *fmt_max; + register unsigned char *b, ch; + int offset; + int z, z1, parse_level; + int zero_pad; + int field_width; + int variables [26]; + int stack [64]; + unsigned int stack_len; + int parms [10]; +#define STACK_POP (stack_len ? stack[--stack_len] : 0) + + if (fmt == NULL) + { + *buf = 0; + return 0; + } + + stack [0] = y; /* pushed for termcap */ + stack [1] = x; + stack_len = 2; + + parms [1] = x; /* p1 */ + parms [2] = y; /* p2 */ + + offset = 0; + zero_pad = 0; + field_width = 0; + + b = (unsigned char *) buf; + fmt_max = fmt + strlen (fmt); + + while (fmt < fmt_max) + { + ch = *fmt++; + + if (ch != '%') + { + *b++ = ch; + continue; + } + + if (fmt == fmt_max) break; + ch = *fmt++; + + switch (ch) + { + default: + *b++ = ch; + break; + + case 'p': + + if (fmt == fmt_max) break; + ch = *fmt++; + if ((ch >= '0') && (ch <= '9')) + stack [stack_len++] = parms [ch - '0']; + break; + + case '\'': /* 'x' */ + if (fmt == fmt_max) break; + stack [stack_len++] = *fmt++; + if (fmt < fmt_max) fmt++; /* skip ' */ + break; + + case '{': /* literal constant, e.g. {30} */ + z = 0; + while ((fmt < fmt_max) && ((ch = *fmt) <= '9') && (ch >= '0')) + { + z = z * 10 + (ch - '0'); + fmt++; + } + stack [stack_len++] = z; + if ((ch == '}') && (fmt < fmt_max)) fmt++; + break; + + case '0': + if (fmt == fmt_max) break; + ch = *fmt; + if ((ch != '2') && (ch != '3')) + break; + zero_pad = 1; + fmt++; + /* drop */ + + case '2': + case '3': + if (fmt == fmt_max) + if (*fmt == 'x') + { + char x_fmt_buf [4]; + char *x_fmt_buf_ptr; + + x_fmt_buf_ptr = x_fmt_buf; + if (zero_pad) *x_fmt_buf_ptr++ = '0'; + *x_fmt_buf_ptr++ = ch; + *x_fmt_buf_ptr++ = 'X'; + *x_fmt_buf_ptr = 0; + + z = STACK_POP; + z += offset; + + sprintf ((char *)b, x_fmt_buf, z); + b += strlen ((char *)b); + zero_pad = 0; + break; + } + + field_width = (ch - '0'); + /* drop */ + + case 'd': + z = STACK_POP; + z += offset; + if (z >= 100) + { + *b++ = z / 100 + '0'; + z = z % 100; + zero_pad = 1; + field_width = 2; + } + else if (zero_pad && (field_width == 3)) + *b++ = '0'; + + if (z >= 10) + { + *b++ = z / 10 + '0'; + z = z % 10; + } + else if (zero_pad && (field_width >= 2)) + *b++ = '0'; + + *b++ = z + '0'; + field_width = zero_pad = 0; + break; + + case 'x': + z = STACK_POP; + z += offset; + sprintf ((char *) b, "%X", z); + b += strlen ((char *)b); + break; + + case 'i': + offset = 1; + break; + + case '+': + /* Handling this depends upon whether or not we are parsing + * terminfo. Terminfo requires the stack so use it as an + * indicator. + */ + if (stack_len > 2) + { + z = STACK_POP; + stack [stack_len - 1] += z; + } + else if (fmt < fmt_max) + { + ch = *fmt++; + if ((unsigned char) ch == 128) ch = 0; + ch = ch + (unsigned char) STACK_POP; + if (ch == '\n') ch++; + *b++ = ch; + } + break; + + /* Binary operators */ + case '-': + case '*': + case '/': + case 'm': + case '&': + case '|': + case '^': + case '=': + case '>': + case '<': + case 'A': + case 'O': + z1 = STACK_POP; + z = STACK_POP; + switch (ch) + { + case '-': z = (z - z1); break; + case '*': z = (z * z1); break; + case '/': z = (z / z1); break; + case 'm': z = (z % z1); break; + case '&': z = (z & z1); break; + case '|': z = (z | z1); break; + case '^': z = (z ^ z1); break; + case '=': z = (z == z1); break; + case '>': z = (z > z1); break; + case '<': z = (z < z1); break; + case 'A': z = (z && z1); break; + case 'O': z = (z || z1); break; + } + stack [stack_len++] = z; + break; + + /* unary */ + case '!': + z = STACK_POP; + stack [stack_len++] = !z; + break; + + case '~': + z = STACK_POP; + stack [stack_len++] = ~z; + break; + + case 'r': /* termcap -- swap parameters */ + z = stack [0]; + stack [0] = stack [1]; + stack [1] = z; + break; + + case '.': /* termcap */ + case 'c': + ch = (unsigned char) STACK_POP; + if (ch == '\n') ch++; + *b++ = ch; + break; + + case 'g': + if (fmt == fmt_max) break; + ch = *fmt++; + if ((ch >= 'a') && (ch <= 'z')) + stack [stack_len++] = variables [ch - 'a']; + break; + + case 'P': + if (fmt == fmt_max) break; + ch = *fmt++; + if ((ch >= 'a') && (ch <= 'z')) + variables [ch - 'a'] = STACK_POP; + break; + + /* If then else parsing. Actually, this is rather easy. The + * key is to notice that 'then' does all the work. 'if' simply + * there to indicate the start of a test and endif indicates + * the end of tests. If 'else' is seen, then skip to + * endif. + */ + case '?': /* if */ + case ';': /* endif */ + break; + + case 't': /* then */ + z = STACK_POP; + if (z != 0) + break; /* good. Continue parsing. */ + + /* z == 0 and test has failed. So, skip past this entire if + * expression to the matching else or matching endif. + */ + /* drop */ + case 'e': /* else */ + + parse_level = 0; + while (fmt < fmt_max) + { + unsigned char ch1; + + ch1 = *fmt++; + if ((ch1 != '%') || (fmt == fmt_max)) + continue; + + ch1 = *fmt++; + + if (ch1 == '?') parse_level++; /* new if */ + else if (ch1 == 'e') + { + if ((ch != 'e') && (parse_level == 0)) + break; + } + else if (ch1 == ';') + { + if (parse_level == 0) + break; + parse_level--; + } + } + break; + } + } + *b = 0; + return (unsigned int) (b - (unsigned char *) buf); +} + +static void tt_printf(char *fmt, int x, int y) +{ + char buf[1024]; + unsigned int n; + if (fmt == NULL) return; + n = tt_sprintf(buf, fmt, x, y); + tt_write(buf, n); +} + +void SLtt_set_scroll_region (int r1, int r2) +{ + Scroll_r1 = r1; + Scroll_r2 = r2; + tt_printf (Scroll_R_Str, Scroll_r1, Scroll_r2); + Cursor_Set = 0; +} + +void SLtt_reset_scroll_region (void) +{ + SLtt_set_scroll_region(0, SLtt_Screen_Rows - 1); +} + +int SLtt_set_cursor_visibility (int show) +{ + if ((Cursor_Visible_Str == NULL) || (Cursor_Invisible_Str == NULL)) + return -1; + + tt_write_string (show ? Cursor_Visible_Str : Cursor_Invisible_Str); + return 0; +} + +/* the goto_rc function moves to row relative to scrolling region */ +void SLtt_goto_rc(int r, int c) +{ + char *s = NULL; + int n; + char buf[6]; + + if ((c < 0) || (r < 0)) + { + Cursor_Set = 0; + return; + } + + /* if (No_Move_In_Standout && Current_Fgbg) SLtt_normal_video (); */ + r += Scroll_r1; + + if ((Cursor_Set > 0) || ((Cursor_Set < 0) && !Automatic_Margins)) + { + n = r - Cursor_r; + if ((n == -1) && (Cursor_Set > 0) && (Cursor_c == c) + && (Curs_Up_Str != NULL)) + { + s = Curs_Up_Str; + } + else if ((n >= 0) && (n <= 4)) + { + if ((n == 0) && (Cursor_Set == 1) + && ((c > 1) || (c == Cursor_c))) + { + if (Cursor_c == c) return; + if (Cursor_c == c + 1) + { + s = buf; + *s++ = '\b'; *s = 0; + s = buf; + } + } + else if (c == 0) + { + s = buf; + if ((Cursor_Set != 1) || (Cursor_c != 0)) *s++ = '\r'; + while (n--) *s++ = '\n'; +#ifdef VMS + /* Need to add this after \n to start a new record. Sheesh. */ + *s++ = '\r'; +#endif + *s = 0; + s = buf; + } + /* Will fail on VMS */ +#ifndef VMS + else if (SLtt_Newline_Ok && (Cursor_Set == 1) && + (Cursor_c >= c) && (c + 3 > Cursor_c)) + { + s = buf; + while (n--) *s++ = '\n'; + n = Cursor_c - c; + while (n--) *s++ = '\b'; + *s = 0; + s = buf; + } +#endif + } + } + if (s != NULL) tt_write_string(s); + else tt_printf(Curs_Pos_Str, r, c); + Cursor_c = c; Cursor_r = r; + Cursor_Set = 1; +} + +void SLtt_begin_insert (void) +{ + tt_write_string(Ins_Mode_Str); +} + +void SLtt_end_insert (void) +{ + tt_write_string(Eins_Mode_Str); +} + +void SLtt_delete_char (void) +{ + SLtt_normal_video (); + tt_write_string(Del_Char_Str); +} + +void SLtt_erase_line (void) +{ + tt_write_string("\r"); + Cursor_Set = 1; Cursor_c = 0; + SLtt_del_eol(); + /* Put the cursor back at the beginning of the line */ + tt_write_string("\r"); + Cursor_Set = 1; Cursor_c = 0; +} + +/* It appears that the Linux console, and most likely others do not + * like scrolling regions that consist of one line. So I have to + * resort to this stupidity to make up for that stupidity. + */ +static void delete_line_in_scroll_region (void) +{ + SLtt_goto_rc (Cursor_r - Scroll_r1, 0); + SLtt_del_eol (); +} + +void SLtt_delete_nlines (int n) +{ + int r1, curs; + char buf[132]; + + if (n <= 0) return; + SLtt_normal_video (); + + if (Scroll_r1 == Scroll_r2) + { + delete_line_in_scroll_region (); + return; + } + + if (Del_N_Lines_Str != NULL) tt_printf(Del_N_Lines_Str,n, 0); + else + /* get a new terminal */ + { + r1 = Scroll_r1; + curs = Cursor_r; + SLtt_set_scroll_region(curs, Scroll_r2); + SLtt_goto_rc(Scroll_r2 - Scroll_r1, 0); + SLMEMSET(buf, '\n', (unsigned int) n); + tt_write(buf, (unsigned int) n); + /* while (n--) tt_putchar('\n'); */ + SLtt_set_scroll_region(r1, Scroll_r2); + SLtt_goto_rc(curs, 0); + } +} + +void SLtt_cls (void) +{ + /* If the terminal is a color terminal but the user wants black and + * white, then make sure that the colors are reset. This appears to be + * necessary. + */ + if ((SLtt_Use_Ansi_Colors == 0) && Is_Color_Terminal) + { + if (Reset_Color_String != NULL) + tt_write_string (Reset_Color_String); + else + tt_write_string ("\033[0m\033[m"); + } + + SLtt_normal_video(); + SLtt_reset_scroll_region (); + tt_write_string(Cls_Str); +} + +void SLtt_reverse_index (int n) +{ + if (!n) return; + + SLtt_normal_video(); + + if (Scroll_r1 == Scroll_r2) + { + delete_line_in_scroll_region (); + return; + } + + if (Add_N_Lines_Str != NULL) tt_printf(Add_N_Lines_Str,n, 0); + else + { + while(n--) tt_write_string(Rev_Scroll_Str); + } +} + +int SLtt_Ignore_Beep = 1; +static char *Visible_Bell_Str; + +void SLtt_beep (void) +{ + if (SLtt_Ignore_Beep & 0x1) SLtt_putchar('\007'); + + if (SLtt_Ignore_Beep & 0x2) + { + if (Visible_Bell_Str != NULL) tt_write_string (Visible_Bell_Str); +#ifdef __linux__ + else if (Linux_Console) + { + tt_write_string ("\033[?5h"); + SLtt_flush_output (); + _SLusleep (50000); + tt_write_string ("\033[?5l"); + } +#endif + } + SLtt_flush_output (); +} + +static void write_string_with_care (char *); + +static void del_eol (void) +{ +#if 0 + int c; +#endif + if ((Del_Eol_Str != NULL) + && (Can_Background_Color_Erase || ((Current_Fgbg & ~0xFF) == 0))) + { + tt_write_string(Del_Eol_Str); + return; + } + +#if 0 + c = Cursor_c; + + /* Avoid writing to the lower right corner. If the terminal does not + * have Del_Eol_Str, then it probably does not have what it takes to play + * games with insert-mode to "push" the desired character into that corner. + */ + if (Cursor_r + 1 < SLtt_Screen_Rows) + c++; + + while (c < SLtt_Screen_Cols) + { + tt_write (" ", 1); + c++; + } + Cursor_c = (SLtt_Screen_Cols-1); +#else + while (Cursor_c < SLtt_Screen_Cols) + { + write_string_with_care (" "); + Cursor_c++; + } + Cursor_c = SLtt_Screen_Cols - 1; + Cursor_Set = 0; +#endif +} + +void SLtt_del_eol (void) +{ + if (Current_Fgbg != 0xFFFFFFFFU) SLtt_normal_video (); + del_eol (); +} + +typedef SLCONST struct +{ + char *name; + SLtt_Char_Type color; +} +Color_Def_Type; + +#define MAX_COLOR_NAMES 17 +static Color_Def_Type Color_Defs [MAX_COLOR_NAMES] = +{ + {"black", SLSMG_COLOR_BLACK}, + {"red", SLSMG_COLOR_RED}, + {"green", SLSMG_COLOR_GREEN}, + {"brown", SLSMG_COLOR_BROWN}, + {"blue", SLSMG_COLOR_BLUE}, + {"magenta", SLSMG_COLOR_MAGENTA}, + {"cyan", SLSMG_COLOR_CYAN}, + {"lightgray", SLSMG_COLOR_LGRAY}, + {"gray", SLSMG_COLOR_GRAY}, + {"brightred", SLSMG_COLOR_BRIGHT_RED}, + {"brightgreen", SLSMG_COLOR_BRIGHT_GREEN}, + {"yellow", SLSMG_COLOR_BRIGHT_BROWN}, + {"brightblue", SLSMG_COLOR_BRIGHT_BLUE}, + {"brightmagenta", SLSMG_COLOR_BRIGHT_CYAN}, + {"brightcyan", SLSMG_COLOR_BRIGHT_MAGENTA}, + {"white", SLSMG_COLOR_BRIGHT_WHITE}, +#define SLSMG_COLOR_DEFAULT 0xFF + {"default", SLSMG_COLOR_DEFAULT} +}; + +void SLtt_set_mono (int obj, char *what, SLtt_Char_Type mask) +{ + (void) what; + if ((obj < 0) || (obj >= JMAX_COLORS)) + { + return; + } + Ansi_Color_Map[obj].mono = mask & ATTR_MASK; +} + +static char *check_color_for_digit_form (char *color) +{ + unsigned int i, ich; + unsigned char *s = (unsigned char *) color; + + i = 0; + while ((ich = (unsigned int) *s) != 0) + { + if ((ich < '0') || (ich > '9')) + return color; + + i = i * 10 + (ich - '0'); + s++; + } + + if (i < MAX_COLOR_NAMES) + color = Color_Defs[i].name; + + return color; +} + +static int get_default_colors (char **fgp, char **bgp) +{ + static char fg_buf[16], bg_buf[16], *bg, *fg; + static int already_parsed; + char *p, *pmax; + + if (already_parsed == -1) + return -1; + + if (already_parsed) + { + *fgp = fg; + *bgp = bg; + return 0; + } + + already_parsed = -1; + + bg = getenv ("COLORFGBG"); + + if (bg == NULL) + { + bg = getenv ("DEFAULT_COLORS"); + if (bg == NULL) + return -1; + } + + p = fg_buf; + pmax = p + (sizeof (fg_buf) - 1); + + while ((*bg != 0) && (*bg != ';')) + { + if (p < pmax) *p++ = *bg; + bg++; + } + *p = 0; + + if (*bg) bg++; + + p = bg_buf; + pmax = p + (sizeof (bg_buf) - 1); + + /* Mark suggested allowing for extra application specific stuff following + * the background color. That is what the check for the semi-colon is for. + */ + while ((*bg != 0) && (*bg != ';')) + { + if (p < pmax) *p++ = *bg; + bg++; + } + *p = 0; + + if (!strcmp (fg_buf, "default") || !strcmp(bg_buf, "default")) + { + *fgp = *bgp = fg = bg = "default"; + } + else + { + *fgp = fg = check_color_for_digit_form (fg_buf); + *bgp = bg = check_color_for_digit_form (bg_buf); + } + already_parsed = 1; + return 0; +} + +static unsigned char FgBg_Stats[JMAX_COLORS]; + +static int Color_0_Modified = 0; + +void SLtt_set_color_object (int obj, SLtt_Char_Type attr) +{ + char *cust_esc; + + if ((obj < 0) || (obj >= JMAX_COLORS)) return; + + cust_esc = Ansi_Color_Map[obj].custom_esc; + if (cust_esc != NULL) + { + SLfree (cust_esc); + FgBg_Stats[(Ansi_Color_Map[obj].fgbg >> 8) & 0x7F] -= 1; + Ansi_Color_Map[obj].custom_esc = NULL; + } + + Ansi_Color_Map[obj].fgbg = attr; + if (obj == 0) Color_0_Modified = 1; + + if (_SLtt_color_changed_hook != NULL) + (*_SLtt_color_changed_hook)(); +} + +SLtt_Char_Type SLtt_get_color_object (int obj) +{ + if ((obj < 0) || (obj >= JMAX_COLORS)) return 0; + return Ansi_Color_Map[obj].fgbg; +} + +void SLtt_add_color_attribute (int obj, SLtt_Char_Type attr) +{ + if ((obj < 0) || (obj >= JMAX_COLORS)) return; + + Ansi_Color_Map[obj].fgbg |= (attr & ATTR_MASK); + if (obj == 0) Color_0_Modified = 1; + if (_SLtt_color_changed_hook != NULL) + (*_SLtt_color_changed_hook)(); +} + +static SLtt_Char_Type fb_to_fgbg (SLtt_Char_Type f, SLtt_Char_Type b) +{ + SLtt_Char_Type attr; + + if (Max_Terminfo_Colors != 8) + { + if (f != SLSMG_COLOR_DEFAULT) f %= Max_Terminfo_Colors; + if (b != SLSMG_COLOR_DEFAULT) b %= Max_Terminfo_Colors; + return ((f << 8) | (b << 16)); + } + + /* Otherwise we have 8 ansi colors. Try to get bright versions + * by using the BOLD and BLINK attributes. + */ + + attr = 0; + + /* Note: If f represents default, it will have the value 0xFF */ + if (f != SLSMG_COLOR_DEFAULT) + { + if (f & 0x8) attr = SLTT_BOLD_MASK; + f &= 0x7; + } + + if (b != SLSMG_COLOR_DEFAULT) + { + if (b & 0x8) attr |= SLTT_BLINK_MASK; + b &= 0x7; + } + + return ((f << 8) | (b << 16) | attr); +} + +/* This looks for colors with name form 'colorN'. If color is of this + * form, N is passed back via parameter list. + */ +static int parse_color_digit_name (char *color, SLtt_Char_Type *f) +{ + unsigned int i; + unsigned char ch; + + if (strncmp (color, "color", 5)) + return -1; + + color += 5; + if (*color == 0) + return -1; + + i = 0; + while (1) + { + unsigned int j; + + ch = (unsigned char) *color++; + if (ch == 0) + break; + if ((ch > '9') || (ch < '0')) + return -1; + + if (i > 0xFFFFFFFFU / 10) + return -1; + j = (i *= 10); + i += (ch - '0'); + if (i < j) + return -1; + } + + *f = (SLtt_Char_Type) i; + return 0; +} + +static int make_color_fgbg (char *fg, char *bg, SLtt_Char_Type *fgbg) +{ + SLtt_Char_Type f = 0xFFFFFFFFU, b = 0xFFFFFFFFU; + char *dfg, *dbg; + unsigned int i; + + if ((fg != NULL) && (*fg == 0)) fg = NULL; + if ((bg != NULL) && (*bg == 0)) bg = NULL; + + if ((fg == NULL) || (bg == NULL)) + { + if (-1 == get_default_colors (&dfg, &dbg)) + return -1; + + if (fg == NULL) fg = dfg; + if (bg == NULL) bg = dbg; + } + + if (-1 == parse_color_digit_name (fg, &f)) + { + for (i = 0; i < MAX_COLOR_NAMES; i++) + { + if (strcmp(fg, Color_Defs[i].name)) continue; + f = Color_Defs[i].color; + break; + } + } + + if (-1 == parse_color_digit_name (bg, &b)) + { + for (i = 0; i < MAX_COLOR_NAMES; i++) + { + if (strcmp(bg, Color_Defs[i].name)) continue; + b = Color_Defs[i].color; + break; + } + } + + if ((f == 0xFFFFFFFFU) || (b == 0xFFFFFFFFU)) + return -1; + + *fgbg = fb_to_fgbg (f, b); + return 0; +} + +void SLtt_set_color (int obj, char *what, char *fg, char *bg) +{ + SLtt_Char_Type fgbg; + + (void) what; + if ((obj < 0) || (obj >= JMAX_COLORS)) + return; + + if (-1 != make_color_fgbg (fg, bg, &fgbg)) + SLtt_set_color_object (obj, fgbg); +} + +void SLtt_set_color_fgbg (int obj, SLtt_Char_Type f, SLtt_Char_Type b) +{ + SLtt_set_color_object (obj, fb_to_fgbg (f, b)); +} + +void SLtt_set_color_esc (int obj, char *esc) +{ + char *cust_esc; + SLtt_Char_Type fgbg = 0; + int i; + + if ((obj < 0) || (obj >= JMAX_COLORS)) + { + return; + } + + cust_esc = Ansi_Color_Map[obj].custom_esc; + if (cust_esc != NULL) + { + SLfree (cust_esc); + FgBg_Stats[(Ansi_Color_Map[obj].fgbg >> 8) & 0x7F] -= 1; + } + + cust_esc = (char *) SLmalloc (strlen(esc) + 1); + if (cust_esc != NULL) strcpy (cust_esc, esc); + + Ansi_Color_Map[obj].custom_esc = cust_esc; + if (cust_esc == NULL) fgbg = 0; + else + { + /* The whole point of this is to generate a unique fgbg */ + for (i = 0; i < JMAX_COLORS; i++) + { + if (FgBg_Stats[i] == 0) fgbg = i; + + if (obj == i) continue; + if ((Ansi_Color_Map[i].custom_esc) == NULL) continue; + if (!strcmp (Ansi_Color_Map[i].custom_esc, cust_esc)) + { + fgbg = (Ansi_Color_Map[i].fgbg >> 8) & 0x7F; + break; + } + } + FgBg_Stats[fgbg] += 1; + } + + fgbg |= 0x80; + Ansi_Color_Map[obj].fgbg = (fgbg | (fgbg << 8)) << 8; + if (obj == 0) Color_0_Modified = 1; + if (_SLtt_color_changed_hook != NULL) + (*_SLtt_color_changed_hook)(); +} + +void SLtt_set_alt_char_set (int i) +{ + static int last_i; + if (SLtt_Has_Alt_Charset == 0) return; + + i = (i != 0); + + if (i == last_i) return; + tt_write_string (i ? Start_Alt_Chars_Str : End_Alt_Chars_Str ); + last_i = i; +} + +static void write_attributes (SLtt_Char_Type fgbg) +{ + int bg0, fg0; + int unknown_attributes; + + if (Worthless_Highlight) return; + if (fgbg == Current_Fgbg) return; + + unknown_attributes = 0; + + /* Before spitting out colors, fix attributes */ + if ((fgbg & ATTR_MASK) != (Current_Fgbg & ATTR_MASK)) + { + if (Current_Fgbg & ATTR_MASK) + { + tt_write_string(Norm_Vid_Str); + /* In case normal video turns off ALL attributes: */ + if (fgbg & SLTT_ALTC_MASK) + Current_Fgbg &= ~SLTT_ALTC_MASK; + SLtt_set_alt_char_set (0); + } + + if ((fgbg & SLTT_ALTC_MASK) + != (Current_Fgbg & SLTT_ALTC_MASK)) + { + SLtt_set_alt_char_set ((int) (fgbg & SLTT_ALTC_MASK)); + } + + if (fgbg & SLTT_ULINE_MASK) tt_write_string (UnderLine_Vid_Str); + if (fgbg & SLTT_BOLD_MASK) SLtt_bold_video (); + if (fgbg & SLTT_REV_MASK) tt_write_string (Rev_Vid_Str); + if (fgbg & SLTT_BLINK_MASK) + { + /* Someday Linux will have a blink mode that set high intensity + * background. Lets be prepared. + */ + if (SLtt_Blink_Mode) tt_write_string (Blink_Vid_Str); + } + unknown_attributes = 1; + } + + if (SLtt_Use_Ansi_Colors) + { + fg0 = (int) GET_FG(fgbg); + bg0 = (int) GET_BG(fgbg); + + if (unknown_attributes + || (fg0 != (int)GET_FG(Current_Fgbg))) + { + if (fg0 == SLSMG_COLOR_DEFAULT) + tt_write_string (Default_Color_Fg_Str); + else + tt_printf (Color_Fg_Str, COLOR_ARG(fg0, Is_Bg_BGR), 0); + } + + if (unknown_attributes + || (bg0 != (int)GET_BG(Current_Fgbg))) + { + if (bg0 == SLSMG_COLOR_DEFAULT) + tt_write_string (Default_Color_Bg_Str); + else + tt_printf (Color_Bg_Str, COLOR_ARG(bg0, Is_Bg_BGR), 0); + } + } + + Current_Fgbg = fgbg; +} + +static int Video_Initialized; + +void SLtt_reverse_video (int color) +{ + SLtt_Char_Type fgbg; + char *esc; + + if (Worthless_Highlight) return; + if ((color < 0) || (color >= JMAX_COLORS)) return; + + if (Video_Initialized == 0) + { + if (color == JNORMAL_COLOR) + { + tt_write_string (Norm_Vid_Str); + } + else tt_write_string (Rev_Vid_Str); + Current_Fgbg = 0xFFFFFFFFU; + return; + } + + if (SLtt_Use_Ansi_Colors) + { + fgbg = Ansi_Color_Map[color].fgbg; + if ((esc = Ansi_Color_Map[color].custom_esc) != NULL) + { + if (fgbg != Current_Fgbg) + { + Current_Fgbg = fgbg; + tt_write_string (esc); + return; + } + } + } + else fgbg = Ansi_Color_Map[color].mono; + + if (fgbg == Current_Fgbg) return; + write_attributes (fgbg); +} + +void SLtt_normal_video (void) +{ + SLtt_reverse_video(JNORMAL_COLOR); +} + +void SLtt_narrow_width (void) +{ + tt_write_string("\033[?3l"); +} + +void SLtt_wide_width (void) +{ + tt_write_string("\033[?3h"); +} + +/* Highest bit represents the character set. */ +#define COLOR_MASK 0x7F00 +#define COLOR_OF(x) (((x)&COLOR_MASK)>>8) +#define CHAR_OF(x) ((x)&0x80FF) + +#if SLTT_HAS_NON_BCE_SUPPORT +static int bce_color_eqs (unsigned int a, unsigned int b) +{ + a = COLOR_OF(a); + b = COLOR_OF(b); + + if (a == b) + return 1; + + if (SLtt_Use_Ansi_Colors == 0) + return Ansi_Color_Map[a].mono == Ansi_Color_Map[b].mono; + + if (Bce_Color_Offset == 0) + return Ansi_Color_Map[a].fgbg == Ansi_Color_Map[b].fgbg; + + /* If either are color 0, then we do not know what that means since the + * terminal does not support BCE */ + if ((a == 0) || (b == 0)) + return 0; + + return Ansi_Color_Map[a-1].fgbg == Ansi_Color_Map[b-1].fgbg; +} +#define COLOR_EQS(a,b) bce_color_eqs (a,b) +#else +# define COLOR_EQS(a, b) \ + (SLtt_Use_Ansi_Colors \ + ? (Ansi_Color_Map[COLOR_OF(a)].fgbg == Ansi_Color_Map[COLOR_OF(b)].fgbg)\ + : (Ansi_Color_Map[COLOR_OF(a)].mono == Ansi_Color_Map[COLOR_OF(b)].mono)) +#endif + +#define CHAR_EQS(a, b) (((a) == (b))\ + || ((CHAR_OF(a)==CHAR_OF(b)) && COLOR_EQS(a,b))) + +/* The whole point of this routine is to prevent writing to the last column + * and last row on terminals with automatic margins. + */ +static void write_string_with_care (char *str) +{ + unsigned int len; + + if (str == NULL) return; + + len = strlen (str); + if (Automatic_Margins && (Cursor_r + 1 == SLtt_Screen_Rows)) + { + if (len + (unsigned int) Cursor_c >= (unsigned int) SLtt_Screen_Cols) + { + /* For now, just do not write there. Later, something more + * sophisticated will be implemented. + */ + if (SLtt_Screen_Cols > Cursor_c) + len = SLtt_Screen_Cols - Cursor_c - 1; + else + len = 0; + } + } + tt_write (str, len); +} + +static void send_attr_str (SLsmg_Char_Type *s) +{ + unsigned char out[SLTT_MAX_SCREEN_COLS], ch, *p; + register SLtt_Char_Type attr; + register SLsmg_Char_Type sh; + int color, last_color = -1; + + p = out; + while (0 != (sh = *s++)) + { + ch = sh & 0xFF; + color = ((int) sh & 0xFF00) >> 8; + +#if SLTT_HAS_NON_BCE_SUPPORT + if (Bce_Color_Offset + && (color >= Bce_Color_Offset)) + color -= Bce_Color_Offset; +#endif + + if (color != last_color) + { + if (SLtt_Use_Ansi_Colors) attr = Ansi_Color_Map[color & 0x7F].fgbg; + else attr = Ansi_Color_Map[color & 0x7F].mono; + + if (sh & 0x8000) /* alternate char set */ + { + if (SLtt_Use_Blink_For_ACS) + { + if (SLtt_Blink_Mode) attr |= SLTT_BLINK_MASK; + } + else attr |= SLTT_ALTC_MASK; + } + + if (attr != Current_Fgbg) + { + if ((ch != ' ') || + /* it is a space so only consider it different if it + * has different attributes. + */ + (attr != Current_Fgbg)) + /* The previous line was: */ + /* (attr & BGALL_MASK) != (Current_Fgbg & BGALL_MASK)) */ + /* However, it does not account for ACS */ + { + if (p != out) + { + *p = 0; + write_string_with_care ((char *) out); + Cursor_c += (int) (p - out); + p = out; + } + + if (SLtt_Use_Ansi_Colors && (NULL != Ansi_Color_Map[color & 0x7F].custom_esc)) + { + tt_write_string (Ansi_Color_Map[color & 0x7F].custom_esc); + /* Just in case the custom escape sequence screwed up + * the alt character set state... + */ + if ((attr & SLTT_ALTC_MASK) != (Current_Fgbg & SLTT_ALTC_MASK)) + SLtt_set_alt_char_set ((int) (attr & SLTT_ALTC_MASK)); + Current_Fgbg = attr; + } + else write_attributes (attr); + + last_color = color; + } + } + } + *p++ = ch; + } + *p = 0; + if (p != out) write_string_with_care ((char *) out); + Cursor_c += (int) (p - out); +} + +static void forward_cursor (unsigned int n, int row) +{ + char buf [1024]; + + + /* if (Current_Fgbg & ~0xFF) */ + /* { */ + /* unsigned int num = 0; */ + /* while (num < n) */ + /* { */ + /* write_string_with_care (" "); */ + /* num++; */ + /* } */ + /* Cursor_c += n; */ + /* return; */ + /* } */ + + + if (n <= 4) + { + SLtt_normal_video (); + if (n >= sizeof (buf)) + n = sizeof (buf) - 1; + SLMEMSET (buf, ' ', n); + buf[n] = 0; + write_string_with_care (buf); + Cursor_c += n; + } + else if (Curs_F_Str != NULL) + { + Cursor_c += n; + n = tt_sprintf(buf, Curs_F_Str, (int) n, 0); + tt_write(buf, n); + } + else SLtt_goto_rc (row, (int) (Cursor_c + n)); +} + + +/* FIXME!! If the terminal does not support color, then this route has + * problems of color object 0 has been assigned some monochrome attribute + * such as reverse video. In such a case, space_char=' ' is not a simple + * space character as is assumed below. + */ + +void SLtt_smart_puts(SLsmg_Char_Type *neww, SLsmg_Char_Type *oldd, int len, int row) +{ + register SLsmg_Char_Type *p, *q, *qmax, *pmax, *buf; + SLsmg_Char_Type buffer[SLTT_MAX_SCREEN_COLS+1]; + unsigned int n_spaces; + SLsmg_Char_Type *space_match, *last_buffered_match; +#ifdef HP_GLITCH_CODE + int handle_hp_glitch = 0; +#endif + SLsmg_Char_Type space_char; +#define SLTT_USE_INSERT_HACK 1 +#if SLTT_USE_INSERT_HACK + SLsmg_Char_Type insert_hack_prev = 0; + SLsmg_Char_Type insert_hack_char = 0; + + if ((row + 1 == SLtt_Screen_Rows) + && (len == SLtt_Screen_Cols) + && (len > 1) + && (SLtt_Term_Cannot_Insert == 0) + && Automatic_Margins) + { + insert_hack_char = neww[len-1]; + if (oldd[len-1] == insert_hack_char) + insert_hack_char = 0; + else + insert_hack_prev = neww[len-2]; + } +#endif + + if (len > SLTT_MAX_SCREEN_COLS) + len = SLTT_MAX_SCREEN_COLS; + + q = oldd; p = neww; + qmax = oldd + len; + pmax = p + len; + + /* Find out where to begin --- while they match, we are ok */ + while (1) + { + if (q == qmax) return; +#if SLANG_HAS_KANJI_SUPPORT + if (*p & 0x80) + { /* new is kanji */ + if ((*q & 0x80) && ((q + 1) < qmax)) + { /* old is also kanji */ + if (((0xFF & *q) != (0xFF & *p)) + || ((0xFF & q[1]) != (0xFF & p[1]))) + break; /* both kanji, but not match */ + + else + { /* kanji match ! */ + if (!COLOR_EQS(*q, *p)) break; + q++; p++; + if (!COLOR_EQS(*q, *p)) break; + /* really match! */ + q++; p++; + continue; + } + } + else break; /* old is not kanji */ + } + else + { /* new is not kanji */ + if (*q & 0x80) break; /* old is kanji */ + } +#endif + if (!CHAR_EQS(*q, *p)) break; + q++; p++; + } + +#ifdef HP_GLITCH_CODE + if (Has_HP_Glitch) + { + SLsmg_Char_Type *qq = q; + + SLtt_goto_rc (row, (int) (p - neww)); + + while (qq < qmax) + { + if (*qq & 0xFF00) + { + SLtt_normal_video (); + SLtt_del_eol (); + qmax = q; + handle_hp_glitch = 1; + break; + } + qq++; + } + } +#endif + /* Find where the last non-blank character on old/new screen is */ + + space_char = ' '; + if (CHAR_EQS(*(pmax-1), ' ')) + { + /* If we get here, then we can erase to the end of the line to create + * the final space. However, this will only work _if_ erasing will + * get us the correct color. If the terminal supports BCE, then this + * is easy. If it does not, then we can only perform this operation + * if the color is known via something like COLORFGBG. For now, + * I just will not perform the optimization for such terminals. + */ + if ((Can_Background_Color_Erase) + && SLtt_Use_Ansi_Colors) + space_char = *(pmax - 1); + + while (pmax > p) + { + pmax--; + if (!CHAR_EQS(*pmax, space_char)) + { + pmax++; + break; + } + } + } + + while (qmax > q) + { + qmax--; + if (!CHAR_EQS(*qmax, space_char)) + { + qmax++; + break; + } + } + + last_buffered_match = buf = buffer; /* buffer is empty */ + +#ifdef HP_GLITCH_CODE + if (handle_hp_glitch) + { + while (p < pmax) + { + *buf++ = *p++; + } + } +#endif + +#ifdef HP_GLITCH_CODE + if (Has_HP_Glitch == 0) + { +#endif + /* Try use use erase to bol if possible */ + if ((Del_Bol_Str != NULL) && (CHAR_OF(*neww) == ' ')) + { + SLsmg_Char_Type *p1; + SLsmg_Char_Type blank; + + p1 = neww; + if ((Can_Background_Color_Erase) + && SLtt_Use_Ansi_Colors) + blank = *p1; + /* black+white attributes do not support bce */ + else + blank = ' '; + + while ((p1 < pmax) && (CHAR_EQS (*p1, blank))) + p1++; + + /* Is this optimization worth it? Assume Del_Bol_Str is ESC [ 1 K + * It costs 4 chars + the space needed to properly position the + * cursor, e.g., ESC [ 10;10H. So, it costs at least 13 characters. + */ + if ((p1 > neww + 13) + && (p1 >= p) + /* Avoid erasing from the end of the line */ + && ((p1 != pmax) || (pmax < neww + len))) + { + int ofs = (int) (p1 - neww); + q = oldd + ofs; + p = p1; + SLtt_goto_rc (row, ofs - 1); + SLtt_reverse_video (COLOR_OF(blank)); + tt_write_string (Del_Bol_Str); + tt_write (" ", 1); + Cursor_c += 1; + } + else + SLtt_goto_rc (row, (int) (p - neww)); + } + else + SLtt_goto_rc (row, (int) (p - neww)); +#ifdef HP_GLITCH_CODE + } +#endif + + + /* loop using overwrite then skip algorithm until done */ + while (1) + { + /* while they do not match and we do not hit a space, buffer them up */ + n_spaces = 0; + while (p < pmax) + { + if (CHAR_EQS(*q, ' ') && CHAR_EQS(*p, ' ')) + { + /* If *q is not a space, we would have to overwrite it. + * However, if *q is a space, then while *p is also one, + * we only need to skip over the blank field. + */ + space_match = p; + p++; q++; + while ((p < pmax) + && CHAR_EQS(*q, ' ') + && CHAR_EQS(*p, ' ')) + { + p++; + q++; + } + n_spaces = (unsigned int) (p - space_match); + break; + } +#if SLANG_HAS_KANJI_SUPPORT + if ((*p & 0x80) && ((p + 1) < pmax)) + { /* new is kanji */ + if (*q & 0x80) + { /* old is also kanji */ + if (((0xFF & *q) != (0xFF & *p)) + || ((0xFF & q[1]) != (0xFF & p[1]))) + { + /* both kanji, but not match */ + *buf++ = *p++; + *buf++ = *p++; + q += 2; + continue; + } + else + { /* kanji match ? */ + if (!COLOR_EQS(*q, *p) || !COLOR_EQS(*(q+1), *(p+1))) + { + /* code is match, but color is diff */ + *buf++ = *p++; + *buf++ = *p++; + q += 2; + continue; + } + /* really match ! */ + break; + } + } + else + { /* old is not kanji */ + *buf++ = *p++; + *buf++ = *p++; + q += 2; + continue; + } + } + else + { /* new is not kanji */ + if (*q & 0x80) + { /* old is kanji */ + *buf++ = *p++; + q++; + continue; + } + } +#endif + + if (CHAR_EQS(*q, *p)) break; + *buf++ = *p++; + q++; + } + *buf = 0; + + /* At this point, the buffer contains characters that do not match */ + if (buf != buffer) send_attr_str (buffer); + buf = buffer; + + if (n_spaces + && ((p < pmax) /* erase to eol will achieve this effect*/ + || (space_char != ' ')))/* unless space_char is not a simple space */ + { + forward_cursor (n_spaces, row); + } + /* Now we overwrote what we could and cursor is placed at position + * of a possible match of new and old. If this is the case, skip + * some more. + */ + + /* Note that from here on, the buffer will contain matched characters */ +#if !SLANG_HAS_KANJI_SUPPORT + while ((p < pmax) && CHAR_EQS(*p, *q)) + { + *buf++ = *p++; + q++; + } +#else + /* Kanji */ + while (p < pmax) + { + if ((*p & 0x80) && ((p + 1) < pmax)) + { /* new is kanji */ + if (*q & 0x80) + { /* old is also kanji */ + if (((0xFF & *q) == (0xFF & *p)) + && ((0xFF & q[1]) == (0xFF & p[1]))) + { + /* kanji match ? */ + if (!COLOR_EQS(*q, *p) + || !COLOR_EQS(q[1], p[1])) + break; + + *buf++ = *p++; + q++; + if (p >= pmax) + { + *buf++ = 32; + p++; + break; + } + else + { + *buf++ = *p++; + q++; + continue; + } + } + else break; /* both kanji, but not match */ + } + else break; /* old is not kanji */ + } + else + { /* new is not kanji */ + if (*q & 0x80) break; /* old is kanji */ + if (!CHAR_EQS(*q, *p)) break; + *buf++ = *p++; + q++; + } + } +#endif + last_buffered_match = buf; + if (p >= pmax) break; + + /* jump to new position is it is greater than 5 otherwise + * let it sit in the buffer and output it later. + */ + if ((int) (buf - buffer) >= 5) + { + forward_cursor ((unsigned int) (buf - buffer), row); + last_buffered_match = buf = buffer; + } + } + + /* At this point we have reached the end of the new string with the + * exception of space_chars hanging off the end of it, but we may not have + * reached the end of the old string if they did not match. + */ + + /* Here the buffer will consist only of characters that have matched */ + if (buf != buffer) + { + if (q < qmax) + { + if ((buf == last_buffered_match) + && ((int) (buf - buffer) >= 5)) + { + forward_cursor ((unsigned int) (buf - buffer), row); + } + else + { + *buf = 0; + send_attr_str (buffer); + } + } + } + + if (q < qmax) + { + SLtt_reverse_video (COLOR_OF(space_char)); + del_eol (); + } + +#if SLTT_USE_INSERT_HACK + else if (insert_hack_char) + { + SLtt_goto_rc (SLtt_Screen_Rows-1, SLtt_Screen_Cols-2); + buffer[0] = insert_hack_char; + buffer[1] = 0; + send_attr_str (buffer); + SLtt_goto_rc (SLtt_Screen_Rows-1, SLtt_Screen_Cols-2); + buffer[0] = insert_hack_prev; + SLtt_begin_insert (); + send_attr_str (buffer); + SLtt_end_insert (); + } +#endif + + if (Automatic_Margins && (Cursor_c + 1 >= SLtt_Screen_Cols)) Cursor_Set = 0; +} + +static void get_color_info (void) +{ + char *fg, *bg; + + /* Allow easy mechanism to override inadequate termcap/terminfo files. */ + if (SLtt_Use_Ansi_Colors == 0) + SLtt_Use_Ansi_Colors = (NULL != getenv ("COLORTERM")); + + if (SLtt_Use_Ansi_Colors) + Is_Color_Terminal = 1; + +#if SLTT_HAS_NON_BCE_SUPPORT + if (Can_Background_Color_Erase == 0) + Can_Background_Color_Erase = (NULL != getenv ("COLORTERM_BCE")); +#endif + + if (-1 == get_default_colors (&fg, &bg)) + return; + + /* Check to see if application has already set them. */ + if (Color_0_Modified) + return; + + SLtt_set_color (0, NULL, fg, bg); + SLtt_set_color (1, NULL, bg, fg); +} + +/* termcap stuff */ + +#ifdef __unix__ + +static int Termcap_Initalized = 0; + +#ifdef USE_TERMCAP +/* Termcap based system */ +static char Termcap_Buf[4096]; +static char Termcap_String_Buf[4096]; +static char *Termcap_String_Ptr; +extern char *tgetstr(char *, char **); +extern int tgetent(char *, char *); +extern int tgetnum(char *); +extern int tgetflag(char *); +#else +/* Terminfo */ +static SLterminfo_Type *Terminfo; +#endif + +#define TGETFLAG(x) (SLtt_tgetflag(x) > 0) + +static char *fixup_tgetstr (char *what) +{ + register char *w, *w1; + char *wsave; + + if (what == NULL) + return NULL; + + /* Check for AIX brain-damage */ + if (*what == '@') + return NULL; + + /* lose pad info --- with today's technology, term is a loser if + it is really needed */ + while ((*what == '.') || + ((*what >= '0') && (*what <= '9'))) what++; + if (*what == '*') what++; + + /* lose terminfo padding--- looks like $<...> */ + w = what; + while (*w) if ((*w++ == '$') && (*w == '<')) + { + w1 = w - 1; + while (*w && (*w != '>')) w++; + if (*w == 0) break; + w++; + wsave = w1; + while ((*w1++ = *w++) != 0); + w = wsave; + } + + if (*what == 0) what = NULL; + return what; +} + +char *SLtt_tgetstr (char *cap) +{ + char *s; + + if (Termcap_Initalized == 0) + return NULL; + +#ifdef USE_TERMCAP + s = tgetstr (cap, &Termcap_String_Ptr); +#else + s = _SLtt_tigetstr (Terminfo, cap); +#endif + + /* Do not strip pad info for alternate character set. I need to make + * this more general. + */ + /* FIXME: Priority=low; */ + if (0 == strcmp (cap, "ac")) + return s; + + return fixup_tgetstr (s); +} + +int SLtt_tgetnum (char *s) +{ + if (Termcap_Initalized == 0) + return -1; +#ifdef USE_TERMCAP + return tgetnum (s); +#else + return _SLtt_tigetnum (Terminfo, s); +#endif +} + +int SLtt_tgetflag (char *s) +{ + if (Termcap_Initalized == 0) + return -1; +#ifdef USE_TERMCAP + return tgetflag (s); +#else + return _SLtt_tigetflag (Terminfo, s); +#endif +} + +static int Vt100_Like = 0; + +void SLtt_get_terminfo (void) +{ + char *term; + int status; + + term = getenv ("TERM"); + if (term == NULL) + SLang_exit_error("TERM environment variable needs set."); + + if (0 == (status = SLtt_initialize (term))) + return; + + if (status == -1) + { + SLang_exit_error ("Unknown terminal: %s\n\ +Check the TERM environment variable.\n\ +Also make sure that the terminal is defined in the terminfo database.\n\ +Alternatively, set the TERMCAP environment variable to the desired\n\ +termcap entry.", + term); + } + + if (status == -2) + { + SLang_exit_error ("\ +Your terminal lacks the ability to clear the screen or position the cursor.\n"); + } +} + +/* Returns 0 if all goes well, -1 if terminal capabilities cannot be deduced, + * or -2 if terminal cannot position the cursor. + */ +int SLtt_initialize (char *term) +{ + char *t, ch; + int is_xterm; + int almost_vtxxx; + + if (SLang_TT_Write_FD == -1) + { + /* Apparantly, this cannot fail according to the man pages. */ + SLang_TT_Write_FD = fileno (stdout); + } + + if (term == NULL) + { + term = getenv ("TERM"); + if (term == NULL) + return -1; + } + + if (_SLsecure_issetugid () + && ((term[0] == '.') || (NULL != strchr(term, '/')))) + return -1; + + Linux_Console = (!strncmp (term, "linux", 5) +# ifdef linux + || !strncmp(term, "con", 3) +# endif + ); + + t = term; + + if (strcmp(t, "vt52") && (*t++ == 'v') && (*t++ == 't') + && (ch = *t, (ch >= '1') && (ch <= '9'))) Vt100_Like = 1; + + is_xterm = ((0 == strncmp (term, "xterm", 5)) + || (0 == strncmp (term, "rxvt", 4)) + || (0 == strncmp (term, "Eterm", 5))); + + almost_vtxxx = (Vt100_Like + || Linux_Console + || is_xterm + || !strcmp (term, "screen")); + +# ifndef USE_TERMCAP + if (NULL == (Terminfo = _SLtt_tigetent (term))) + { + if (almost_vtxxx) /* Special cases. */ + { + int vt102 = 1; + if (!strcmp (term, "vt100")) vt102 = 0; + get_color_info (); + SLtt_set_term_vtxxx (&vt102); + (void) SLtt_get_screen_size (); + return 0; + } + return -1; + } +# else /* USE_TERMCAP */ + if (1 != tgetent(Termcap_Buf, term)) + return -1; + Termcap_String_Ptr = Termcap_String_Buf; +# endif /* NOT USE_TERMCAP */ + + Termcap_Initalized = 1; + + Cls_Str = SLtt_tgetstr ("cl"); + Curs_Pos_Str = SLtt_tgetstr ("cm"); + + if ((NULL == (Ins_Mode_Str = SLtt_tgetstr("im"))) + || ( NULL == (Eins_Mode_Str = SLtt_tgetstr("ei"))) + || ( NULL == (Del_Char_Str = SLtt_tgetstr("dc")))) + SLtt_Term_Cannot_Insert = 1; + + Visible_Bell_Str = SLtt_tgetstr ("vb"); + Curs_Up_Str = SLtt_tgetstr ("up"); + Rev_Scroll_Str = SLtt_tgetstr("sr"); + Del_N_Lines_Str = SLtt_tgetstr("DL"); + Add_N_Lines_Str = SLtt_tgetstr("AL"); + + /* Actually these are used to initialize terminals that use cursor + * addressing. Hard to believe. + */ + Term_Init_Str = SLtt_tgetstr ("ti"); + Term_Reset_Str = SLtt_tgetstr ("te"); + + /* If I do this for vtxxx terminals, arrow keys start sending ESC O A, + * which I do not want. This is mainly for HP terminals. + */ + if ((almost_vtxxx == 0) || SLtt_Force_Keypad_Init) + { + Keypad_Init_Str = SLtt_tgetstr ("ks"); + Keypad_Reset_Str = SLtt_tgetstr ("ke"); + } + + /* Make up for defective termcap/terminfo databases */ + if ((Vt100_Like && (term[2] != '1')) + || Linux_Console + || is_xterm + ) + { + if (Del_N_Lines_Str == NULL) Del_N_Lines_Str = "\033[%dM"; + if (Add_N_Lines_Str == NULL) Add_N_Lines_Str = "\033[%dL"; + } + + Scroll_R_Str = SLtt_tgetstr("cs"); + + SLtt_get_screen_size (); + + if ((Scroll_R_Str == NULL) + || (((NULL == Del_N_Lines_Str) || (NULL == Add_N_Lines_Str)) + && (NULL == Rev_Scroll_Str))) + { + if (is_xterm + || Linux_Console + ) + { + /* Defective termcap mode!!!! */ + SLtt_set_term_vtxxx (NULL); + } + else SLtt_Term_Cannot_Scroll = 1; + } + + Del_Eol_Str = SLtt_tgetstr("ce"); + Del_Bol_Str = SLtt_tgetstr("cb"); + if (is_xterm && (Del_Bol_Str == NULL)) + Del_Bol_Str = "\033[1K"; + if (is_xterm && (Del_Eol_Str == NULL)) + Del_Eol_Str = "\033[K"; + + Rev_Vid_Str = SLtt_tgetstr("mr"); + if (Rev_Vid_Str == NULL) Rev_Vid_Str = SLtt_tgetstr("so"); + + Bold_Vid_Str = SLtt_tgetstr("md"); + + /* Although xterm cannot blink, it does display the blinking characters + * as bold ones. Some Rxvt will display the background as high intensity. + */ + if ((NULL == (Blink_Vid_Str = SLtt_tgetstr("mb"))) + && is_xterm) + Blink_Vid_Str = "\033[5m"; + + UnderLine_Vid_Str = SLtt_tgetstr("us"); + + Start_Alt_Chars_Str = SLtt_tgetstr ("as"); /* smacs */ + End_Alt_Chars_Str = SLtt_tgetstr ("ae"); /* rmacs */ + Enable_Alt_Char_Set = SLtt_tgetstr ("eA"); /* enacs */ + SLtt_Graphics_Char_Pairs = SLtt_tgetstr ("ac"); + + if (NULL == SLtt_Graphics_Char_Pairs) + { + /* make up for defective termcap/terminfo */ + if (Vt100_Like) + { + Start_Alt_Chars_Str = "\016"; + End_Alt_Chars_Str = "\017"; + Enable_Alt_Char_Set = "\033)0"; + } + } + + /* aixterm added by willi */ + if (is_xterm || !strncmp (term, "aixterm", 7)) + { + Start_Alt_Chars_Str = "\016"; + End_Alt_Chars_Str = "\017"; + Enable_Alt_Char_Set = "\033(B\033)0"; + } + + if ((SLtt_Graphics_Char_Pairs == NULL) && + ((Start_Alt_Chars_Str == NULL) || (End_Alt_Chars_Str == NULL))) + { + SLtt_Has_Alt_Charset = 0; + Enable_Alt_Char_Set = NULL; + } + else SLtt_Has_Alt_Charset = 1; + +#ifdef AMIGA + Enable_Alt_Char_Set = Start_Alt_Chars_Str = End_Alt_Chars_Str = NULL; +#endif + + /* status line capabilities */ + if ((SLtt_Has_Status_Line == -1) + && (0 != (SLtt_Has_Status_Line = TGETFLAG ("hs")))) + { + Disable_Status_line_Str = SLtt_tgetstr ("ds"); + Return_From_Status_Line_Str = SLtt_tgetstr ("fs"); + Goto_Status_Line_Str = SLtt_tgetstr ("ts"); + /* Status_Line_Esc_Ok = TGETFLAG("es"); */ + Num_Status_Line_Columns = SLtt_tgetnum ("ws"); + if (Num_Status_Line_Columns < 0) Num_Status_Line_Columns = 0; + } + + if (NULL == (Norm_Vid_Str = SLtt_tgetstr("me"))) + { + Norm_Vid_Str = SLtt_tgetstr("se"); + } + + Cursor_Invisible_Str = SLtt_tgetstr("vi"); + Cursor_Visible_Str = SLtt_tgetstr("ve"); + + Curs_F_Str = SLtt_tgetstr("RI"); + +# if 0 + if (NULL != Curs_F_Str) + { + Len_Curs_F_Str = strlen(Curs_F_Str); + } + else Len_Curs_F_Str = strlen(Curs_Pos_Str); +# endif + + Automatic_Margins = TGETFLAG ("am"); + /* No_Move_In_Standout = !TGETFLAG ("ms"); */ +# ifdef HP_GLITCH_CODE + Has_HP_Glitch = TGETFLAG ("xs"); +# else + Worthless_Highlight = TGETFLAG ("xs"); +# endif + + if (Worthless_Highlight == 0) + { /* Magic cookie glitch */ + Worthless_Highlight = (SLtt_tgetnum ("sg") > 0); + } + + if (Worthless_Highlight) + SLtt_Has_Alt_Charset = 0; + + Reset_Color_String = SLtt_tgetstr ("op"); + + /* Apparantly the difference between "AF" and "Sf" is that AF uses RGB, + * but Sf uses BGR. + */ + Color_Fg_Str = SLtt_tgetstr ("AF"); /* ANSI setaf */ + if (Color_Fg_Str == NULL) + { + Color_Fg_Str = SLtt_tgetstr ("Sf"); /* setf */ + Is_Fg_BGR = (Color_Fg_Str != NULL); + } + Color_Bg_Str = SLtt_tgetstr ("AB"); /* ANSI setbf */ + if (Color_Bg_Str == NULL) + { + Color_Bg_Str = SLtt_tgetstr ("Sb"); /* setb */ + Is_Fg_BGR = (Color_Bg_Str != NULL); + } + + if ((Max_Terminfo_Colors = SLtt_tgetnum ("Co")) < 0) + Max_Terminfo_Colors = 8; + + if ((Color_Bg_Str != NULL) && (Color_Fg_Str != NULL)) + SLtt_Use_Ansi_Colors = 1; + else + { +#if 0 + Color_Fg_Str = "%?%p1%{7}%>%t\033[1;3%p1%{8}%m%dm%e\033[3%p1%dm%;"; + Color_Bg_Str = "%?%p1%{7}%>%t\033[5;4%p1%{8}%m%dm%e\033[4%p1%dm%;"; + Max_Terminfo_Colors = 16; +#else + Color_Fg_Str = "\033[3%dm"; + Color_Bg_Str = "\033[4%dm"; + Max_Terminfo_Colors = 8; +#endif + } + +#if SLTT_HAS_NON_BCE_SUPPORT + Can_Background_Color_Erase = TGETFLAG ("ut"); /* bce */ + /* Modern xterms have the BCE capability as well as the linux console */ + if (Can_Background_Color_Erase == 0) + { + Can_Background_Color_Erase = (Linux_Console +# if SLTT_XTERM_ALWAYS_BCE + || is_xterm +# endif + ); + } +#endif + get_color_info (); + + + if ((Cls_Str == NULL) + || (Curs_Pos_Str == NULL)) + return -2; + + return 0; +} + +#endif +/* Unix */ + +/* specific to vtxxx only */ +void SLtt_enable_cursor_keys (void) +{ +#ifdef __unix__ + if (Vt100_Like) +#endif + tt_write_string("\033=\033[?1l"); +} + +#ifdef VMS +int SLtt_initialize (char *term) +{ + SLtt_get_terminfo (); + return 0; +} + +void SLtt_get_terminfo () +{ + int zero = 0; + + /* Apparantly, this cannot fail according to the man pages. */ + if (SLang_TT_Write_FD == -1) + SLang_TT_Write_FD = fileno (stdout); + + Can_Background_Color_Erase = 0; + + Color_Fg_Str = "\033[3%dm"; + Color_Bg_Str = "\033[4%dm"; + Max_Terminfo_Colors = 8; + + get_color_info (); + + SLtt_set_term_vtxxx(&zero); + Start_Alt_Chars_Str = "\016"; + End_Alt_Chars_Str = "\017"; + SLtt_Has_Alt_Charset = 1; + SLtt_Graphics_Char_Pairs = "aaffgghhjjkkllmmnnooqqssttuuvvwwxx"; + Enable_Alt_Char_Set = "\033(B\033)0"; + SLtt_get_screen_size (); +} +#endif + +/* This sets term for vt102 terminals it parameter vt100 is 0. If vt100 + * is non-zero, set terminal appropriate for a only vt100 + * (no add line capability). */ + +void SLtt_set_term_vtxxx(int *vt100) +{ + Norm_Vid_Str = "\033[m"; + + Scroll_R_Str = "\033[%i%d;%dr"; + Cls_Str = "\033[2J\033[H"; + Rev_Vid_Str = "\033[7m"; + Bold_Vid_Str = "\033[1m"; + Blink_Vid_Str = "\033[5m"; + UnderLine_Vid_Str = "\033[4m"; + Del_Eol_Str = "\033[K"; + Del_Bol_Str = "\033[1K"; + Rev_Scroll_Str = "\033M"; + Curs_F_Str = "\033[%dC"; + /* Len_Curs_F_Str = 5; */ + Curs_Pos_Str = "\033[%i%d;%dH"; + if ((vt100 == NULL) || (*vt100 == 0)) + { + Ins_Mode_Str = "\033[4h"; + Eins_Mode_Str = "\033[4l"; + Del_Char_Str = "\033[P"; + Del_N_Lines_Str = "\033[%dM"; + Add_N_Lines_Str = "\033[%dL"; + SLtt_Term_Cannot_Insert = 0; + } + else + { + Del_N_Lines_Str = NULL; + Add_N_Lines_Str = NULL; + SLtt_Term_Cannot_Insert = 1; + } + SLtt_Term_Cannot_Scroll = 0; + /* No_Move_In_Standout = 0; */ +} + +int SLtt_init_video (void) +{ + /* send_string_to_term("\033[?6h"); */ + /* relative origin mode */ + tt_write_string (Term_Init_Str); + tt_write_string (Keypad_Init_Str); + SLtt_reset_scroll_region(); + SLtt_end_insert(); + tt_write_string (Enable_Alt_Char_Set); + Video_Initialized = 1; + return 0; +} + +int SLtt_reset_video (void) +{ + SLtt_goto_rc (SLtt_Screen_Rows - 1, 0); + Cursor_Set = 0; + SLtt_normal_video (); /* MSKermit requires this */ + tt_write_string(Norm_Vid_Str); + + Current_Fgbg = 0xFFFFFFFFU; + SLtt_set_alt_char_set (0); + if (SLtt_Use_Ansi_Colors) + { + if (Reset_Color_String == NULL) + { + SLtt_Char_Type attr; + if (-1 != make_color_fgbg (NULL, NULL, &attr)) + write_attributes (attr); + else tt_write_string ("\033[0m\033[m"); + } + else tt_write_string (Reset_Color_String); + Current_Fgbg = 0xFFFFFFFFU; + } + SLtt_erase_line (); + tt_write_string (Keypad_Reset_Str); + tt_write_string (Term_Reset_Str); + SLtt_flush_output (); + Video_Initialized = 0; + return 0; +} + +void SLtt_bold_video (void) +{ + tt_write_string (Bold_Vid_Str); +} + +int SLtt_set_mouse_mode (int mode, int force) +{ + char *term; + + if (force == 0) + { + if (NULL == (term = (char *) getenv("TERM"))) return -1; + if (strncmp ("xterm", term, 5)) + return -1; + } + + if (mode) + tt_write_string ("\033[?9h"); + else + tt_write_string ("\033[?9l"); + + return 0; +} + +void SLtt_disable_status_line (void) +{ + if (SLtt_Has_Status_Line > 0) + { + tt_write_string (Disable_Status_line_Str); + SLtt_flush_output (); + } +} + +int SLtt_write_to_status_line (char *s, int col) +{ + if ((SLtt_Has_Status_Line <= 0) + || (Goto_Status_Line_Str == NULL) + || (Return_From_Status_Line_Str == NULL)) + return -1; + + tt_printf (Goto_Status_Line_Str, col, 0); + tt_write_string (s); + tt_write_string (Return_From_Status_Line_Str); + return 0; +} + +void SLtt_get_screen_size (void) +{ +#ifdef VMS + int status, code; + unsigned short chan; + $DESCRIPTOR(dev_dsc, "SYS$INPUT:"); +#endif + int r = 0, c = 0; + +#ifdef TIOCGWINSZ + struct winsize wind_struct; + + do + { + if ((ioctl(1,TIOCGWINSZ,&wind_struct) == 0) + || (ioctl(0, TIOCGWINSZ, &wind_struct) == 0) + || (ioctl(2, TIOCGWINSZ, &wind_struct) == 0)) + { + c = (int) wind_struct.ws_col; + r = (int) wind_struct.ws_row; + break; + } + } + while (errno == EINTR); + +#endif + +#ifdef VMS + status = sys$assign(&dev_dsc,&chan,0,0,0); + if (status & 1) + { + code = DVI$_DEVBUFSIZ; + status = lib$getdvi(&code, &chan,0, &c, 0,0); + if (!(status & 1)) + c = 80; + code = DVI$_TT_PAGE; + status = lib$getdvi(&code, &chan,0, &r, 0,0); + if (!(status & 1)) + r = 24; + sys$dassgn(chan); + } +#endif + + if (r <= 0) + { + char *s = getenv ("LINES"); + if (s != NULL) r = atoi (s); + } + + if (c <= 0) + { + char *s = getenv ("COLUMNS"); + if (s != NULL) c = atoi (s); + } + + if ((r <= 0) || (r > SLTT_MAX_SCREEN_ROWS)) r = 24; + if ((c <= 0) || (c > SLTT_MAX_SCREEN_COLS)) c = 80; + SLtt_Screen_Rows = r; + SLtt_Screen_Cols = c; +} + +#if SLTT_HAS_NON_BCE_SUPPORT +int _SLtt_get_bce_color_offset (void) +{ + if ((SLtt_Use_Ansi_Colors == 0) + || Can_Background_Color_Erase + || SLtt_Use_Blink_For_ACS) /* in this case, we cannot lose a color */ + Bce_Color_Offset = 0; + else + { + if (GET_BG(Ansi_Color_Map[0].fgbg) == SLSMG_COLOR_DEFAULT) + Bce_Color_Offset = 0; + else + Bce_Color_Offset = 1; + } + + return Bce_Color_Offset; +} +#endif diff --git a/libslang/src/sldostty.c b/libslang/src/sldostty.c new file mode 100644 index 0000000..bc3f32a --- /dev/null +++ b/libslang/src/sldostty.c @@ -0,0 +1,519 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#ifdef __DJGPP__ +# define _NAIVE_DOS_REGS +#endif + +#include + +#if defined (__EMX__) +# define int86 _int86 +# define delay _sleep2 +#endif /* __EMX__ */ + +#if defined (__WATCOMC__) +# include +# include +# define int86 int386 +#endif + +#if defined (__DJGPP__) +# include +# include +# include +#endif + +#ifndef _NKEYBRD_READ +# define _NKEYBRD_READ 0x0 +#endif +#ifndef _NKEYBRD_READY +# define _NKEYBRD_READY 0x1 +#endif +#ifndef _NKEYBRD_SHIFTSTATUS +# define _NKEYBRD_SHIFTSTATUS 0x2 +#endif + +#define BIOSKEY slbioskey +#if defined(__WATCOMC__) +# define keyWaiting() _bios_keybrd(_NKEYBRD_READY) +#else +# define keyWaiting() BIOSKEY(_NKEYBRD_READY) +#endif + +#ifndef __EMX__ +# define USE_MOUSE_CODE 1 +#else +# define USE_MOUSE_CODE 0 +#endif + +#include "slang.h" +#include "_slang.h" + +#ifdef __cplusplus +# define _DOTS_ ... +#else +# define _DOTS_ void +#endif + +#if !defined (__EMX__) && !defined (__GO32__) && !defined (__WATCOMC__) +#define HAS_INT9 +#endif + +#ifdef __GO32__ +# include +#endif + +#if defined (HAS_INT9) +static void interrupt (*int9_old) (_DOTS_); +static unsigned char far *shift = (unsigned char far *) 0x417; +static unsigned int Abort_Scan_Code = 34; /* 34 = scan code for ^G */ + +/*----------------------------------------------------------------------*\ + * an interrupt 9 handler, not for use with most 32 bit compilers +\*----------------------------------------------------------------------*/ +static void interrupt int9_handler (_DOTS_) +{ + unsigned char s, s1; + + s1 = *shift & 0xF; /* ignore caps, ins, num lock, scroll lock */ + s = inp (0x60); + if (s1 & 0x04) /* control key */ + { + if (s == Abort_Scan_Code) + { + if (SLang_Ignore_User_Abort == 0) SLang_Error = SL_USER_BREAK; + SLKeyBoard_Quit = 1; + } + } + (*int9_old) (); +} +#endif /* HAS_INT9 */ + +static void int9_change (int set) +{ +#if defined (HAS_INT9) + if (set) /* install a new handler */ + { + if (int9_old != NULL) return; + int9_old = getvect (9); + setvect (9, int9_handler); + } + else if (int9_old != NULL) /* restore the old handler */ + { + setvect (9, int9_old); + int9_old = NULL; + } +#else + (void) set; +#endif /* HAS_INT9 */ +} + +/*----------------------------------------------------------------------*\ + * Function: static void set_ctrl_break (int state); + * + * set the control-break setting +\*----------------------------------------------------------------------*/ +static void set_ctrl_break (int state) +{ +#if defined (__EMX__) + (void) state; /* not really required */ +#else /* __EMX__ */ + + static int prev = 0; + +# if defined (__GO32__) + if (state == 0) + { +# if __DJGPP__ >= 2 + signal (SIGINT, SIG_IGN); +# endif + prev = getcbrk (); + setcbrk (0); + } + else + { +# if __DJGPP__ >= 2 + signal (SIGINT, SIG_DFL); +# endif + setcbrk (prev); + } +# else /* __GO32__ */ +# if defined(__WATCOMC__) + fprintf (stderr, "Have not yet defined set_ctrl_break for __WATCOMC__\n"); + prev = state; +# else + asm mov dl, byte ptr prev + asm mov ax, state + asm cmp ax, 0 + asm jne L1 + asm mov ah, 33h + asm mov al, 0 + asm mov dl, byte ptr prev + asm int 21h + asm xor ax, ax + asm mov al, dl + asm mov prev, ax + asm mov dl, 0 + L1: + asm mov al, 1 + asm mov ah, 33h + asm int 21h +# endif /* __WATCOMC__ */ +# endif /* __GO32__ */ +#endif /* __EMX__ */ +} + +/*----------------------------------------------------------------------*\ + * static unsigned int slbioskey (int op); + * + * op 0-2 (standard) and 0x10-0x12 (extended) are valid + * + * 0, 0x10 _NKEYBRD_READ - read the key + * 1, 0x11 _NKEYBRD_READY - check if a key is waiting + * if so give a peek of its value, otherwise return 0 + * 2, 0x12 _NKEYBRD_SHIFTSTATUS - get shift flags + * (Ins, Cap, Num, Scroll, Alt, ^Ctrl L_shift, R_shift) + * flags = ICNSA^LR only the lower byte is valid! +\*----------------------------------------------------------------------*/ +static int bios_key_f = 0; +static unsigned int slbioskey (int op) +{ + union REGS r; + r.h.ah = (op & 0x03) | bios_key_f; + int86 (0x16, &r, &r); +#if defined(__WATCOMC__) + /* return (_bios_keybrd ((op & 0x03) | bios_key_f)); */ +# if 1 /* the correct zero flag for watcom? */ + /* is zero flag set? (no key waiting) */ + if ((op & _NKEYBRD_READY) && (r.x.cflag & 0x40) == 0x40) return 0; +# else /* the correct zero flag for watcom? */ + /* is zero flag set? (no key waiting) */ + if ((op & _NKEYBRD_READY) && (r.x.cflag & 0x4)) return 0; +# endif + return (r.x.eax & 0xffff); +#else + /* is zero flag set? (no key waiting) */ + if (op & _NKEYBRD_READY) + { + if ((r.x.flags & 0x40) == 0x40) + return 0; + if (r.x.ax == 0) /* CTRL-BREAK */ + return -1; + } + return (r.x.ax & 0xffff); +#endif +} + +#if USE_MOUSE_CODE +/*----------------------------------------------------------------------*\ + * Simple mouse routines for 16/32-bit DOS-targets. + * Gisle Vanem +\*----------------------------------------------------------------------*/ + +#define HARD_MOUSE_RESET 0 + +static int Have_Mouse = 0; +static int Process_Mouse_Events = 0; + +/*----------------------------------------------------------------------*\ + * peem_far_mem() + * +\*----------------------------------------------------------------------*/ +static unsigned long peek_dos_mem (unsigned long dos_addr, + unsigned char *pentry) +{ + unsigned long vector; + unsigned char entry; + +#if defined(__DJGPP__) +# define MAKE_LINEAR(seg,ofs) ((unsigned long)(((seg) << 4) + (ofs))) + vector = _farpeekl (_dos_ds, dos_addr); + entry = _farpeekb (_dos_ds, MAKE_LINEAR(vector >> 16, vector & 0xffff)); + +#elif defined(__EMX__) + vector = 0; + entry = 0; /* to-do!! */ + +#elif defined(__WATCOMC__) && defined(__FLAT__) /* wcc386 */ + vector = *(unsigned long*) dos_addr; + entry = *(unsigned char*) vector; +#else + vector = *(unsigned long far*) dos_addr; + entry = *(unsigned char far*) vector; +#endif + + if (pentry) + *pentry = entry; + return (vector); +} + +/*----------------------------------------------------------------------*\ + * mouse_pressed (int button, int *x_pos, int *y_pos) + * + * Return 1 if left (0) or right (1) mouse-button was pressed. +\*----------------------------------------------------------------------*/ +static int mouse_pressed (int button, int *x_pos, int *y_pos) +{ + union REGS r; + + r.x.ax = 5; + r.x.bx = button; + int86 (0x33, &r, &r); + *x_pos = r.x.cx; + *y_pos = r.x.dx; + return (r.x.bx); +} + +/*----------------------------------------------------------------------*\ + * mouse_show (int show) + * + * Show (show=1) or hide (show=0) the mouse cursor +\*----------------------------------------------------------------------*/ +static int mouse_show (int show) +{ + union REGS r; + + if (Have_Mouse == 0) + return -1; + + r.x.ax = show ? 1 : 2; + int86 (0x33, &r, &r); + return 0; +} + +/*----------------------------------------------------------------------*\ + * mouse_exit (void) + * + * Do a soft-reset of the mouse-driver (hides cursor) +\*----------------------------------------------------------------------*/ +static void mouse_exit (void) +{ + union REGS r; + r.x.ax = 0x21; + int86 (0x33, &r, &r); +} + +/*----------------------------------------------------------------------*\ + * mouse_init (void) + * + * Peek at mouse interrupt vector for a driver. + * Do a soft/hard-reset of the mouse-driver. + * Add a SLang atexit function +\*----------------------------------------------------------------------*/ +static int mouse_init (void) +{ + union REGS r; + unsigned char entry = 0; + unsigned long vector = peek_dos_mem (4*0x33, &entry); + + if (!vector || entry == 0xCF) /* NULL or points to IRET */ + return -1; + +#if HARD_MOUSE_RESET + r.x.ax = 0; /* mouse hard-reset and reinit */ +#else + r.x.ax = 0x21; /* mouse soft-reset and reinit */ +#endif + + int86 (0x33, &r, &r); + if (r.x.ax != 0xFFFF) + return -1; + + (void) SLang_add_cleanup_function (mouse_exit); + Have_Mouse = 1; + return 0; +} + +/*----------------------------------------------------------------------*\ + * static int mouse_get_event (void); + * + * Poll mouse for changed button-state and encode x/y position and + * button state into an escape sequence "\e[M.." +\*----------------------------------------------------------------------*/ +static int mouse_get_event (void) +{ + char buf [6]; + int x, y; + + if (!Have_Mouse || Process_Mouse_Events == 0) + return (0); + + if (mouse_pressed(0, &x, &y)) /* left button pressed? */ + buf[3] = 040; + else if (mouse_pressed(1, &x, &y)) /* right button pressed */ + buf[3] = 041; + else return (0); + +#if 0 /* test */ + fprintf (stderr, "mouse_get_event: x=%d, y=%d\n", x, y); +#endif + + /* + * Taken from slw32tty.c / process_mouse_event(): + * + * We have a simple press or release. Encode it as an escape sequence + * and buffer the result. The encoding is: + * 'ESC [ M b x y' + * where b represents the button state, and x,y represent the coordinates. + * The ESC is handled by the calling routine. + */ + buf[0] = 27; + buf[1] = '['; + buf[2] = 'M'; + buf[4] = 1 + ' ' + (x >> 3); /* textmode co-ordinates are 1/8th of */ + buf[5] = 1 + ' ' + (y >> 3); /* graphics-mode co-ordinates */ + + if (SLang_buffer_keystring (buf, sizeof(buf)) < 0) + return (0); + return (1); +} + +#endif /* USE_MOUSE_CODE */ + +/*----------------------------------------------------------------------*\ + * Function: int SLang_init_tty (int abort_char, int no_flow_control, + * int opost); + * + * initialize the keyboard interface and attempt to set-up the interrupt 9 + * handler if ABORT_CHAR is non-zero. + * NO_FLOW_CONTROL and OPOST are only for compatiblity and are ignored. +\*----------------------------------------------------------------------*/ +int SLang_init_tty (int abort_char, int no_flow_control, int opost) +{ + (void) no_flow_control; + (void) opost; + + bios_key_f = 0x10; /* assume it's an enhanced keyboard */ +#if defined (HAS_INT9) + bios_key_f &= peekb (0x40,0x96); /* verify it's true */ + if (abort_char > 0) Abort_Scan_Code = (unsigned int) abort_char; +#else + (void) abort_char; +#endif + + set_ctrl_break (0); + + return 0; +} + +/*----------------------------------------------------------------------*\ + * Function: void SLang_reset_tty (void); + * + * reset the tty before exiting +\*----------------------------------------------------------------------*/ +void SLang_reset_tty (void) +{ + int9_change (0); + set_ctrl_break (1); +} + +/*----------------------------------------------------------------------*\ + * Function: int _SLsys_input_pending (int tsecs); + * + * sleep for *tsecs tenths of a sec waiting for input +\*----------------------------------------------------------------------*/ +int _SLsys_input_pending (int tsecs) +{ + if (keyWaiting()) return 1; + + /* Convert tsecs to units of 20 ms */ + tsecs = tsecs * 5; + + /* If tsecs is less than 0, it represents millisecs */ + if (tsecs < 0) + tsecs = -tsecs / 100; + + while ((tsecs > 0) && (SLang_Input_Buffer_Len == 0)) + { + delay (20); /* 20 ms or 1/50 sec */ +#if USE_MOUSE_CODE + if (1 == mouse_get_event ()) + return SLang_Input_Buffer_Len; +#endif + if (keyWaiting()) break; + tsecs--; + } + return (tsecs); +} + +/*----------------------------------------------------------------------*\ + * Function: unsigned int _SLsys_getkey (void); + * + * Wait for and get the next available mouse-event / keystroke. + * Also re-maps some useful keystrokes. + * + * Backspace (^H) => Del (127) + * Ctrl-Space => ^@ (^@^3 - a pc NUL char) + * extended keys are prefixed by a null character +\*----------------------------------------------------------------------*/ +unsigned int _SLsys_getkey (void) +{ + unsigned int key, scan, ch, shift; + + while ((SLang_Input_Buffer_Len == 0) + && (0 == _SLsys_input_pending (300))) + ; + + if (SLang_Input_Buffer_Len) + return SLang_getkey (); + + key = BIOSKEY(_NKEYBRD_READ); + ch = key & 0xff; + scan = key >> 8; + shift = BIOSKEY(_NKEYBRD_SHIFTSTATUS) & 0xf; + + if (key == 0x0e08) + return 127; /* Backspace key */ + + switch (ch) + { + case 32: + if (0 == (shift & 0x04)) + break; + /* ^space = ^@ */ + scan = 3; /* send back Ctrl-@ => ^@^C */ + /* drop */ + case 0xe0: + case 0: /* extended key code */ + ch = _SLpc_convert_scancode (scan, 0, 1); + } + return (ch); +} + +/*----------------------------------------------------------------------*\ + * Function: void SLang_set_abort_signal (void (*handler)(int)); +\*----------------------------------------------------------------------*/ +int SLang_set_abort_signal (void (*handler)(int)) +{ + if (handler == NULL) int9_change (1); + return 0; +} + +int SLtt_set_mouse_mode (int mode, int force) +{ +#if USE_MOUSE_CODE + (void) force; + + if ((Have_Mouse == 0) + && (-1 == mouse_init ())) + { + Process_Mouse_Events = 0; + return -1; + } + + Process_Mouse_Events = mode; + return mouse_show (mode); +#else + (void) mode; + (void) force; + + return -1; +#endif +} diff --git a/libslang/src/slerr.c b/libslang/src/slerr.c new file mode 100644 index 0000000..2e4eca5 --- /dev/null +++ b/libslang/src/slerr.c @@ -0,0 +1,181 @@ +/* error handling common to all routines. */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +void (*SLang_VMessage_Hook) (char *, va_list); +void (*SLang_Error_Hook)(char *); +void (*SLang_Exit_Error_Hook)(char *, va_list); +volatile int SLang_Error = 0; +char *SLang_Error_Message; +volatile int SLKeyBoard_Quit = 0; + +static char *get_error_string (void) +{ + char *str; + + if (!SLang_Error) SLang_Error = SL_UNKNOWN_ERROR; + if (SLang_Error_Message != NULL) str = SLang_Error_Message; + else switch(SLang_Error) + { + case SL_NOT_IMPLEMENTED: str = "Not Implemented"; break; + case SL_APPLICATION_ERROR: str = "Application Error"; break; + case SL_VARIABLE_UNINITIALIZED: str = "Variable Uninitialized"; break; + case SL_MALLOC_ERROR : str = "Malloc Error"; break; + case SL_INTERNAL_ERROR: str = "Internal Error"; break; + case SL_STACK_OVERFLOW: str = "Stack Overflow"; break; + case SL_STACK_UNDERFLOW: str = "Stack Underflow"; break; + case SL_INTRINSIC_ERROR: str = "Intrinsic Error"; break; + case SL_USER_BREAK: str = "User Break"; break; + case SL_UNDEFINED_NAME: str = "Undefined Name"; break; + case SL_SYNTAX_ERROR: str = "Syntax Error"; break; + case SL_DUPLICATE_DEFINITION: str = "Duplicate Definition"; break; + case SL_TYPE_MISMATCH: str = "Type Mismatch"; break; + case SL_READONLY_ERROR: str = "Variable is read-only"; break; + case SL_DIVIDE_ERROR: str = "Divide by zero"; break; + case SL_OBJ_NOPEN: str = "Object not opened"; break; + case SL_OBJ_UNKNOWN: str = "Object unknown"; break; + case SL_INVALID_PARM: str = "Invalid Parameter"; break; + case SL_TYPE_UNDEFINED_OP_ERROR: + str = "Operation not defined for datatype"; break; + case SL_USER_ERROR: + str = "User Error"; break; + case SL_USAGE_ERROR: + str = "Illegal usage of function"; + break; + case SL_FLOATING_EXCEPTION: + str = "Floating Point Exception"; + break; + case SL_UNKNOWN_ERROR: + default: str = "Unknown Error Code"; + } + + SLang_Error_Message = NULL; + return str; +} + +void SLang_doerror (char *error) +{ + char *str = NULL; + char *err; + char *malloced_err_buf; + char err_buf [1024]; + + malloced_err_buf = NULL; + + if (((SLang_Error == SL_USER_ERROR) + || (SLang_Error == SL_USAGE_ERROR)) + && (error != NULL) && (*error != 0)) + err = error; + else + { + char *sle = "S-Lang Error: "; + unsigned int len; + char *fmt; + + str = get_error_string (); + + fmt = "%s%s%s"; + if ((error == NULL) || (*error == 0)) + error = ""; + else if (SLang_Error == SL_UNKNOWN_ERROR) + /* Do not display an unknown error message if error is non-NULL */ + str = ""; + else + fmt = "%s%s: %s"; + + len = strlen (sle) + strlen (str) + strlen(error) + 1; + + err = err_buf; + if (len >= sizeof (err_buf)) + { + if (NULL == (malloced_err_buf = SLmalloc (len))) + err = NULL; + else + err = malloced_err_buf; + } + + if (err != NULL) sprintf (err, fmt, sle, str, error); + else err = "Out of memory"; + } + + if (SLang_Error_Hook == NULL) + { + fputs (err, stderr); + fputs("\r\n", stderr); + fflush (stderr); + } + else + (*SLang_Error_Hook)(err); + + SLfree (malloced_err_buf); +} + +void SLang_verror (int err_code, char *fmt, ...) +{ + va_list ap; + char err [1024]; + + if (err_code == 0) err_code = SL_INTRINSIC_ERROR; + if (SLang_Error == 0) SLang_Error = err_code; + + if (fmt != NULL) + { + va_start(ap, fmt); + (void) _SLvsnprintf (err, sizeof (err), fmt, ap); + fmt = err; + va_end(ap); + } + + SLang_doerror (fmt); +} + +void SLang_exit_error (char *fmt, ...) +{ + va_list ap; + + va_start (ap, fmt); + if (SLang_Exit_Error_Hook != NULL) + { + (*SLang_Exit_Error_Hook) (fmt, ap); + exit (1); + } + + if (fmt != NULL) + { + vfprintf (stderr, fmt, ap); + fputs ("\r\n", stderr); + fflush (stderr); + } + va_end (ap); + + exit (1); +} + +void SLang_vmessage (char *fmt, ...) +{ + va_list ap; + + if (fmt == NULL) + return; + + va_start (ap, fmt); + + if (SLang_VMessage_Hook != NULL) + (*SLang_VMessage_Hook) (fmt, ap); + else + { + vfprintf (stdout, fmt, ap); + fputs ("\r\n", stdout); + } + + va_end (ap); +} diff --git a/libslang/src/slerrno.c b/libslang/src/slerrno.c new file mode 100644 index 0000000..8d49d80 --- /dev/null +++ b/libslang/src/slerrno.c @@ -0,0 +1,219 @@ +/* The point of this file is to handle errno values in a system independent + * way so that they may be used in slang scripts. + */ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include +#include "slang.h" +#include "_slang.h" + +typedef SLCONST struct +{ + char *msg; + int sys_errno; + char *symbolic_name; +} +Errno_Map_Type; + +static Errno_Map_Type Errno_Map [] = +{ +#ifndef EPERM +# define EPERM -1 +#endif + {"Not owner", EPERM, "EPERM"}, +#ifndef ENOENT +# define ENOENT -1 +#endif + {"No such file or directory", ENOENT, "ENOENT"}, +#ifndef ESRCH +# define ESRCH -1 +#endif + {"No such process", ESRCH, "ESRCH"}, +#ifndef EINTR +# define EINTR -1 +#endif + {"Interrupted system call", EINTR, "EINTR"}, +#ifndef EIO +# define EIO -1 +#endif + {"I/O error", EIO, "EIO"}, +#ifndef ENXIO +# define ENXIO -1 +#endif + {"No such device or address", ENXIO, "ENXIO"}, +#ifndef E2BIG +# define E2BIG -1 +#endif + {"Arg list too long", E2BIG, "E2BIG"}, +#ifndef ENOEXEC +# define ENOEXEC -1 +#endif + {"Exec format error", ENOEXEC,"ENOEXEC"}, +#ifndef EBADF +# define EBADF -1 +#endif + {"Bad file number", EBADF, "EBADF"}, +#ifndef ECHILD +# define ECHILD -1 +#endif + {"No children", ECHILD, "ECHILD"}, +#ifndef EAGAIN +# define EAGAIN -1 +#endif + {"Try again", EAGAIN, "EAGAIN"}, +#ifndef ENOMEM +# define ENOMEM -1 +#endif + {"Not enough core", ENOMEM, "ENOMEM"}, +#ifndef EACCES +# define EACCES -1 +#endif + {"Permission denied", EACCES, "EACCES"}, +#ifndef EFAULT +# define EFAULT -1 +#endif + {"Bad address", EFAULT, "EFAULT"}, +#ifndef ENOTBLK +# define ENOTBLK -1 +#endif + {"Block device required", ENOTBLK, "ENOTBLK"}, +#ifndef EBUSY +# define EBUSY -1 +#endif + {"Mount device busy", EBUSY, "EBUSY"}, +#ifndef EEXIST +# define EEXIST -1 +#endif + {"File exists", EEXIST, "EEXIST"}, +#ifndef EXDEV +# define EXDEV -1 +#endif + {"Cross-device link", EXDEV, "EXDEV"}, +#ifndef ENODEV +# define ENODEV -1 +#endif + {"No such device", ENODEV, "ENODEV"}, +#ifndef ENOTDIR +# define ENOTDIR -1 +#endif + {"Not a directory", ENOTDIR, "ENOTDIR"}, +#ifndef EISDIR +# define EISDIR -1 +#endif + {"Is a directory", EISDIR, "EISDIR"}, +#ifndef EINVAL +# define EINVAL -1 +#endif + {"Invalid argument", EINVAL, "EINVAL"}, +#ifndef ENFILE +# define ENFILE -1 +#endif + {"File table overflow", ENFILE, "ENFILE"}, +#ifndef EMFILE +# define EMFILE -1 +#endif + {"Too many open files", EMFILE, "EMFILE"}, +#ifndef ENOTTY +# define ENOTTY -1 +#endif + {"Not a typewriter", ENOTTY, "ENOTTY"}, +#ifndef ETXTBSY +# define ETXTBSY -1 +#endif + {"Text file busy", ETXTBSY, "ETXTBSY"}, +#ifndef EFBIG +# define EFBIG -1 +#endif + {"File too large", EFBIG, "EFBIG"}, +#ifndef ENOSPC +# define ENOSPC -1 +#endif + {"No space left on device", ENOSPC, "ENOSPC"}, +#ifndef ESPIPE +# define ESPIPE -1 +#endif + {"Illegal seek", ESPIPE, "ESPIPE"}, +#ifndef EROFS +# define EROFS -1 +#endif + {"Read-only file system", EROFS, "EROFS"}, +#ifndef EMLINK +# define EMLINK -1 +#endif + {"Too many links", EMLINK, "EMLINK"}, +#ifndef EPIPE +# define EPIPE -1 +#endif + {"Broken pipe", EPIPE, "EPIPE"}, +#ifndef ELOOP +# define ELOOP -1 +#endif + {"Too many levels of symbolic links",ELOOP, "ELOOP"}, +#ifndef ENAMETOOLONG +# define ENAMETOOLONG -1 +#endif + {"File name too long", ENAMETOOLONG, "ENAMETOOLONG"}, + + {NULL, 0, NULL} +}; + +int _SLerrno_errno; + +int SLerrno_set_errno (int sys_errno) +{ + _SLerrno_errno = sys_errno; + return 0; +} + +char *SLerrno_strerror (int sys_errno) +{ + Errno_Map_Type *e; + + e = Errno_Map; + while (e->msg != NULL) + { + if (e->sys_errno == sys_errno) + return e->msg; + + e++; + } + + if (sys_errno == SL_ERRNO_NOT_IMPLEMENTED) + return "System call not available for this platform"; + + return "Unknown error"; +} + +static char *intrin_errno_string (int *sys_errno) +{ + return SLerrno_strerror (*sys_errno); +} + +int _SLerrno_init (void) +{ + static Errno_Map_Type *e; + + if (e != NULL) /* already initialized */ + return 0; + + if ((-1 == SLadd_intrinsic_function ("errno_string", (FVOID_STAR) intrin_errno_string, + SLANG_STRING_TYPE, 1, SLANG_INT_TYPE)) + || (-1 == SLadd_intrinsic_variable ("errno", (VOID_STAR)&_SLerrno_errno, SLANG_INT_TYPE, 1))) + return -1; + + e = Errno_Map; + while (e->msg != NULL) + { + if (-1 == SLadd_intrinsic_variable (e->symbolic_name, (VOID_STAR) &e->sys_errno, SLANG_INT_TYPE, 1)) + return -1; + e++; + } + + return 0; +} diff --git a/libslang/src/slfile.c b/libslang/src/slfile.c new file mode 100644 index 0000000..b58d24b --- /dev/null +++ b/libslang/src/slfile.c @@ -0,0 +1,24 @@ +/* file stdio intrinsics for S-Lang */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* Compatibility */ +int SLang_init_slfile (void) +{ + if ((-1 == SLang_init_stdio ()) + || (-1 == SLang_init_posix_dir ()) + || (-1 == SLdefine_for_ifdef("__SLFILE__"))) + return -1; + + return 0; +} + diff --git a/libslang/src/slgetkey.c b/libslang/src/slgetkey.c new file mode 100644 index 0000000..68b13a3 --- /dev/null +++ b/libslang/src/slgetkey.c @@ -0,0 +1,306 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +unsigned int SLang_Input_Buffer_Len = 0; +unsigned char SLang_Input_Buffer [SL_MAX_INPUT_BUFFER_LEN]; + +int SLang_Abort_Char = 7; +int SLang_Ignore_User_Abort = 0; + +/* This has the effect of mapping all characters in the range 128-169 to + * ESC [ something + */ + +unsigned int SLang_getkey (void) +{ + unsigned int imax; + unsigned int ch; + + if (SLang_Input_Buffer_Len) + { + ch = (unsigned int) *SLang_Input_Buffer; + SLang_Input_Buffer_Len--; + imax = SLang_Input_Buffer_Len; + + SLMEMCPY ((char *) SLang_Input_Buffer, + (char *) (SLang_Input_Buffer + 1), imax); + } + else if (SLANG_GETKEY_ERROR == (ch = _SLsys_getkey ())) return ch; + +#if _SLANG_MAP_VTXXX_8BIT +# if !defined(IBMPC_SYSTEM) + if (ch & 0x80) + { + unsigned char i; + i = (unsigned char) (ch & 0x7F); + if (i < ' ') + { + i += 64; + SLang_ungetkey (i); + ch = 27; + } + } +# endif +#endif + return(ch); +} + +int SLang_ungetkey_string (unsigned char *s, unsigned int n) +{ + register unsigned char *bmax, *b, *b1; + if (SLang_Input_Buffer_Len + n + 3 > SL_MAX_INPUT_BUFFER_LEN) + return -1; + + b = SLang_Input_Buffer; + bmax = (b - 1) + SLang_Input_Buffer_Len; + b1 = bmax + n; + while (bmax >= b) *b1-- = *bmax--; + bmax = b + n; + while (b < bmax) *b++ = *s++; + SLang_Input_Buffer_Len += n; + return 0; +} + +int SLang_buffer_keystring (unsigned char *s, unsigned int n) +{ + + if (n + SLang_Input_Buffer_Len + 3 > SL_MAX_INPUT_BUFFER_LEN) return -1; + + SLMEMCPY ((char *) SLang_Input_Buffer + SLang_Input_Buffer_Len, + (char *) s, n); + SLang_Input_Buffer_Len += n; + return 0; +} + +int SLang_ungetkey (unsigned char ch) +{ + return SLang_ungetkey_string(&ch, 1); +} + +int SLang_input_pending (int tsecs) +{ + int n; + unsigned char c; + if (SLang_Input_Buffer_Len) return (int) SLang_Input_Buffer_Len; + + n = _SLsys_input_pending (tsecs); + + if (n <= 0) return 0; + + c = (unsigned char) SLang_getkey (); + SLang_ungetkey_string (&c, 1); + + return n; +} + +void SLang_flush_input (void) +{ + int quit = SLKeyBoard_Quit; + + SLang_Input_Buffer_Len = 0; + SLKeyBoard_Quit = 0; + while (_SLsys_input_pending (0) > 0) + { + (void) _SLsys_getkey (); + /* Set this to 0 because _SLsys_getkey may stuff keyboard buffer if + * key sends key sequence (OS/2, DOS, maybe VMS). + */ + SLang_Input_Buffer_Len = 0; + } + SLKeyBoard_Quit = quit; +} + +#ifdef IBMPC_SYSTEM +static int Map_To_ANSI; +int SLgetkey_map_to_ansi (int enable) +{ + Map_To_ANSI = enable; + return 0; +} + +static int convert_scancode (unsigned int scan, + unsigned int shift, + int getkey, + unsigned int *ret_key) +{ + unsigned char buf[16]; + unsigned char *b; + unsigned char end; + int is_arrow; + + shift &= (_SLTT_KEY_ALT|_SLTT_KEY_SHIFT|_SLTT_KEY_CTRL); + + b = buf; + if (_SLTT_KEY_ALT == shift) + { + shift = 0; + *b++ = 27; + } + *b++ = 27; + *b++ = '['; + + is_arrow = 0; + end = '~'; + if (shift) + { + if (shift == _SLTT_KEY_CTRL) + end = '^'; + else if (shift == _SLTT_KEY_SHIFT) + end = '$'; + else shift = 0; + } + + /* These mappings correspond to what rxvt produces under Linux */ + switch (scan & 0xFF) + { + default: + return -1; + + case 0x47: /* home */ + *b++ = '1'; + break; + case 0x48: /* up */ + end = 'A'; + is_arrow = 1; + break; + case 0x49: /* PgUp */ + *b++ = '5'; + break; + case 0x4B: /* Left */ + end = 'D'; + is_arrow = 1; + break; + case 0x4D: /* Right */ + end = 'C'; + is_arrow = 1; + break; + case 0x4F: /* End */ + *b++ = '4'; + break; + case 0x50: /* Down */ + end = 'B'; + is_arrow = 1; + break; + case 0x51: /* PgDn */ + *b++ = '6'; + break; + case 0x52: /* Insert */ + *b++ = '2'; + break; + case 0x53: /* Delete */ + *b++ = '3'; + break; + case ';': /* F1 */ + *b++ = '1'; + *b++ = '1'; + break; + case '<': /* F2 */ + *b++ = '1'; + *b++ = '2'; + break; + case '=': /* F3 */ + *b++ = '1'; + *b++ = '3'; + break; + + case '>': /* F4 */ + *b++ = '1'; + *b++ = '4'; + break; + + case '?': /* F5 */ + *b++ = '1'; + *b++ = '5'; + break; + + case '@': /* F6 */ + *b++ = '1'; + *b++ = '7'; + break; + + case 'A': /* F7 */ + *b++ = '1'; + *b++ = '8'; + break; + + case 'B': /* F8 */ + *b++ = '1'; + *b++ = '9'; + break; + + case 'C': /* F9 */ + *b++ = '2'; + *b++ = '0'; + break; + + case 'D': /* F10 */ + *b++ = '2'; + *b++ = '1'; + break; + + case 0x57: /* F11 */ + *b++ = '2'; + *b++ = '3'; + break; + + case 0x58: /* F12 */ + *b++ = '2'; + *b++ = '4'; + break; + } + + if (is_arrow && shift) + { + if (shift == _SLTT_KEY_CTRL) + end &= 0x1F; + else + end |= 0x20; + } + *b++ = end; + + if (getkey) + { + (void) SLang_buffer_keystring (buf + 1, (unsigned int) (b - (buf + 1))); + *ret_key = buf[0]; + return 0; + } + + (void) SLang_buffer_keystring (buf, (unsigned int) (b - buf)); + return 0; +} + + +unsigned int _SLpc_convert_scancode (unsigned int scan, + unsigned int shift, + int getkey) +{ + unsigned char buf[16]; + + if (Map_To_ANSI) + { + if (0 == convert_scancode (scan, shift, getkey, &scan)) + return scan; + } + + if (getkey) + { + buf[0] = scan & 0xFF; + SLang_buffer_keystring (buf, 1); + return (scan >> 8) & 0xFF; + } + buf[0] = (scan >> 8) & 0xFF; + buf[1] = scan & 0xFF; + (void) SLang_buffer_keystring (buf, 2); + return 0; +} + +#endif diff --git a/libslang/src/slimport.c b/libslang/src/slimport.c new file mode 100644 index 0000000..d1feaaf --- /dev/null +++ b/libslang/src/slimport.c @@ -0,0 +1,314 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#define SLANG_HAS_DYNAMIC_LINKING 1 + +#ifndef HAVE_DLFCN_H +# undef SLANG_HAS_DYNAMIC_LINKING +# define SLANG_HAS_DYNAMIC_LINKING 0 +#endif + +/* The rest of this file is in the if block */ +#if SLANG_HAS_DYNAMIC_LINKING + +#ifdef HAVE_DLFCN_H +# include +#endif + +static char *Module_Path; +#define MODULE_PATH_ENV_NAME "SLANG_MODULE_PATH" +#ifndef MODULE_INSTALL_DIR +# define MODULE_INSTALL_DIR "/usr/local/lib/slang/modules" +#endif + +typedef struct _Handle_Type +{ + struct _Handle_Type *next; + char *name; + VOID_STAR handle; + void (*deinit_fun) (void); +} +Handle_Type; + +static Handle_Type *Handle_List; + +static void delete_handles (void) +{ + while (Handle_List != NULL) + { + Handle_Type *next = Handle_List->next; + + if (Handle_List->deinit_fun != NULL) + Handle_List->deinit_fun (); + (void) dlclose (Handle_List->handle); + SLang_free_slstring (Handle_List->name); + SLfree ((char *)Handle_List); + Handle_List = next; + } +} + +static Handle_Type *save_handle (char *name, VOID_STAR h, void (*df)(void)) +{ + Handle_Type *l; + + l = (Handle_Type *) SLmalloc (sizeof (Handle_Type)); + if (l == NULL) + return NULL; + memset ((char *) l, 0, sizeof(Handle_Type)); + if (NULL == (l->name = SLang_create_slstring (name))) + { + SLfree ((char *) l); + return NULL; + } + l->handle = h; + l->next = Handle_List; + l->deinit_fun = df; + Handle_List = l; + + return l; +} + +static Handle_Type *find_handle (char *name) +{ + Handle_Type *l; + + l = Handle_List; + while (l != NULL) + { + if (0 == strcmp (l->name, name)) + break; + l = l->next; + } + return l; +} + +static int import_from_library (char *name, + char *init_fun_name, char *deinit_fun_name, + char *file, + char *ns, + char *ns_init_fun_name) +{ + VOID_STAR handle; + int (*init_fun) (void); + int (*ns_init_fun) (char *); + void (*deinit_fun) (void); + char *err; + char filebuf[1024]; + char *fun_name; + char *save_file; + char *save_err; + + if (NULL != find_handle (name)) + return 0; /* already loaded */ + + save_err = NULL; + save_file = file; + while (1) + { +#ifndef RTLD_GLOBAL +# define RTLD_GLOBAL 0 +#endif +#ifdef RTLD_NOW + handle = (VOID_STAR) dlopen (file, RTLD_NOW | RTLD_GLOBAL); +#else + handle = (VOID_STAR) dlopen (file, RTLD_LAZY | RTLD_GLOBAL); +#endif + + if (handle != NULL) + { + if (save_err != NULL) + SLfree (save_err); + break; + } + + /* Purify reports that dlerror returns a pointer that generates UMR + * errors. There is nothing that I can do about that.... + */ + if ((NULL == strchr (file, '/')) + && (strlen(file) < sizeof(filebuf))) + { + err = (char *) dlerror (); + if (err != NULL) + save_err = SLmake_string (err); + + _SLsnprintf (filebuf, sizeof (filebuf), "./%s", file); + file = filebuf; + continue; + } + + if ((NULL == (err = save_err)) + && (NULL == (err = (char *) dlerror ()))) + err = "UNKNOWN"; + + SLang_verror (SL_INTRINSIC_ERROR, + "Error linking to %s: %s", save_file, err); + + if (save_err != NULL) + SLfree (save_err); + + return -1; + } + + fun_name = ns_init_fun_name; + ns_init_fun = (int (*)(char *)) dlsym (handle, fun_name); + + if ((ns == NULL) || (*ns == 0)) + ns = "Global"; + + if (ns_init_fun == NULL) + { + if (0 != strcmp (ns, "Global")) + goto return_error; + + fun_name = init_fun_name; + init_fun = (int (*)(void)) dlsym (handle, fun_name); + if (init_fun == NULL) + goto return_error; + + if (-1 == (*init_fun) ()) + { + dlclose (handle); + return -1; + } + } + else if (-1 == (*ns_init_fun) (ns)) + { + dlclose (handle); + return -1; + } + + + deinit_fun = (void (*)(void)) dlsym (handle, deinit_fun_name); + + (void) save_handle (name, handle, deinit_fun); + return 0; + + return_error: + + if (NULL == (err = (char *) dlerror ())) + err = "UNKNOWN"; + + dlclose (handle); + SLang_verror (SL_INTRINSIC_ERROR, + "Unable to get symbol %s from %s: %s", + name, file, err); + return -1; +} + +static void import_module (void) +{ +#define MAX_MODULE_NAME_SIZE 256 + char module_name[MAX_MODULE_NAME_SIZE]; + char symbol_name[MAX_MODULE_NAME_SIZE]; + char deinit_name[MAX_MODULE_NAME_SIZE]; + char ns_init_name[MAX_MODULE_NAME_SIZE]; + char *path; + char *file; + char *module; + char *ns = NULL; + + if (SLang_Num_Function_Args == 2) + { + if (-1 == SLang_pop_slstring (&ns)) + return; + } + + if (-1 == SLang_pop_slstring (&module)) + { + SLang_free_slstring (ns); /* NULL ok */ + return; + } + + if (strlen (module) >= MAX_MODULE_NAME_SIZE) + { + SLang_verror (SL_INVALID_PARM, "module name too long"); + SLang_free_slstring (module); + SLang_free_slstring (ns); + return; + } + + _SLsnprintf (symbol_name, sizeof(symbol_name), "init_%s_module", module); + _SLsnprintf (module_name, sizeof(module_name), "%s-module.so", module); + _SLsnprintf (deinit_name, sizeof(deinit_name), "deinit_%s_module", module); + _SLsnprintf (ns_init_name, sizeof (ns_init_name), "init_%s_module_ns", module); + + if (Module_Path != NULL) + file = SLpath_find_file_in_path (Module_Path, module_name); + else file = NULL; + + if ((file == NULL) + && (NULL != (path = _SLsecure_getenv (MODULE_PATH_ENV_NAME)))) + file = SLpath_find_file_in_path (path, module_name); + + if (file == NULL) + file = SLpath_find_file_in_path (MODULE_INSTALL_DIR, module_name); + + if (file != NULL) + { + (void) import_from_library (symbol_name, symbol_name, deinit_name, file, ns, ns_init_name); + SLfree (file); + } + else + { + /* Maybe the system loader can find it in LD_LIBRARY_PATH */ + (void) import_from_library (symbol_name, symbol_name, deinit_name, module_name, ns, ns_init_name); + } +} + +static void set_import_module_path (char *path) +{ + (void) SLang_set_module_load_path (path); +} + +static char *get_import_module_path (void) +{ + char *path; + if (Module_Path != NULL) + return Module_Path; + if (NULL != (path = _SLsecure_getenv (MODULE_PATH_ENV_NAME))) + return path; + return MODULE_INSTALL_DIR; +} + +static SLang_Intrin_Fun_Type Module_Intrins [] = +{ + MAKE_INTRINSIC_0("import", import_module, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("set_import_module_path", set_import_module_path, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("get_import_module_path", get_import_module_path, SLANG_STRING_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +#endif /* SLANG_HAS_DYNAMIC_LINKING */ + +int SLang_set_module_load_path (char *path) +{ +#if SLANG_HAS_DYNAMIC_LINKING + if (NULL == (path = SLang_create_slstring (path))) + return -1; + SLang_free_slstring (Module_Path); + Module_Path = path; + return 0; +#else + (void) path; + return -1; +#endif +} + +int SLang_init_import (void) +{ +#if SLANG_HAS_DYNAMIC_LINKING + (void) SLang_add_cleanup_function (delete_handles); + return SLadd_intrin_fun_table (Module_Intrins, "__IMPORT__"); +#else + return 0; +#endif +} diff --git a/libslang/src/slinclud.h b/libslang/src/slinclud.h new file mode 100644 index 0000000..c65812f --- /dev/null +++ b/libslang/src/slinclud.h @@ -0,0 +1,30 @@ +#ifndef _SLANG_INCLUDE_H_ +#define _SLANG_INCLUDE_H_ + +#include "config.h" +#include "sl-feat.h" + +#include +#include + +#if defined(__QNX__) && defined(__WATCOMC__) +# include +#endif + +#ifdef HAVE_STDLIB_H +# include +#endif + +#ifdef HAVE_UNISTD_H +# include +#endif + +#ifdef HAVE_MALLOC_H +# include +#endif + +#ifdef HAVE_MEMORY_H +# include +#endif + +#endif /* _SLANG_INCLUDE_H_ */ diff --git a/libslang/src/slintall.c b/libslang/src/slintall.c new file mode 100644 index 0000000..e183ed5 --- /dev/null +++ b/libslang/src/slintall.c @@ -0,0 +1,29 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +int SLang_init_all (void) +{ + if ((-1 == SLang_init_slang ()) +#if SLANG_HAS_FLOAT + || (-1 == SLang_init_slmath ()) +#endif + || (-1 == SLang_init_posix_dir ()) + || (-1 == SLang_init_posix_process ()) + || (-1 == SLang_init_stdio ()) + || (-1 == SLang_init_array ()) + || (-1 == SLang_init_posix_io ()) + || (-1 == SLang_init_ospath ()) + ) + return -1; + + return 0; +} + diff --git a/libslang/src/slistruc.c b/libslang/src/slistruc.c new file mode 100644 index 0000000..0ca0128 --- /dev/null +++ b/libslang/src/slistruc.c @@ -0,0 +1,224 @@ +/* Intrinsic Structure type implementation */ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* Intrinsic structures */ + +typedef struct +{ + char *name; + VOID_STAR addr; + SLang_IStruct_Field_Type *fields; +} +_SLang_IStruct_Type; + +static SLang_IStruct_Field_Type *istruct_pop_field (char *name, int no_readonly, VOID_STAR *addr) +{ + _SLang_IStruct_Type *s; + SLang_IStruct_Field_Type *f; + char *struct_addr; + + /* Note: There is no need to free this object */ + if (-1 == SLclass_pop_ptr_obj (SLANG_ISTRUCT_TYPE, (VOID_STAR *) &s)) + return NULL; + + if (NULL == (struct_addr = *(char **)s->addr)) + { + SLang_verror (SL_INTRINSIC_ERROR, + "%s is NULL. Unable to access field", s->name); + return NULL; + } + + f = s->fields; + while (f->field_name != NULL) + { + /* Since both these are slstrings, just test pointers */ + if (f->field_name != name) + { + f++; + continue; + } + + if (no_readonly && f->read_only) + { + SLang_verror (SL_READONLY_ERROR, + "%s.%s is read-only", s->name, name); + return NULL; + } + + *addr = (VOID_STAR) (struct_addr + f->offset); + return f; + } + + SLang_verror (SL_TYPE_MISMATCH, + "%s has no field called %s", s->name, name); + return NULL; +} + +static int istruct_sget (unsigned char type, char *name) +{ + SLang_IStruct_Field_Type *f; + VOID_STAR addr; + SLang_Class_Type *cl; + + if (NULL == (f = istruct_pop_field (name, 0, &addr))) + return -1; + + type = f->type; + cl = _SLclass_get_class (type); + + return (cl->cl_push_intrinsic)(f->type, addr); +} + +static int istruct_sput (unsigned char type, char *name) +{ + SLang_IStruct_Field_Type *f; + VOID_STAR addr; + SLang_Class_Type *cl; + + if (NULL == (f = istruct_pop_field (name, 1, &addr))) + return -1; + + type = f->type; + cl = _SLclass_get_class (type); + + return (*cl->cl_pop) (type, addr); +} + +static int istruct_push (unsigned char type, VOID_STAR ptr) +{ + _SLang_IStruct_Type *s; + + s = *(_SLang_IStruct_Type **) ptr; + if ((s == NULL) + || (s->addr == NULL) + || (*(char **) s->addr == NULL)) + return SLang_push_null (); + + return SLclass_push_ptr_obj (type, (VOID_STAR) s); +} + +static int istruct_pop (unsigned char type, VOID_STAR ptr) +{ + return SLclass_pop_ptr_obj (type, (VOID_STAR *)ptr); +} + +static void istruct_destroy (unsigned char type, VOID_STAR ptr) +{ + (void) type; + (void) ptr; +} + +/* Intrinsic struct objects are not stored in a variable. So, the address that + * is passed here is actually a pointer to the struct. So, pass its address + * to istruct_push since v is a variable. Confusing, n'est pas? + */ +static int istruct_push_intrinsic (unsigned char type, VOID_STAR v) +{ + return istruct_push (type, (VOID_STAR) &v); +} + +static int init_intrin_struct (void) +{ + SLang_Class_Type *cl; + static int initialized; + + if (initialized) + return 0; + + if (NULL == (cl = SLclass_allocate_class ("IStruct_Type"))) + return -1; + + cl->cl_pop = istruct_pop; + cl->cl_push = istruct_push; + cl->cl_sget = istruct_sget; + cl->cl_sput = istruct_sput; + cl->cl_destroy = istruct_destroy; + cl->cl_push_intrinsic = istruct_push_intrinsic; + + if (-1 == SLclass_register_class (cl, SLANG_ISTRUCT_TYPE, sizeof (_SLang_IStruct_Type *), + SLANG_CLASS_TYPE_PTR)) + return -1; + + initialized = 1; + return 0; +} + +int SLns_add_istruct_table (SLang_NameSpace_Type *ns, SLang_IStruct_Field_Type *fields, VOID_STAR addr, char *name) +{ + _SLang_IStruct_Type *s; + SLang_IStruct_Field_Type *f; + + if (-1 == init_intrin_struct ()) + return -1; + + if (addr == NULL) + { + SLang_verror (SL_INVALID_PARM, + "SLadd_istruct_table: address must be non-NULL"); + return -1; + } + + if (fields == NULL) + return -1; + + /* Make the field names slstrings so that only the pointers need to be + * compared. However, this table may have been already been added for + * another instance of the intrinsic object. So, check for the presence + * of an slstring. + */ + f = fields; + while (f->field_name != NULL) + { + char *fname; + + fname = SLang_create_slstring (f->field_name); + if (fname == NULL) + return -1; + + /* Here is the check for the slstring */ + if (f->field_name == fname) + SLang_free_slstring (fname); + else /* replace string literal with slstring */ + f->field_name = fname; + + f++; + } + + s = (_SLang_IStruct_Type *)SLmalloc (sizeof (_SLang_IStruct_Type)); + if (s == NULL) + return -1; + + memset ((char *)s, 0, sizeof (_SLang_IStruct_Type)); + if (NULL == (s->name = SLang_create_slstring (name))) + { + SLfree ((char *) s); + return -1; + } + + s->addr = addr; + s->fields = fields; + + if (-1 == SLns_add_intrinsic_variable (ns, name, (VOID_STAR) s, SLANG_ISTRUCT_TYPE, 1)) + { + SLang_free_slstring (s->name); + SLfree ((char *) s); + return -1; + } + + return 0; +} + +int SLadd_istruct_table (SLang_IStruct_Field_Type *fields, VOID_STAR addr, char *name) +{ + return SLns_add_istruct_table (NULL, fields, addr, name); +} + diff --git a/libslang/src/slkeymap.c b/libslang/src/slkeymap.c new file mode 100644 index 0000000..e3eb64b --- /dev/null +++ b/libslang/src/slkeymap.c @@ -0,0 +1,595 @@ +/* Keymap routines for SLang. The role of these keymap routines is simple: + * Just read keys from the tty and return a pointer to a keymap structure. + * That is, a keymap is simple a mapping of strings (keys from tty) to + * structures. Also included are routines for managing the keymaps. + */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* We need a define a rule for upperand lower case chars that user cannot + change! This could be a problem for international chars! */ + +#define UPPER_CASE_KEY(x) (((x) >= 'a') && ((x) <= 'z') ? (x) - 32 : (x)) +#define LOWER_CASE_KEY(x) (((x) >= 'A') && ((x) <= 'Z') ? (x) + 32 : (x)) + +int SLang_Key_TimeOut_Flag = 0; /* true if more than 1 sec has elapsed + without key in multikey sequence */ + +int SLang_Last_Key_Char; + +SLKeyMap_List_Type SLKeyMap_List[SLANG_MAX_KEYMAPS]; + +static SLang_Key_Type *malloc_key(unsigned char *str) +{ + SLang_Key_Type *neew; + + if (NULL == (neew = (SLang_Key_Type *) SLmalloc(sizeof(SLang_Key_Type)))) + return NULL; + + SLMEMSET ((char *) neew, 0, sizeof (SLang_Key_Type)); + SLMEMCPY((char *) neew->str, (char *) str, (unsigned int) *str); + return(neew); +} + +static SLKeyMap_List_Type *add_keymap (char *name, SLang_Key_Type *map) +{ + int i; + + for (i = 0; i < SLANG_MAX_KEYMAPS; i++) + { + if (SLKeyMap_List[i].keymap == NULL) + { + if (NULL == (name = SLang_create_slstring (name))) + return NULL; + + SLKeyMap_List[i].keymap = map; + SLKeyMap_List[i].name = name; + return &SLKeyMap_List[i]; + } + } + SLang_Error = SL_UNKNOWN_ERROR; + /* SLang_doerror ("Keymap quota exceeded."); */ + return NULL; +} + +FVOID_STAR SLang_find_key_function(char *name, SLKeyMap_List_Type *keymap) +{ + SLKeymap_Function_Type *fp = keymap -> functions; + char ch = *name; + + while ((fp != NULL) && (fp->name != NULL)) + { + if ((ch == *fp->name) + && (0 == strcmp(fp->name, name))) + return (FVOID_STAR) fp->f; + + fp++; + } + return NULL; +} + +#ifdef REAL_UNIX_SYSTEM +/* Expand termcap string specified by s. s as passed will have the format: + * "XY)..." where XY represents a termcap keyname. + */ +static char *process_termcap_string (char *s, char *str, int *ip, int imax) +{ + char c[3], *val; + int i; + + if ((0 == (c[0] = s[0])) + || (0 == (c[1] = s[1])) + || (s[2] != ')')) + { + SLang_verror (SL_SYNTAX_ERROR, "setkey: ^(%s is badly formed", s); + return NULL; + } + s += 3; + + c[2] = 0; + if ((NULL == (val = SLtt_tgetstr (c))) + || (*val == 0)) + return NULL; + + i = *ip; + while ((i < imax) && (*val != 0)) + { + str[i++] = *val++; + } + *ip = i; + + return s; +} +#endif + +/* convert things like "^A" to 1 etc... The 0th char is the strlen INCLUDING + * the length character itself. + */ +char *SLang_process_keystring(char *s) +{ + /* FIXME: v2.0, make this thread safe */ + static char str[32]; + unsigned char ch; + int i; + + i = 1; + while (*s != 0) + { + ch = (unsigned char) *s++; + if (ch == '^') + { + ch = *s++; + if (ch == 0) + { + if (i < 32) + str[i++] = '^'; + break; + } +#ifdef REAL_UNIX_SYSTEM + if (ch == '(') + { + s = process_termcap_string (s, str, &i, 32); + if (s == NULL) + { + str[0] = 1; + return str; + } + continue; + } +#endif + ch = UPPER_CASE_KEY(ch); + if (ch == '?') ch = 127; else ch = ch - 'A' + 1; + } + + if (i >= 32) break; + str[i++] = ch; + } + + if (i > SLANG_MAX_KEYMAP_KEY_SEQ) + { + SLang_verror (SL_INVALID_PARM, "Key sequence is too long"); + return NULL; + } + + str[0] = i; + return(str); +} + +static int key_string_compare (unsigned char *a, unsigned char *b, unsigned int len) +{ + unsigned char *amax = a + len; + int cha, chb, cha_up, chb_up; + + while (a < amax) + { + cha = *a++; + chb = *b++; + + if (cha == chb) continue; + + cha_up = UPPER_CASE_KEY(cha); + chb_up = UPPER_CASE_KEY(chb); + + if (cha_up == chb_up) + { + /* Use case-sensitive result. */ + return cha - chb; + } + /* Use case-insensitive result. */ + return cha_up - chb_up; + } + return 0; +} + +static char *Define_Key_Error = "Inconsistency in define key."; + +/* This function also performs an insertion in an ordered way. */ +static int find_the_key (char *s, SLKeyMap_List_Type *kml, SLang_Key_Type **keyp) +{ + unsigned char ch; + unsigned int str_len; + SLang_Key_Type *key, *last, *neew; + unsigned char *str; + + *keyp = NULL; + + if (NULL == (str = (unsigned char *) SLang_process_keystring(s))) + return -2; + + if (1 == (str_len = str[0])) + return 0; + + ch = str[1]; + key = kml->keymap + ch; + + if (str_len == 2) + { + if (key->next != NULL) + { + SLang_doerror (Define_Key_Error); + return -2; + } + + if (key->type == SLKEY_F_INTERPRET) + SLang_free_slstring (key->f.s); + + key->str[0] = str_len; + key->str[1] = ch; + + *keyp = key; + return 0; + } + + /* insert the key definition */ + while (1) + { + int cmp; + unsigned int key_len, len; + + last = key; + key = key->next; + + if ((key != NULL) && (key->str != NULL)) + { + len = key_len = key->str[0]; + if (len > str_len) len = str_len; + + cmp = key_string_compare (str + 1, key->str + 1, len - 1); + + if (cmp > 0) + continue; + + if (cmp == 0) + { + if (key_len != str_len) + { + SLang_doerror (Define_Key_Error); + return -2; + } + + if (key->type == SLKEY_F_INTERPRET) + SLang_free_slstring (key->f.s); + + *keyp = key; + return 0; + } + /* Drop to cmp < 0 case */ + } + + if (NULL == (neew = malloc_key(str))) return -1; + + neew -> next = key; + last -> next = neew; + + *keyp = neew; + return 0; + } +} + +/* returns -2 if inconsistent, -1 if malloc error, 0 upon success */ +int SLkm_define_key (char *s, FVOID_STAR f, SLKeyMap_List_Type *kml) +{ + SLang_Key_Type *key; + unsigned int type = SLKEY_F_INTRINSIC; + int ret; + + ret = find_the_key (s, kml, &key); + if ((ret != 0) || (key == NULL)) + return ret; + + key->type = type; + key->f.f = f; + return 0; +} + +int SLang_define_key (char *s, char *funct, SLKeyMap_List_Type *kml) +{ + SLang_Key_Type *key; + FVOID_STAR f; + int ret; + + ret = find_the_key (s, kml, &key); + if ((ret != 0) || (key == NULL)) + return ret; + + f = SLang_find_key_function(funct, kml); + + if (f == NULL) /* assume interpreted */ + { + char *str = SLang_create_slstring (funct); + if (str == NULL) return -1; + key->type = SLKEY_F_INTERPRET; + key->f.s = str; + } + else + { + key->type = SLKEY_F_INTRINSIC; + key->f.f = f; + } + return 0; +} + +int SLkm_define_keysym (char *s, unsigned int keysym, SLKeyMap_List_Type *kml) +{ + SLang_Key_Type *key; + int ret; + + ret = find_the_key (s, kml, &key); + + if ((ret != 0) || (key == NULL)) + return ret; + + key->type = SLKEY_F_KEYSYM; + key->f.keysym = keysym; + return 0; +} + +SLang_Key_Type *SLang_do_key(SLKeyMap_List_Type *kml, int (*getkey)(void)) +{ + register SLang_Key_Type *key, *next, *kmax; + unsigned int len; + unsigned char input_ch; + register unsigned char chup; + unsigned char key_ch = 0; + + SLang_Last_Key_Char = (*getkey)(); + SLang_Key_TimeOut_Flag = 0; + + if (SLANG_GETKEY_ERROR == (unsigned int) SLang_Last_Key_Char) + return NULL; + + input_ch = (unsigned char) SLang_Last_Key_Char; + + key = (SLang_Key_Type *) &((kml->keymap)[input_ch]); + + /* if the next one is null, then we know this MAY be it. */ + while (key->next == NULL) + { + if (key->type != 0) + return key; + + /* Try its opposite case counterpart */ + if (input_ch == LOWER_CASE_KEY(input_ch)) + input_ch = UPPER_CASE_KEY(input_ch); + + key = kml->keymap + input_ch; + if (key->type == 0) + return NULL; + } + + /* It appears to be a prefix character in a key sequence. */ + + len = 1; /* already read one character */ + key = key->next; /* Now we are in the key list */ + kmax = NULL; /* set to end of list */ + + while (1) + { + SLang_Key_TimeOut_Flag = 1; + SLang_Last_Key_Char = (*getkey)(); + SLang_Key_TimeOut_Flag = 0; + + len++; + + if ((SLANG_GETKEY_ERROR == (unsigned int) SLang_Last_Key_Char) + || SLKeyBoard_Quit) + break; + + input_ch = (unsigned char) SLang_Last_Key_Char; + + chup = UPPER_CASE_KEY(input_ch); + + while (key != kmax) + { + if (key->str[0] > len) + { + key_ch = key->str[len]; + if (chup == UPPER_CASE_KEY(key_ch)) + break; + } + key = key->next; + } + + if (key == kmax) break; + + /* If the input character is lowercase, check to see if there is + * a lowercase match. If so, set key to it. Note: the + * algorithm assumes the sorting performed by key_string_compare. + */ + if (input_ch != key_ch) + { + next = key->next; + while (next != kmax) + { + if (next->str[0] > len) + { + unsigned char next_ch = next->str[len]; + if (next_ch == input_ch) + { + key = next; + break; + } + if (next_ch != chup) + break; + } + next = next->next; + } + } + + /* Ok, we found the first position of a possible match. If it + * is exact, we are done. + */ + if ((unsigned int) key->str[0] == len + 1) + return key; + + /* Apparantly, there are some ambiguities. Read next key to resolve + * the ambiguity. Adjust kmax to encompass ambiguities. + */ + + next = key->next; + while (next != kmax) + { + if ((unsigned int) next->str[0] > len) + { + key_ch = next->str[len]; + if (chup != UPPER_CASE_KEY(key_ch)) + break; + } + next = next->next; + } + kmax = next; + } + + return NULL; +} + +void SLang_undefine_key(char *s, SLKeyMap_List_Type *kml) +{ + int n, i; + SLang_Key_Type *key, *next, *last, *key_root, *keymap; + unsigned char *str; + + keymap = kml -> keymap; + if (NULL == (str = (unsigned char *) SLang_process_keystring(s))) + return; + + if (0 == (n = *str++ - 1)) return; + i = *str; + + last = key_root = (SLang_Key_Type *) &(keymap[i]); + key = key_root->next; + + while (key != NULL) + { + next = key->next; + if (0 == SLMEMCMP ((char *)(key->str + 1), (char *) str, n)) + { + if (key->type == SLKEY_F_INTERPRET) + SLang_free_slstring (key->f.s); + + SLfree((char *) key); + last->next = next; + } + else last = key; + key = next; + } + + if (n == 1) + { + *key_root->str = 0; + key_root->f.f = NULL; + key_root->type = 0; + } +} + +char *SLang_make_keystring(unsigned char *s) +{ + static char buf [3 * SLANG_MAX_KEYMAP_KEY_SEQ + 1]; + char *b; + int n; + + n = *s++ - 1; + + if (n > SLANG_MAX_KEYMAP_KEY_SEQ) + { + SLang_verror (SL_INVALID_PARM, "Key sequence is too long"); + return NULL; + } + + b = buf; + while (n--) + { + if (*s < 32) + { + *b++ = '^'; + *b++ = *s + 'A' - 1; + } + else *b++ = *s; + s++; + } + *b = 0; + return(buf); +} + +static SLang_Key_Type *copy_keymap(SLKeyMap_List_Type *kml) +{ + int i; + SLang_Key_Type *neew, *old, *new_root, *km; + + if (NULL == (new_root = (SLang_Key_Type *) SLcalloc(256, sizeof(SLang_Key_Type)))) + return NULL; + + if (kml == NULL) return new_root; + km = kml->keymap; + + for (i = 0; i < 256; i++) + { + old = &(km[i]); + neew = &(new_root[i]); + + if (old->type == SLKEY_F_INTERPRET) + neew->f.s = SLang_create_slstring (old->f.s); + else + neew->f.f = old->f.f; + + neew->type = old->type; + SLMEMCPY((char *) neew->str, (char *) old->str, (unsigned int) *old->str); + + old = old->next; + while (old != NULL) + { + neew->next = malloc_key((unsigned char *) old->str); + neew = neew->next; + + if (old->type == SLKEY_F_INTERPRET) + neew->f.s = SLang_create_slstring (old->f.s); + else + neew->f.f = old->f.f; + + neew->type = old->type; + old = old->next; + } + neew->next = NULL; + } + return(new_root); +} + +SLKeyMap_List_Type *SLang_create_keymap(char *name, SLKeyMap_List_Type *map) +{ + SLang_Key_Type *neew; + SLKeyMap_List_Type *new_map; + + if ((NULL == (neew = copy_keymap(map))) + || (NULL == (new_map = add_keymap(name, neew)))) return NULL; + + if (map != NULL) new_map -> functions = map -> functions; + + return new_map; +} + +SLKeyMap_List_Type *SLang_find_keymap(char *name) +{ + SLKeyMap_List_Type *kmap, *kmap_max; + + kmap = SLKeyMap_List; + kmap_max = kmap + SLANG_MAX_KEYMAPS; + + while (kmap < kmap_max) + { + if ((kmap->name != NULL) + && (0 == strcmp (kmap->name, name))) + return kmap; + + kmap++; + } + return NULL; +} diff --git a/libslang/src/slkeypad.c b/libslang/src/slkeypad.c new file mode 100644 index 0000000..8984575 --- /dev/null +++ b/libslang/src/slkeypad.c @@ -0,0 +1,182 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static SLKeyMap_List_Type *Keymap_List; + +static int (*Getkey_Function)(void); + +int SLkp_init (void) +{ + char esc_seq[10]; + int i; + + if (NULL == (Keymap_List = SLang_create_keymap ("_SLKeypad", NULL))) + return -1; + + esc_seq[1] = 0; + for (i = 1; i < 256; i++) + { + esc_seq[0] = (char) i; + SLkm_define_keysym (esc_seq, i, Keymap_List); + } + + /* Now add most common ones. */ +#ifndef IBMPC_SYSTEM + SLkm_define_keysym ("^@", 0, Keymap_List); + + SLkm_define_keysym ("\033[A", SL_KEY_UP, Keymap_List); + SLkm_define_keysym ("\033OA", SL_KEY_UP, Keymap_List); + SLkm_define_keysym ("\033[B", SL_KEY_DOWN, Keymap_List); + SLkm_define_keysym ("\033OB", SL_KEY_DOWN, Keymap_List); + SLkm_define_keysym ("\033[C", SL_KEY_RIGHT, Keymap_List); + SLkm_define_keysym ("\033OC", SL_KEY_RIGHT, Keymap_List); + SLkm_define_keysym ("\033[D", SL_KEY_LEFT, Keymap_List); + SLkm_define_keysym ("\033OD", SL_KEY_LEFT, Keymap_List); + SLkm_define_keysym ("\033[F", SL_KEY_END, Keymap_List); + SLkm_define_keysym ("\033OF", SL_KEY_END, Keymap_List); + SLkm_define_keysym ("\033[H", SL_KEY_HOME, Keymap_List); + SLkm_define_keysym ("\033OH", SL_KEY_HOME, Keymap_List); + SLkm_define_keysym ("\033[2~", SL_KEY_IC, Keymap_List); + SLkm_define_keysym ("\033[3~", SL_KEY_DELETE, Keymap_List); + SLkm_define_keysym ("\033[5~", SL_KEY_PPAGE, Keymap_List); + SLkm_define_keysym ("\033[6~", SL_KEY_NPAGE, Keymap_List); + SLkm_define_keysym ("\033[7~", SL_KEY_HOME, Keymap_List); + SLkm_define_keysym ("\033[8~", SL_KEY_END, Keymap_List); +#else + /* Note: This will not work if SLgetkey_map_to_ansi (1) has + * been called. + */ + SLkm_define_keysym ("^@\x48", SL_KEY_UP, Keymap_List ); + SLkm_define_keysym ("^@\x50", SL_KEY_DOWN, Keymap_List ); + SLkm_define_keysym ("^@\x4d", SL_KEY_RIGHT, Keymap_List ); + SLkm_define_keysym ("^@\x4b", SL_KEY_LEFT, Keymap_List ); + SLkm_define_keysym ("^@\x47", SL_KEY_HOME, Keymap_List ); + SLkm_define_keysym ("^@\x49", SL_KEY_PPAGE, Keymap_List ); + SLkm_define_keysym ("^@\x51", SL_KEY_NPAGE, Keymap_List ); + SLkm_define_keysym ("^@\x4f", SL_KEY_END, Keymap_List ); + SLkm_define_keysym ("^@\x52", SL_KEY_IC, Keymap_List ); + SLkm_define_keysym ("^@\x53", SL_KEY_DELETE, Keymap_List ); + + SLkm_define_keysym ("\xE0\x48", SL_KEY_UP, Keymap_List ); + SLkm_define_keysym ("\xE0\x50", SL_KEY_DOWN, Keymap_List ); + SLkm_define_keysym ("\xE0\x4d", SL_KEY_RIGHT, Keymap_List ); + SLkm_define_keysym ("\xE0\x4b", SL_KEY_LEFT, Keymap_List ); + SLkm_define_keysym ("\xE0\x47", SL_KEY_HOME, Keymap_List ); + SLkm_define_keysym ("\xE0\x49", SL_KEY_PPAGE, Keymap_List ); + SLkm_define_keysym ("\xE0\x51", SL_KEY_NPAGE, Keymap_List ); + SLkm_define_keysym ("\xE0\x4f", SL_KEY_END, Keymap_List ); + SLkm_define_keysym ("\xE0\x52", SL_KEY_IC, Keymap_List ); + SLkm_define_keysym ("\xE0\x53", SL_KEY_DELETE, Keymap_List ); + + strcpy (esc_seq, "^@ "); /* guarantees esc_seq[3] = 0. */ + + for (i = 0x3b; i < 0x45; i++) + { + esc_seq [2] = i; + SLkm_define_keysym (esc_seq, SL_KEY_F(i - 0x3a), Keymap_List); + } + esc_seq[2] = 0x57; SLkm_define_keysym (esc_seq, SL_KEY_F(11), Keymap_List); + esc_seq[2] = 0x58; SLkm_define_keysym (esc_seq, SL_KEY_F(12), Keymap_List); +#endif + +#ifdef REAL_UNIX_SYSTEM + strcpy (esc_seq, "^(kX)"); + for (i = 0; i <= 9; i++) + { + esc_seq[3] = '0' + i; + SLkm_define_keysym (esc_seq, SL_KEY_F(i), Keymap_List); + } + SLkm_define_keysym ("^(k;)", SL_KEY_F(10), Keymap_List); + SLkm_define_keysym ("^(F1)", SL_KEY_F(11), Keymap_List); + SLkm_define_keysym ("^(F2)", SL_KEY_F(12), Keymap_List); + + SLkm_define_keysym ("^(ku)", SL_KEY_UP, Keymap_List); + SLkm_define_keysym ("^(kd)", SL_KEY_DOWN, Keymap_List); + SLkm_define_keysym ("^(kl)", SL_KEY_LEFT, Keymap_List); + SLkm_define_keysym ("^(kr)", SL_KEY_RIGHT, Keymap_List); + SLkm_define_keysym ("^(kP)", SL_KEY_PPAGE, Keymap_List); + SLkm_define_keysym ("^(kN)", SL_KEY_NPAGE, Keymap_List); + SLkm_define_keysym ("^(kh)", SL_KEY_HOME, Keymap_List); + SLkm_define_keysym ("^(@7)", SL_KEY_END, Keymap_List); + SLkm_define_keysym ("^(K1)", SL_KEY_A1, Keymap_List); + SLkm_define_keysym ("^(K3)", SL_KEY_A3, Keymap_List); + SLkm_define_keysym ("^(K2)", SL_KEY_B2, Keymap_List); + SLkm_define_keysym ("^(K4)", SL_KEY_C1, Keymap_List); + SLkm_define_keysym ("^(K5)", SL_KEY_C3, Keymap_List); + SLkm_define_keysym ("^(%0)", SL_KEY_REDO, Keymap_List); + SLkm_define_keysym ("^(&8)", SL_KEY_UNDO, Keymap_List); + SLkm_define_keysym ("^(kb)", SL_KEY_BACKSPACE, Keymap_List); + SLkm_define_keysym ("^(@8)", SL_KEY_ENTER, Keymap_List); + SLkm_define_keysym ("^(kD)", SL_KEY_DELETE, Keymap_List); +#endif + + if (SLang_Error) + return -1; + return 0; +} + +int SLkp_getkey (void) +{ + SLang_Key_Type *key; + + if (Getkey_Function == NULL) + Getkey_Function = (int (*)(void)) SLang_getkey; + + key = SLang_do_key (Keymap_List, Getkey_Function); + if ((key == NULL) || (key->type != SLKEY_F_KEYSYM)) + { + SLang_flush_input (); + return SL_KEY_ERR; + } + + return key->f.keysym; +} + +int SLkp_define_keysym (char *keystr, unsigned int keysym) +{ + if (SLkm_define_keysym (keystr, keysym, Keymap_List) < 0) + return -1; + + return 0; +} + +void SLkp_set_getkey_function (int (*f)(void)) +{ + if (f == NULL) + Getkey_Function = (int (*)(void)) SLang_getkey; + else + Getkey_Function = f; +} + +#if 0 +int main (int argc, char **argv) +{ + int ch; + + SLtt_get_terminfo (); + + if (-1 == SLkp_init ()) + return 1; + + SLang_init_tty (-1, 0, 0); + + while ('q' != (ch = SLkp_getkey ())) + { + fprintf (stdout, "Keycode = %d\r\n", ch); + fflush (stdout); + } + + SLang_reset_tty (); + + return 0; +} +#endif + diff --git a/libslang/src/sllimits.h b/libslang/src/sllimits.h new file mode 100644 index 0000000..8185743 --- /dev/null +++ b/libslang/src/sllimits.h @@ -0,0 +1,73 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +/* sllimits.h */ + +/* slstring.c: Size of the hash table used for strings (prime numbers) */ +#ifdef __MSDOS_16BIT__ +# define SLSTRING_HASH_TABLE_SIZE 601 +# define SLASSOC_HASH_TABLE_SIZE 601 +#else +# define SLSTRING_HASH_TABLE_SIZE 2909 +# define SLASSOC_HASH_TABLE_SIZE 2909 +#endif + +/* slang.c: maximum size of run time stack */ +#ifdef __MSDOS_16BIT__ +# define SLANG_MAX_STACK_LEN 500 +#else +# define SLANG_MAX_STACK_LEN 2500 +#endif + +/* slang.c: This sets the size on the depth of function calls */ +#ifdef __MSDOS_16BIT__ +# define SLANG_MAX_RECURSIVE_DEPTH 50 +#else +# define SLANG_MAX_RECURSIVE_DEPTH 2500 +#endif + +/* slang.c: Size of the stack used for local variables */ +#ifdef __MSDOS_16BIT__ +# define SLANG_MAX_LOCAL_STACK 200 +#else +# define SLANG_MAX_LOCAL_STACK 4096 +#endif + +/* slang.c: The size of the hash table used for local and global objects. + * These should be prime numbers. + */ +#define SLGLOBALS_HASH_TABLE_SIZE 2909 +#define SLLOCALS_HASH_TABLE_SIZE 73 +#define SLSTATIC_HASH_TABLE_SIZE 73 + +/* Size of the keyboard buffer use by the ungetkey routines */ +#ifdef __MSDOS_16BIT__ +# define SL_MAX_INPUT_BUFFER_LEN 40 +#else +# define SL_MAX_INPUT_BUFFER_LEN 1024 +#endif + +/* Maximum number of nested switch statements */ +#define SLANG_MAX_NESTED_SWITCH 10 + +/* Size of the block stack (used in byte-compiling) */ +#define SLANG_MAX_BLOCK_STACK_LEN 50 + +/* slfile.c: Max number of open file pointers */ +#ifdef __MSDOS_16BIT__ +# define SL_MAX_FILES 32 +#else +# define SL_MAX_FILES 256 +#endif + +#if !defined(__MSDOS_16BIT__) +# define SLTT_MAX_SCREEN_COLS 512 +# define SLTT_MAX_SCREEN_ROWS 512 +#else +# define SLTT_MAX_SCREEN_ROWS 64 +# define SLTT_MAX_SCREEN_COLS 75 +#endif + diff --git a/libslang/src/slmalloc.c b/libslang/src/slmalloc.c new file mode 100644 index 0000000..7e7cc2e --- /dev/null +++ b/libslang/src/slmalloc.c @@ -0,0 +1,165 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#ifdef SL_MALLOC_DEBUG +# undef SL_MALLOC_DEBUG +#endif + +#include "slang.h" +#include "_slang.h" + +#ifdef __alpha +# define Chunk 8 +#else +# define Chunk 4 +#endif + +static long Total_Allocated; +static long Max_Single_Allocation; +static long Max_Allocated; +/* #define SLDEBUG_DOUT */ + +#ifdef SLDEBUG_DOUT +static FILE *dout; +#endif + +void SLmalloc_dump_statistics (void) +{ +#ifdef SLDEBUG_DOUT + fflush (dout); +#endif + fprintf (stderr, "Total Allocated: %ld\nHighest single allocation: %ld\nHighest Total Allocated:%ld\n", + Total_Allocated, Max_Single_Allocation, Max_Allocated); +} + +static void register_at_exit_fun (void) +{ + static int is_registered = 0; + if (is_registered) + return; + is_registered = 1; + +#ifdef SLDEBUG_DOUT + if (dout == NULL) dout = fopen ("malloc.out", "w"); +#endif + SLang_add_cleanup_function (SLmalloc_dump_statistics); +} + +static void fixup (unsigned char *p, unsigned long n, char *what) +{ + register_at_exit_fun (); + + p += Chunk; + *(p - 4)= (unsigned char) ((n >> 24) & 0xFF); + *(p - 3) = (unsigned char) ((n >> 16) & 0xFF); + *(p - 2) = (unsigned char) ((n >> 8) & 0xFF); + *(p - 1) = (unsigned char) (n & 0xFF); + *(p + (int) n) = 27; + *(p + (int) (n + 1)) = 182; + *(p + (int) (n + 2)) = 81; + *(p + (int) (n + 3)) = 86; + Total_Allocated += (long) n; + if (Total_Allocated > Max_Allocated) Max_Allocated = Total_Allocated; + if ((long) n > Max_Single_Allocation) + Max_Single_Allocation = (long) n; + +#ifdef SLDEBUG_DOUT + fprintf (dout, "ALLOC: %s\t%p %ld\n", what, p, (long) n); +#else + (void) what; +#endif +} + +static void SLmalloc_doerror (char *buf) +{ + SLang_doerror (buf); +} + +static int check_memory (unsigned char *p, char *what) +{ + char buf[128]; + unsigned long n; + + register_at_exit_fun (); + + n = ((unsigned long) *(p - 4)) << 24; + n |= ((unsigned long) *(p - 3)) << 16; + n |= ((unsigned long) *(p - 2)) << 8; + n |= (unsigned long) *(p - 1); + + if (n == 0xFFFFFFFFUL) + { + sprintf (buf, "%s: %p: Already FREE! Abort NOW.", what, p - Chunk); + SLmalloc_doerror (buf); + return -1; + } + + if ((*(p + (int) n) != 27) + || (*(p + (int) (n + 1)) != 182) + || (*(p + (int) (n + 2)) != 81) + || (*(p + (int) (n + 3)) != 86)) + { + sprintf (buf, "\007%s: %p: Memory corrupt! Abort NOW.", what, p); + SLmalloc_doerror (buf); + return -1; + } + + *(p - 4) = *(p - 3) = *(p - 2) = *(p - 1) = 0xFF; + + Total_Allocated -= (long) n; + if (Total_Allocated < 0) + { + sprintf (buf, "\007%s: %p\nFreed %ld, Allocated is: %ld!\n", + what, p, (long) n, Total_Allocated); + SLang_doerror (buf); + } +#ifdef SLDEBUG_DOUT + fprintf (dout, "FREE: %s:\t%p %ld\n", what, p, (long) n); +#endif + return 0; +} + +void SLdebug_free (char *p) +{ + if (p == NULL) return; + if (-1 == check_memory ((unsigned char *) p, "FREE")) return; + + SLFREE (p - Chunk); +} + +char *SLdebug_malloc (unsigned long n) +{ + char *p; + + if ((p = (char *) SLMALLOC (n + 2 * Chunk)) == NULL) return NULL; + + fixup ((unsigned char *) p, n, "MALLOC"); + return p + Chunk; +} + +char *SLdebug_realloc (char *p, unsigned long n) +{ + if (-1 == check_memory ((unsigned char *) p, "REALLOC")) return NULL; + if ((p = (char *) SLREALLOC (p - Chunk, n + 2 * Chunk)) == NULL) return NULL; + fixup ((unsigned char *) p, n, "REALLOC"); + return p + Chunk; +} + +char *SLdebug_calloc (unsigned long n, unsigned long size) +{ + char *p; + int m; + + /* This is tough -- hope this is a good assumption!! */ + if (size >= Chunk) m = 1; else m = Chunk; + + if ((p = (char *) SLCALLOC (n + m + m, size)) == NULL) return NULL; + fixup ((unsigned char *) p, size * n, "CALLOC"); + return p + Chunk; +} + diff --git a/libslang/src/slmath.c b/libslang/src/slmath.c new file mode 100644 index 0000000..37d755a --- /dev/null +++ b/libslang/src/slmath.c @@ -0,0 +1,570 @@ +/* sin, cos, etc, for S-Lang */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include + +#if SLANG_HAS_FLOAT +#include "slang.h" +#include "_slang.h" + +#ifdef PI +# undef PI +#endif +#define PI 3.14159265358979323846264338327950288 + +#if defined(__unix__) +#include +#include + +#define SIGNAL SLsignal + +static void math_floating_point_exception (int sig) +{ + sig = errno; + if (SLang_Error == 0) SLang_Error = SL_FLOATING_EXCEPTION; + (void) SIGNAL (SIGFPE, math_floating_point_exception); + errno = sig; +} +#endif + +double SLmath_hypot (double x, double y) +{ + double fr, fi, ratio; + + fr = fabs(x); + fi = fabs(y); + + if (fr > fi) + { + ratio = y / x; + x = fr * sqrt (1.0 + ratio * ratio); + } + else if (fi == 0.0) x = 0.0; + else + { + ratio = x / y; + x = fi * sqrt (1.0 + ratio * ratio); + } + + return x; +} + +/* usage here is a1 a2 ... an n x ==> a1x^n + a2 x ^(n - 1) + ... + an */ +static double math_poly (void) +{ + int n; + double xn = 1.0, sum = 0.0; + double an, x; + + if ((SLang_pop_double(&x, NULL, NULL)) + || (SLang_pop_integer(&n))) return(0.0); + + while (n-- > 0) + { + if (SLang_pop_double(&an, NULL, NULL)) break; + sum += an * xn; + xn = xn * x; + } + return (double) sum; +} + +static int double_math_op_result (int op, unsigned char a, unsigned char *b) +{ + (void) op; + + if (a != SLANG_FLOAT_TYPE) + *b = SLANG_DOUBLE_TYPE; + else + *b = a; + + return 1; +} + +#ifdef HAVE_ASINH +# define ASINH_FUN asinh +#else +# define ASINH_FUN my_asinh +static double my_asinh (double x) +{ + return log (x + sqrt (x*x + 1)); +} +#endif +#ifdef HAVE_ACOSH +# define ACOSH_FUN acosh +#else +# define ACOSH_FUN my_acosh +static double my_acosh (double x) +{ + return log (x + sqrt(x*x - 1)); /* x >= 1 */ +} +#endif +#ifdef HAVE_ATANH +# define ATANH_FUN atanh +#else +# define ATANH_FUN my_atanh +static double my_atanh (double x) +{ + return 0.5 * log ((1.0 + x)/(1.0 - x)); /* 0 <= x^2 < 1 */ +} +#endif + +static int double_math_op (int op, + unsigned char type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + double *a, *b; + unsigned int i; + double (*fun) (double); + + (void) type; + a = (double *) ap; + b = (double *) bp; + + switch (op) + { + default: + return 0; + + case SLMATH_SINH: + fun = sinh; + break; + case SLMATH_COSH: + fun = cosh; + break; + case SLMATH_TANH: + fun = tanh; + break; + case SLMATH_TAN: + fun = tan; + break; + case SLMATH_ASIN: + fun = asin; + break; + case SLMATH_ACOS: + fun = acos; + break; + case SLMATH_ATAN: + fun = atan; + break; + case SLMATH_EXP: + fun = exp; + break; + case SLMATH_LOG: + fun = log; + break; + case SLMATH_LOG10: + fun = log10; + break; + case SLMATH_SQRT: + fun = sqrt; + break; + case SLMATH_SIN: + fun = sin; + break; + case SLMATH_COS: + fun = cos; + break; + + case SLMATH_ASINH: + fun = ASINH_FUN; + break; + case SLMATH_ATANH: + fun = ATANH_FUN; + break; + case SLMATH_ACOSH: + fun = ACOSH_FUN; + break; + + case SLMATH_CONJ: + case SLMATH_REAL: + for (i = 0; i < na; i++) + b[i] = a[i]; + return 1; + case SLMATH_IMAG: + for (i = 0; i < na; i++) + b[i] = 0.0; + return 1; + } + + for (i = 0; i < na; i++) + b[i] = (*fun) (a[i]); + + return 1; +} + +static int float_math_op (int op, + unsigned char type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + float *a, *b; + unsigned int i; + double (*fun) (double); + + (void) type; + a = (float *) ap; + b = (float *) bp; + + + switch (op) + { + default: + return 0; + + case SLMATH_SINH: + fun = sinh; + break; + case SLMATH_COSH: + fun = cosh; + break; + case SLMATH_TANH: + fun = tanh; + break; + case SLMATH_TAN: + fun = tan; + break; + case SLMATH_ASIN: + fun = asin; + break; + case SLMATH_ACOS: + fun = acos; + break; + case SLMATH_ATAN: + fun = atan; + break; + case SLMATH_EXP: + fun = exp; + break; + case SLMATH_LOG: + fun = log; + break; + case SLMATH_LOG10: + fun = log10; + break; + case SLMATH_SQRT: + fun = sqrt; + break; + case SLMATH_SIN: + fun = sin; + break; + case SLMATH_COS: + fun = cos; + break; + + case SLMATH_ASINH: + fun = ASINH_FUN; + break; + case SLMATH_ATANH: + fun = ATANH_FUN; + break; + case SLMATH_ACOSH: + fun = ACOSH_FUN; + break; + + case SLMATH_CONJ: + case SLMATH_REAL: + for (i = 0; i < na; i++) + b[i] = a[i]; + return 1; + case SLMATH_IMAG: + for (i = 0; i < na; i++) + b[i] = 0.0; + return 1; + } + + for (i = 0; i < na; i++) + b[i] = (float) (*fun) ((double) a[i]); + + return 1; +} + +static int generic_math_op (int op, + unsigned char type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + double *b; + unsigned int i; + SLang_To_Double_Fun_Type to_double; + double (*fun) (double); + unsigned int da; + char *a; + + if (NULL == (to_double = SLarith_get_to_double_fun (type, &da))) + return 0; + + b = (double *) bp; + a = (char *) ap; + + switch (op) + { + default: + return 0; + + case SLMATH_SINH: + fun = sinh; + break; + case SLMATH_COSH: + fun = cosh; + break; + case SLMATH_TANH: + fun = tanh; + break; + case SLMATH_TAN: + fun = tan; + break; + case SLMATH_ASIN: + fun = asin; + break; + case SLMATH_ACOS: + fun = acos; + break; + case SLMATH_ATAN: + fun = atan; + break; + case SLMATH_EXP: + fun = exp; + break; + case SLMATH_LOG: + fun = log; + break; + case SLMATH_LOG10: + fun = log10; + break; + case SLMATH_SQRT: + fun = sqrt; + break; + case SLMATH_SIN: + fun = sin; + break; + case SLMATH_COS: + fun = cos; + break; + + case SLMATH_ASINH: + fun = ASINH_FUN; + break; + case SLMATH_ATANH: + fun = ATANH_FUN; + break; + case SLMATH_ACOSH: + fun = ACOSH_FUN; + break; + + + case SLMATH_CONJ: + case SLMATH_REAL: + for (i = 0; i < na; i++) + { + b[i] = to_double((VOID_STAR) a); + a += da; + } + return 1; + + case SLMATH_IMAG: + for (i = 0; i < na; i++) + b[i] = 0.0; + return 1; + } + + for (i = 0; i < na; i++) + { + b[i] = (*fun) (to_double ((VOID_STAR) a)); + a += da; + } + + return 1; +} + +#if SLANG_HAS_COMPLEX +static int complex_math_op_result (int op, unsigned char a, unsigned char *b) +{ + (void) a; + switch (op) + { + default: + *b = SLANG_COMPLEX_TYPE; + break; + + case SLMATH_REAL: + case SLMATH_IMAG: + *b = SLANG_DOUBLE_TYPE; + break; + } + return 1; +} + +static int complex_math_op (int op, + unsigned char type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + double *a, *b; + unsigned int i; + unsigned int na2 = na * 2; + double *(*fun) (double *, double *); + + (void) type; + a = (double *) ap; + b = (double *) bp; + + switch (op) + { + default: + return 0; + + case SLMATH_REAL: + for (i = 0; i < na; i++) + b[i] = a[2 * i]; + return 1; + + case SLMATH_IMAG: + for (i = 0; i < na; i++) + b[i] = a[2 * i + 1]; + return 1; + + case SLMATH_CONJ: + for (i = 0; i < na2; i += 2) + { + b[i] = a[i]; + b[i+1] = -a[i+1]; + } + return 1; + + case SLMATH_ATANH: + fun = SLcomplex_atanh; + break; + case SLMATH_ACOSH: + fun = SLcomplex_acosh; + break; + case SLMATH_ASINH: + fun = SLcomplex_asinh; + break; + case SLMATH_EXP: + fun = SLcomplex_exp; + break; + case SLMATH_LOG: + fun = SLcomplex_log; + break; + case SLMATH_LOG10: + fun = SLcomplex_log10; + break; + case SLMATH_SQRT: + fun = SLcomplex_sqrt; + break; + case SLMATH_SIN: + fun = SLcomplex_sin; + break; + case SLMATH_COS: + fun = SLcomplex_cos; + break; + case SLMATH_SINH: + fun = SLcomplex_sinh; + break; + case SLMATH_COSH: + fun = SLcomplex_cosh; + break; + case SLMATH_TANH: + fun = SLcomplex_tanh; + break; + case SLMATH_TAN: + fun = SLcomplex_tan; + break; + case SLMATH_ASIN: + fun = SLcomplex_asin; + break; + case SLMATH_ACOS: + fun = SLcomplex_acos; + break; + case SLMATH_ATAN: + fun = SLcomplex_atan; + break; + } + + for (i = 0; i < na2; i += 2) + (void) (*fun) (b + i, a + i); + + return 1; +} +#endif + +static SLang_DConstant_Type DConst_Table [] = +{ + MAKE_DCONSTANT("E", 2.718281828459045), + MAKE_DCONSTANT("PI", 3.14159265358979323846264338327950288), + SLANG_END_DCONST_TABLE +}; + +static SLang_Math_Unary_Type SLmath_Table [] = +{ + MAKE_MATH_UNARY("sinh", SLMATH_SINH), + MAKE_MATH_UNARY("asinh", SLMATH_ASINH), + MAKE_MATH_UNARY("cosh", SLMATH_COSH), + MAKE_MATH_UNARY("acosh", SLMATH_ACOSH), + MAKE_MATH_UNARY("tanh", SLMATH_TANH), + MAKE_MATH_UNARY("atanh", SLMATH_ATANH), + MAKE_MATH_UNARY("sin", SLMATH_SIN), + MAKE_MATH_UNARY("cos", SLMATH_COS), + MAKE_MATH_UNARY("tan", SLMATH_TAN), + MAKE_MATH_UNARY("atan", SLMATH_ATAN), + MAKE_MATH_UNARY("acos", SLMATH_ACOS), + MAKE_MATH_UNARY("asin", SLMATH_ASIN), + MAKE_MATH_UNARY("exp", SLMATH_EXP), + MAKE_MATH_UNARY("log", SLMATH_LOG), + MAKE_MATH_UNARY("sqrt", SLMATH_SQRT), + MAKE_MATH_UNARY("log10", SLMATH_LOG10), +#if SLANG_HAS_COMPLEX + MAKE_MATH_UNARY("Real", SLMATH_REAL), + MAKE_MATH_UNARY("Imag", SLMATH_IMAG), + MAKE_MATH_UNARY("Conj", SLMATH_CONJ), +#endif + SLANG_END_MATH_UNARY_TABLE +}; + +static SLang_Intrin_Fun_Type SLang_Math_Table [] = +{ + MAKE_INTRINSIC_0("polynom", math_poly, SLANG_DOUBLE_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +int SLang_init_slmath (void) +{ + unsigned char *int_types; + +#if defined(__unix__) + (void) SIGNAL (SIGFPE, math_floating_point_exception); +#endif + +#if SLANG_HAS_COMPLEX + if (-1 == _SLinit_slcomplex ()) + return -1; +#endif + int_types = _SLarith_Arith_Types; + + while (*int_types != SLANG_FLOAT_TYPE) + { + if (-1 == SLclass_add_math_op (*int_types, generic_math_op, double_math_op_result)) + return -1; + int_types++; + } + + if ((-1 == SLclass_add_math_op (SLANG_FLOAT_TYPE, float_math_op, double_math_op_result)) + || (-1 == SLclass_add_math_op (SLANG_DOUBLE_TYPE, double_math_op, double_math_op_result)) +#if SLANG_HAS_COMPLEX + || (-1 == SLclass_add_math_op (SLANG_COMPLEX_TYPE, complex_math_op, complex_math_op_result)) +#endif + ) + return -1; + + if ((-1 == SLadd_math_unary_table (SLmath_Table, "__SLMATH__")) + || (-1 == SLadd_intrin_fun_table (SLang_Math_Table, NULL)) + || (-1 == SLadd_dconstant_table (DConst_Table, NULL))) + return -1; + + return 0; +} +#endif /* SLANG_HAS_FLOAT */ diff --git a/libslang/src/slmemchr.c b/libslang/src/slmemchr.c new file mode 100644 index 0000000..2b69ab8 --- /dev/null +++ b/libslang/src/slmemchr.c @@ -0,0 +1,47 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are fast memcpy, memset routines. When available, I + use system rouines. For msdos, I use inline assembly. */ + +/* The current versions only work in the forward direction only!! */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +char *SLmemchr(register char *p, register char c, register int n) +{ + int n2; + register char *pmax; + + pmax = p + (n - 32); + + while (p <= pmax) + { + if ((*p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c)) + return p; + p++; + } + + n2 = n % 32; + + while (n2--) + { + if (*p == c) return p; + p++; + } + return(NULL); +} diff --git a/libslang/src/slmemcmp.c b/libslang/src/slmemcmp.c new file mode 100644 index 0000000..58d121e --- /dev/null +++ b/libslang/src/slmemcmp.c @@ -0,0 +1,76 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are fast memcpy, memset routines. When available, I + use system rouines. For msdos, I use inline assembly. */ + +/* The current versions only work in the forward direction only!! */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* This is an UNSIGNED comparison designed for systems that either do not have +* this function or performed a signed comparison (SunOS) +*/ +int SLmemcmp(register char *s1, register char *s2, int n) +{ + register int cmp; + register char *s1max; + + s1max = s1 + (n - 32); + + while (s1 <= s1max) + { + if (*s1 != *s2) return ((unsigned char) *s1 - (unsigned char) *s2); + if (*(s1 + 1) != *(s2 + 1)) return ((unsigned char) *(s1 + 1) - (unsigned char) *(s2 + 1)); + if (*(s1 + 2) != *(s2 + 2)) return ((unsigned char) *(s1 + 2) - (unsigned char) *(s2 + 2)); + if (*(s1 + 3) != *(s2 + 3)) return ((unsigned char) *(s1 + 3) - (unsigned char) *(s2 + 3)); + if (*(s1 + 4) != *(s2 + 4)) return ((unsigned char) *(s1 + 4) - (unsigned char) *(s2 + 4)); + if (*(s1 + 5) != *(s2 + 5)) return ((unsigned char) *(s1 + 5) - (unsigned char) *(s2 + 5)); + if (*(s1 + 6) != *(s2 + 6)) return ((unsigned char) *(s1 + 6) - (unsigned char) *(s2 + 6)); + if (*(s1 + 7) != *(s2 + 7)) return ((unsigned char) *(s1 + 7) - (unsigned char) *(s2 + 7)); + if (*(s1 + 8) != *(s2 + 8)) return ((unsigned char) *(s1 + 8) - (unsigned char) *(s2 + 8)); + if (*(s1 + 9) != *(s2 + 9)) return ((unsigned char) *(s1 + 9) - (unsigned char) *(s2 + 9)); + if (*(s1 + 10) != *(s2 + 10)) return ((unsigned char) *(s1 + 10) - (unsigned char) *(s2 + 10)); + if (*(s1 + 11) != *(s2 + 11)) return ((unsigned char) *(s1 + 11) - (unsigned char) *(s2 + 11)); + if (*(s1 + 12) != *(s2 + 12)) return ((unsigned char) *(s1 + 12) - (unsigned char) *(s2 + 12)); + if (*(s1 + 13) != *(s2 + 13)) return ((unsigned char) *(s1 + 13) - (unsigned char) *(s2 + 13)); + if (*(s1 + 14) != *(s2 + 14)) return ((unsigned char) *(s1 + 14) - (unsigned char) *(s2 + 14)); + if (*(s1 + 15) != *(s2 + 15)) return ((unsigned char) *(s1 + 15) - (unsigned char) *(s2 + 15)); + if (*(s1 + 16) != *(s2 + 16)) return ((unsigned char) *(s1 + 16) - (unsigned char) *(s2 + 16)); + if (*(s1 + 17) != *(s2 + 17)) return ((unsigned char) *(s1 + 17) - (unsigned char) *(s2 + 17)); + if (*(s1 + 18) != *(s2 + 18)) return ((unsigned char) *(s1 + 18) - (unsigned char) *(s2 + 18)); + if (*(s1 + 19) != *(s2 + 19)) return ((unsigned char) *(s1 + 19) - (unsigned char) *(s2 + 19)); + if (*(s1 + 20) != *(s2 + 20)) return ((unsigned char) *(s1 + 20) - (unsigned char) *(s2 + 20)); + if (*(s1 + 21) != *(s2 + 21)) return ((unsigned char) *(s1 + 21) - (unsigned char) *(s2 + 21)); + if (*(s1 + 22) != *(s2 + 22)) return ((unsigned char) *(s1 + 22) - (unsigned char) *(s2 + 22)); + if (*(s1 + 23) != *(s2 + 23)) return ((unsigned char) *(s1 + 23) - (unsigned char) *(s2 + 23)); + if (*(s1 + 24) != *(s2 + 24)) return ((unsigned char) *(s1 + 24) - (unsigned char) *(s2 + 24)); + if (*(s1 + 25) != *(s2 + 25)) return ((unsigned char) *(s1 + 25) - (unsigned char) *(s2 + 25)); + if (*(s1 + 26) != *(s2 + 26)) return ((unsigned char) *(s1 + 26) - (unsigned char) *(s2 + 26)); + if (*(s1 + 27) != *(s2 + 27)) return ((unsigned char) *(s1 + 27) - (unsigned char) *(s2 + 27)); + if (*(s1 + 28) != *(s2 + 28)) return ((unsigned char) *(s1 + 28) - (unsigned char) *(s2 + 28)); + if (*(s1 + 29) != *(s2 + 29)) return ((unsigned char) *(s1 + 29) - (unsigned char) *(s2 + 29)); + if (*(s1 + 30) != *(s2 + 30)) return ((unsigned char) *(s1 + 30) - (unsigned char) *(s2 + 30)); + if (*(s1 + 31) != *(s2 + 31)) return ((unsigned char) *(s1 + 31) - (unsigned char) *(s2 + 31)); + s1 += 32; s2 += 32; + } + + s1max = s1 + (n % 32); + + while (s1 < s1max) + { + cmp = (unsigned char) *s1 - (unsigned char) *s2; + if (cmp) return(cmp); + s1++; + s2++; + } + + return(0); +} diff --git a/libslang/src/slmemcpy.c b/libslang/src/slmemcpy.c new file mode 100644 index 0000000..31136d6 --- /dev/null +++ b/libslang/src/slmemcpy.c @@ -0,0 +1,49 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are fast memcpy, memset routines. When available, I + use system rouines. For msdos, I use inline assembly. */ + +/* The current versions only work in the forward direction only!! */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +char *SLmemcpy(char *s1, char *s2, int n) +{ +#if defined(__BORLANDC__) && defined(__MSDOS__) + asm mov ax, ds + asm mov bx, si + asm mov dx, di + asm mov cx, n + asm les di, s1 + asm lds si, s2 + asm cld + asm rep movsb + asm mov ds, ax + asm mov si, bx + asm mov di, dx + return(s1); + +#else + register char *smax, *s = s1; + int n2; + + n2 = n % 4; + smax = s + (n - 4); + while (s <= smax) + { + *s = *s2; *(s + 1) = *(s2 + 1); *(s + 2) = *(s2 + 2); *(s + 3) = *(s2 + 3); + s += 4; + s2 += 4; + } + while (n2--) *s++ = *s2++; + return(s1); +#endif +} diff --git a/libslang/src/slmemset.c b/libslang/src/slmemset.c new file mode 100644 index 0000000..96cd2f1 --- /dev/null +++ b/libslang/src/slmemset.c @@ -0,0 +1,39 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are fast memcpy, memset routines. When available, I + use system rouines. For msdos, I use inline assembly. */ + +/* The current versions only work in the forward direction only!! */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +void SLmemset(char *p, char space, int n) +{ +#if defined(__BORLANDC__) && defined(__MSDOS__) + asm mov al, space + asm mov dx, di + asm mov cx, n + asm les di, p + asm cld + asm rep stosb + asm mov di, dx +#else + register char *pmax; + + pmax = p + (n - 4); + n = n % 4; + while (p <= pmax) + { + *p++ = space; *p++ = space; *p++ = space; *p++= space; + } + while (n--) *p++ = space; +#endif +} diff --git a/libslang/src/slmisc.c b/libslang/src/slmisc.c new file mode 100644 index 0000000..84d15f4 --- /dev/null +++ b/libslang/src/slmisc.c @@ -0,0 +1,605 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#define _GNU_SOURCE +#include "slinclud.h" + +#include + +#include "slang.h" +#include "_slang.h" + +#define DEBUG_MALLOC 0 + +#if DEBUG_MALLOC +# define SLREALLOC_FUN SLdebug_realloc +# define SLMALLOC_FUN SLdebug_malloc +# define SLFREE_FUN SLdebug_free +#else +# define SLREALLOC_FUN SLREALLOC +# define SLMALLOC_FUN SLMALLOC +# define SLFREE_FUN SLFREE +#endif + +/* Version information goes here since this file is always needed. */ +int SLang_Version = SLANG_VERSION; +char *SLang_Version_String = SLANG_VERSION_STRING; + +char *SLmake_string(char *str) +{ + return SLmake_nstring(str, strlen (str)); +} + +char *SLmake_nstring (char *str, unsigned int n) +{ + char *ptr; + + if (NULL == (ptr = SLmalloc(n + 1))) + { + return NULL; + } + SLMEMCPY (ptr, str, n); + ptr[n] = 0; + return(ptr); +} + +void SLmake_lut (unsigned char *lut, unsigned char *range, unsigned char reverse) +{ + /* register unsigned char *l = lut, *lmax = lut + 256; */ + int i, r1, r2; + + memset ((char *)lut, reverse, 256); + /* while (l < lmax) *l++ = reverse; */ + reverse = !reverse; + + r1 = *range++; + while (r1) + { + r2 = *range++; + if ((r2 == '-') && (*range != 0)) + { + r2 = *range++; + for (i = r1; i <= r2; i++) lut[i] = reverse; + r1 = *range++; + continue; + } + lut[r1] = reverse; + r1 = r2; + } +} + +char *SLmalloc (unsigned int len) +{ + char *p; + + p = (char *) SLMALLOC_FUN (len); + if (p == NULL) + SLang_Error = SL_MALLOC_ERROR; + + return p; +} + +void SLfree (char *p) +{ + if (p != NULL) SLFREE_FUN (p); +} + +char *SLrealloc (char *p, unsigned int len) +{ + if (len == 0) + { + SLfree (p); + return NULL; + } + + if (p == NULL) p = SLmalloc (len); + else + { + p = (char *)SLREALLOC_FUN (p, len); + if (p == NULL) + SLang_Error = SL_MALLOC_ERROR; + } + return p; +} + +char *SLcalloc (unsigned int nelems, unsigned int len) +{ + char *p; + + len = nelems * len; + p = SLmalloc (len); + if (p != NULL) SLMEMSET (p, 0, len); + return p; +} + + +char *_SLskip_whitespace (char *s) +{ + while (isspace (*s)) + s++; + + return s; +} + + +/* p and ch may point to the same buffer */ +char *_SLexpand_escaped_char(char *p, char *ch) +{ + int i = 0; + int max = 0, num, base = 0; + char ch1; + + ch1 = *p++; + + switch (ch1) + { + default: num = ch1; break; + case 'n': num = '\n'; break; + case 't': num = '\t'; break; + case 'v': num = '\v'; break; + case 'b': num = '\b'; break; + case 'r': num = '\r'; break; + case 'f': num = '\f'; break; + case 'E': case 'e': num = 27; break; + case 'a': num = 7; + break; + + /* octal */ + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + max = '7'; + base = 8; i = 2; num = ch1 - '0'; + break; + + case 'd': /* decimal -- S-Lang extension */ + base = 10; + i = 3; + max = '9'; + num = 0; + break; + + case 'x': /* hex */ + base = 16; + max = '9'; + i = 2; + num = 0; + break; + } + + while (i--) + { + ch1 = *p; + + if ((ch1 <= max) && (ch1 >= '0')) + { + num = base * num + (ch1 - '0'); + } + else if (base == 16) + { + ch1 |= 0x20; + if ((ch1 < 'a') || ((ch1 > 'f'))) break; + num = base * num + 10 + (ch1 - 'a'); + } + else break; + p++; + } + + *ch = (char) num; + return p; +} + +/* s and t could represent the same space */ +void SLexpand_escaped_string (register char *s, register char *t, + register char *tmax) +{ + char ch; + + while (t < tmax) + { + ch = *t++; + if (ch == '\\') + { + t = _SLexpand_escaped_char (t, &ch); + } + *s++ = ch; + } + *s = 0; +} + +int SLextract_list_element (char *list, unsigned int nth, char delim, + char *elem, unsigned int buflen) +{ + char *el, *elmax; + char ch; + + while (nth > 0) + { + while ((0 != (ch = *list)) && (ch != delim)) + list++; + + if (ch == 0) return -1; + + list++; + nth--; + } + + el = elem; + elmax = el + (buflen - 1); + + while ((0 != (ch = *list)) && (ch != delim) && (el < elmax)) + *el++ = *list++; + *el = 0; + + return 0; +} + +#ifndef HAVE_VSNPRINTF +int _SLvsnprintf (char *buf, unsigned int buflen, char *fmt, va_list ap) +{ +#if 1 + unsigned int len; + + /* On some systems vsprintf returns useless information. So, punt */ + vsprintf (buf, fmt, ap); + len = strlen (buf); + if (len >= buflen) + { + SLang_exit_error ("\ +Your system lacks the vsnprintf system call and vsprintf overflowed a buffer.\n\ +The integrity of this program has been violated.\n"); + return EOF; /* NOT reached */ + } + return (int)len; +#else + int status; + + status = vsprintf (buf, fmt, ap); + if (status >= (int) buflen) + { + /* If we are lucky, we will get this far. The real solution is to + * provide a working version of vsnprintf + */ + SLang_exit_error ("\ +Your system lacks the vsnprintf system call and vsprintf overflowed a buffer.\n\ +The integrity of this program has been violated.\n"); + return EOF; /* NOT reached */ + } + return status; +#endif +} +#endif + +#ifndef HAVE_SNPRINTF +int _SLsnprintf (char *buf, unsigned int buflen, char *fmt, ...) +{ + int status; + + va_list ap; + + va_start (ap, fmt); + status = _SLvsnprintf (buf, buflen, fmt, ap); + va_end (ap); + + return status; +} +#endif + +typedef struct _Cleanup_Function_Type +{ + struct _Cleanup_Function_Type *next; + void (*f)(void); +} +Cleanup_Function_Type; + +static Cleanup_Function_Type *Cleanup_Function_List; + +static void cleanup_slang (void) +{ + while (Cleanup_Function_List != NULL) + { + Cleanup_Function_Type *next = Cleanup_Function_List->next; + (*Cleanup_Function_List->f)(); + SLFREE_FUN ((char *) Cleanup_Function_List); + Cleanup_Function_List = next; + } +} + +#ifndef HAVE_ATEXIT +# ifdef HAVE_ON_EXIT +static void on_exit_cleanup_slang (int arg_unused) +{ + (void) arg_unused; + cleanup_slang (); +} +# endif +#endif + +int SLang_add_cleanup_function (void (*f)(void)) +{ + Cleanup_Function_Type *l; + + l = (Cleanup_Function_Type *) SLMALLOC_FUN (sizeof (Cleanup_Function_Type)); + if (l == NULL) + return -1; + + l->f = f; + l->next = Cleanup_Function_List; + + if (Cleanup_Function_List == NULL) + { +#ifdef HAVE_ATEXIT + (void) atexit (cleanup_slang); +#else +# ifdef HAVE_ON_EXIT + (void) on_exit (on_exit_cleanup_slang, 0); +# endif +#endif + } + Cleanup_Function_List = l; + return 0; +} + + +int SLang_guess_type (char *t) +{ + char *p; + register char ch; + int modifier; + + if (*t == '-') t++; + p = t; + +#if SLANG_HAS_FLOAT + if (*p != '.') + { +#endif + modifier = 0; + while ((*p >= '0') && (*p <= '9')) p++; + if (t == p) return (SLANG_STRING_TYPE); + if ((*p == 'x') && (p == t + 1)) /* 0x?? */ + { + modifier |= 8; + p++; + while (ch = *p, + ((ch >= '0') && (ch <= '9')) + || (((ch | 0x20) >= 'a') && ((ch | 0x20) <= 'f'))) p++; + } + + /* Now look for UL, LU, UH, HU, L, H modifiers */ + while ((ch = *p) != 0) + { + ch |= 0x20; + if (ch == 'h') modifier |= 1; + else if (ch == 'l') modifier |= 2; + else if (ch == 'u') modifier |= 4; + else break; + p++; + } + if ((1|2) == (modifier & (1|2))) /* hl present */ + return SLANG_STRING_TYPE; + + if (ch == 0) + { + if ((modifier & 0x7) == 0) return SLANG_INT_TYPE; + if (modifier & 4) + { + if (modifier & 1) return SLANG_USHORT_TYPE; + if (modifier & 2) return SLANG_ULONG_TYPE; + return SLANG_UINT_TYPE; + } + if (modifier & 1) return SLANG_SHORT_TYPE; + if (modifier & 2) return SLANG_LONG_TYPE; + return SLANG_INT_TYPE; + } + + if (modifier) return SLANG_STRING_TYPE; +#if SLANG_HAS_FLOAT + } + + /* now down to double case */ + if (*p == '.') + { + p++; + while ((*p >= '0') && (*p <= '9')) p++; + } + if (*p == 0) return(SLANG_DOUBLE_TYPE); + if ((*p != 'e') && (*p != 'E')) + { +# if SLANG_HAS_COMPLEX + if (((*p == 'i') || (*p == 'j')) + && (p[1] == 0)) + return SLANG_COMPLEX_TYPE; +# endif + if (((*p | 0x20) == 'f') && (p[1] == 0)) + return SLANG_FLOAT_TYPE; + + return SLANG_STRING_TYPE; + } + + p++; + if ((*p == '-') || (*p == '+')) p++; + while ((*p >= '0') && (*p <= '9')) p++; + if (*p != 0) + { +# if SLANG_HAS_COMPLEX + if (((*p == 'i') || (*p == 'j')) + && (p[1] == 0)) + return SLANG_COMPLEX_TYPE; +# endif + if (((*p | 0x20) == 'f') && (p[1] == 0)) + return SLANG_FLOAT_TYPE; + + return SLANG_STRING_TYPE; + } + return SLANG_DOUBLE_TYPE; +#else + return SLANG_STRING_TYPE; +#endif /* SLANG_HAS_FLOAT */ +} + +static int hex_atoul (unsigned char *s, unsigned long *ul) +{ + register unsigned char ch; + register unsigned long value; + register int base; + + s++; /* skip the leading 0 */ + + /* look for 'x' which indicates hex */ + if ((*s | 0x20) == 'x') + { + base = 16; + s++; + if (*s == 0) + { + SLang_Error = SL_SYNTAX_ERROR; + return -1; + } + } + else base = 8; + + value = 0; + while ((ch = *s++) != 0) + { + char ch1 = ch | 0x20; + switch (ch1) + { + default: + SLang_Error = SL_SYNTAX_ERROR; + break; + + case 'u': + case 'l': + case 'h': + *ul = value; + return 0; + + case '8': + case '9': + if (base != 16) SLang_Error = SL_SYNTAX_ERROR; + /* drop */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + ch1 -= '0'; + break; + + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + if (base != 16) SLang_Error = SL_SYNTAX_ERROR; + ch1 = (ch1 - 'a') + 10; + break; + } + value = value * base + ch1; + } + *ul = value; + return 0; +} + +/* Note: These routines do not check integer overflow. I would use the C + * library functions atol and atoul but some implementations check overflow + * and some do not. The following implementations provide a consistent + * behavior. + */ +unsigned long SLatoul (unsigned char *s) +{ + int sign; + unsigned long value; + + if (*s == '-') sign = -1; + else + { + sign = 1; + if (*s == '+') s++; + } + + if (*s == '0') + { + if (-1 == hex_atoul (s, &value)) + return (unsigned long) -1; + } + else + { + s = (unsigned char *) _SLskip_whitespace ((char *)s); + + value = 0; + while (isdigit (*s)) + { + value = value * 10 + (unsigned long) (*s - '0'); + s++; + } + } + + if (sign == -1) + value = (unsigned long)-1L * value; + + return value; +} + +long SLatol (unsigned char *s) +{ + s = (unsigned char *) _SLskip_whitespace ((char *)s); + + if (*s == '-') + { + long value = (long) SLatoul (s+1); + return -value; + } + return (long) SLatoul (s); +} + +int SLatoi (unsigned char *s) +{ + return (int) SLatol (s); +} + +#if !defined(HAVE_ISSETUGID) && defined(__GLIBC__) && (__GLIBC__ >= 2) +extern int __libc_enable_secure; +# define HAVE___LIBC_ENABLE_SECURE 1 +#endif + +int _SLsecure_issetugid (void) +{ +#ifdef HAVE_ISSETUGID + return (1 == issetugid ()); +#else +# ifdef HAVE___LIBC_ENABLE_SECURE + return __libc_enable_secure; +# else +# if defined(HAVE_GETUID) && defined(HAVE_GETEUID) && defined(HAVE_GETGID) && defined(HAVE_GETEUID) + static int enable_secure; + if (enable_secure == 0) + { + if ((getuid () != geteuid ()) + || (getgid () != getegid ())) + enable_secure = 1; + else + enable_secure = -1; + } + return (enable_secure == 1); +# else + return 0; +# endif +# endif +#endif +} + +/* Like getenv, except if running as setuid or setgid, returns NULL */ +char *_SLsecure_getenv (char *s) +{ + if (_SLsecure_issetugid ()) + return NULL; + return getenv (s); +} diff --git a/libslang/src/slnspace.c b/libslang/src/slnspace.c new file mode 100644 index 0000000..52dbe57 --- /dev/null +++ b/libslang/src/slnspace.c @@ -0,0 +1,294 @@ +/* -*- mode: C; mode: fold; -*- */ +/* slnspace.c --- Name Space implementation */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static SLang_NameSpace_Type *Namespace_Tables; + +static SLang_NameSpace_Type *find_name_table (char *name) +{ + SLang_NameSpace_Type *table_list; + + table_list = Namespace_Tables; + while (table_list != NULL) + { + if (0 == strcmp (table_list->name, name)) + break; + table_list = table_list->next; + } + return table_list; +} + +SLang_NameSpace_Type *_SLns_find_namespace (char *name) +{ + SLang_NameSpace_Type *table_list; + + table_list = Namespace_Tables; + while (table_list != NULL) + { + if ((table_list->namespace_name != NULL) + && (0 == strcmp (table_list->namespace_name, name))) + break; + table_list = table_list->next; + } + return table_list; +} + +SLang_NameSpace_Type *_SLns_allocate_namespace (char *name, unsigned int size) +{ + SLang_NameSpace_Type *table_list; + SLang_Name_Type **nt; + static int num; + char namebuf[64]; + + if (name == NULL) + { + sprintf (namebuf, " *** internal ns <%d> *** ", num); + name = namebuf; + num++; + } + + if (NULL != (table_list = find_name_table (name))) + return table_list; + + if (NULL == (name = SLang_create_slstring (name))) + return NULL; + + if (NULL == (table_list = (SLang_NameSpace_Type *) + SLmalloc (sizeof (SLang_NameSpace_Type)))) + { + SLang_free_slstring (name); + return NULL; + } + + if (NULL == (nt = (SLang_Name_Type **) SLmalloc (sizeof (SLang_Name_Type *) * size))) + { + SLang_free_slstring (name); + SLfree ((char *)table_list); + return NULL; + } + + memset ((char *)nt, 0, size * sizeof (SLang_Name_Type *)); + memset ((char *) table_list, 0, sizeof (SLang_NameSpace_Type)); + + table_list->name = name; + table_list->table = nt; + table_list->table_size = size; + + table_list->next = Namespace_Tables; + Namespace_Tables = table_list; + + return table_list; +} + +int _SLns_set_namespace_name (SLang_NameSpace_Type *t, char *name) +{ + SLang_NameSpace_Type *t1; + + t1 = _SLns_find_namespace (name); + if (t == t1) + return 0; /* already has this name */ + + if (t1 == NULL) + t1 = t; + + if ((t != t1) || (*name == 0)) + { + SLang_verror (SL_INTRINSIC_ERROR, "Namespace \"%s\" already exists", + name); + return -1; + } + + if (t->namespace_name != NULL) + { + SLang_verror (SL_INTRINSIC_ERROR, "An attempt was made to redefine namespace from \"%s\" to \"%s\"\n", + t->namespace_name, name); + return -1; + } + + if (NULL == (name = SLang_create_slstring (name))) + return -1; + + SLang_free_slstring (t->namespace_name); /* NULL ok */ + t->namespace_name = name; + + return 0; +} + +SLang_Array_Type *_SLnspace_apropos (SLang_NameSpace_Type *ns, char *pat, unsigned int what) +{ + SLang_Array_Type *at; + unsigned int table_size; + SLang_Name_Type *t, **table; + int num_matches; + unsigned int i; + SLRegexp_Type rexp; + unsigned char rbuf[512]; + unsigned int two; + + at = NULL; + + if ((ns == NULL) + || ((table = ns->table) == NULL)) + return NULL; + + memset ((char *) &rexp, 0, sizeof (SLRegexp_Type)); + rexp.case_sensitive = 1; + rexp.buf = rbuf; + rexp.buf_len = sizeof (rbuf); + rexp.pat = (unsigned char *)pat; + + if (0 != SLang_regexp_compile (&rexp)) + { + SLang_verror (SL_INVALID_PARM, "Invalid regular expression: %s", pat); + return NULL; + } + + table_size = ns->table_size; + + two = 2; + while (two != 0) + { + two--; + + num_matches = 0; + for (i = 0; i < table_size; i++) + { + t = table[i]; + while (t != NULL) + { + unsigned int flags; + char *name = t->name; + + switch (t->name_type) + { + case SLANG_GVARIABLE: + flags = 8; + break; + + case SLANG_ICONSTANT: + case SLANG_DCONSTANT: + case SLANG_RVARIABLE: + case SLANG_IVARIABLE: + flags = 4; + break; + + case SLANG_INTRINSIC: + case SLANG_MATH_UNARY: + case SLANG_APP_UNARY: + flags = 1; + break; + + case SLANG_FUNCTION: + flags = 2; + break; + + default: + flags = 0; + break; + } + + if ((flags & what) + && (NULL != SLang_regexp_match ((unsigned char *)name, strlen (name), &rexp))) + { + if (at != NULL) + { + if (-1 == SLang_set_array_element (at, &num_matches, (VOID_STAR)&name)) + goto return_error; + } + num_matches++; + } + t = t->next; + } + } + + if (at == NULL) + { + at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num_matches, 1); + if (at == NULL) + goto return_error; + } + } + + return at; + + return_error: + SLang_free_array (at); + return NULL; +} + +SLang_NameSpace_Type *SLns_create_namespace (char *namespace_name) +{ + SLang_NameSpace_Type *ns; + + if (namespace_name == NULL) + namespace_name = "Global"; + + ns = _SLns_find_namespace (namespace_name); + if (ns != NULL) + return ns; + + if (NULL == (ns = _SLns_allocate_namespace (NULL, SLSTATIC_HASH_TABLE_SIZE))) + return NULL; + + if (-1 == _SLns_set_namespace_name (ns, namespace_name)) + { + SLns_delete_namespace (ns); + return NULL; + } + + return ns; +} + +void SLns_delete_namespace (SLang_NameSpace_Type *ns) +{ + (void) ns; + /* V2.0 */ +} + +SLang_Array_Type *_SLns_list_namespaces (void) +{ + SLang_NameSpace_Type *table_list; + SLang_Array_Type *at; + int num, i; + + num = 0; + table_list = Namespace_Tables; + while (table_list != NULL) + { + if (table_list->namespace_name != NULL) + num++; + table_list = table_list->next; + } + at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num, 1); + if (at == NULL) + return NULL; + + table_list = Namespace_Tables; + i = 0; + while ((table_list != NULL) + && (i < num)) + { + if (table_list->namespace_name != NULL) + { + char *name = table_list->namespace_name; + if (-1 == SLang_set_array_element (at, &i, (VOID_STAR)&name)) + { + SLang_free_array (at); + return NULL; + } + i++; + } + table_list = table_list->next; + } + return at; +} diff --git a/libslang/src/slos2tty.c b/libslang/src/slos2tty.c new file mode 100644 index 0000000..4199d61 --- /dev/null +++ b/libslang/src/slos2tty.c @@ -0,0 +1,288 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#define INCL_BASE +#define INCL_NOPM +#define INCL_VIO +#define INCL_KBD +#define INCL_DOS +#if 0 +# define INCL_DOSSEMAPHORES +#endif +#ifdef LONG +#undef LONG +#endif +#ifdef VOID +#undef VOID +#endif +#include + +#include +#include + +static TID SLos2_threadID = (TID) 0; + +KBDINFO initialKbdInfo; /* keyboard info */ + +/* Code to read keystrokes in a separate thread */ + +typedef struct kbdcodes { + UCHAR ascii; + UCHAR scan; +/* USHORT shift; */ +} KBDCODES; + +#define BUFFER_LEN 4096 +static KBDCODES threadKeys[BUFFER_LEN]; +static int atEnd = 0; +static int startBuf; +static int endBuf; + +/* Original code used semaphores to control access to threadKeys. + * It is expected that the semaphore code will be deleted after 0.97. +*/ +#if 0 + +#ifdef __os2_16__ + +typedef USHORT APIRET; +static HSEM Hmtx; + +#define DosRequestMutexSem(hmtx,timeout) DosSemRequest(hmtx,timeout) +#define DosReleaseMutexSem(hmtx) DosSemClear(hmtx) +#define DosCloseMutexSem(hmtx) DosCloseSem(hmtx) + +#else /* !defined(__os2_16__) */ + +static HMTX Hmtx; /* Mutex Semaphore */ + +#endif + +static APIRET CreateSem(void) +{ +#ifdef __os2_16__ + char SemName[32]; + sprintf(SemName, "\\SEM\\jed\\%u", getpid()); + return ( DosCreateSem (0, &Hmtx, SemName) ); +#else + return ( DosCreateMutexSem (NULL, &Hmtx, 0, 0) ); +#endif +} + +static APIRET RequestSem(void) +{ + return ( DosRequestMutexSem (Hmtx, -1) ); +} + +static APIRET ReleaseSem(void) +{ + return ( DosReleaseMutexSem (Hmtx) ); +} + +static APIRET CloseSem(void) +{ + return( DosCloseMutexSem (Hmtx) ); +} + +#else + +#define CreateSem() +#define RequestSem() +#define ReleaseSem() +#define CloseSem() + +#endif + +static void set_kbd(void) +{ + KBDINFO kbdInfo; + + kbdInfo = initialKbdInfo; + kbdInfo.fsMask &= ~0x0001; /* not echo on */ + kbdInfo.fsMask |= 0x0002; /* echo off */ + kbdInfo.fsMask &= ~0x0008; /* cooked mode off */ + kbdInfo.fsMask |= 0x0004; /* raw mode */ + kbdInfo.fsMask &= ~0x0100; /* shift report off */ + KbdSetStatus(&kbdInfo, 0); +} + +static void thread_getkey () +{ + KBDKEYINFO keyInfo; + int n; + + while (!atEnd) { /* at end is a flag */ + set_kbd(); + KbdCharIn(&keyInfo, IO_NOWAIT, 0); /* get a character */ + if (keyInfo.fbStatus & 0x040) { /* found a char process it */ + if (keyInfo.chChar == SLang_Abort_Char) { + if (SLang_Ignore_User_Abort == 0) SLang_Error = SL_USER_BREAK; + SLKeyBoard_Quit = 1; + } + n = (endBuf + 1) % BUFFER_LEN; + if (n == startBuf) { + DosBeep (500, 20); + KbdFlushBuffer(0); + continue; + } + RequestSem(); + threadKeys [n].ascii = keyInfo.chChar; + threadKeys [n].scan = keyInfo.chScan; +/* threadKeys [n].shift = keyInfo.fsState; */ + endBuf = n; + ReleaseSem(); + } else /* no char available*/ + DosSleep (20); + } +} + +static void thread_code (void *Args) +{ + (void) Args; + startBuf = -1; /* initialize the buffer pointers */ + endBuf = -1; + thread_getkey (); + atEnd = 0; /* reset the flag */ + _endthread(); +} + +/* The code below is in the main thread */ + +int SLang_init_tty(int abort_char, int dum2, int dum3) +{ + VIOCURSORINFO cursorInfo, OldcursorInfo; + + (void) dum2; (void) dum3; + if (abort_char == -1) abort_char = 3; /* ^C */ + SLang_Abort_Char = abort_char; + + /* set ^C off */ + signal (SIGINT, SIG_IGN); + signal (SIGBREAK, SIG_IGN); + + /* set up the keyboard */ + + initialKbdInfo.cb = sizeof(initialKbdInfo); + KbdGetStatus(&initialKbdInfo, 0); + set_kbd(); + + /* open a semaphore */ + CreateSem(); + + /* start a separate thread to read the keyboard */ +#if defined(__BORLANDC__) + SLos2_threadID = _beginthread (thread_code, 8096, NULL); +#else + SLos2_threadID = _beginthread (thread_code, NULL, 8096, NULL); +#endif + + if ((int)SLos2_threadID == -1) + { + SLang_exit_error ("init_tty: Error starting keyboard thread."); + } + + VioGetCurType (&OldcursorInfo, 0); + cursorInfo.yStart = 1; + cursorInfo.cEnd = 15; + cursorInfo.cx = 1; + cursorInfo.attr = 1; + if (VioSetCurType (&cursorInfo, 0)) + VioSetCurType (&OldcursorInfo, 0); /* reset to previous value */ + + return 0; +} + +void SLang_reset_tty (void) +{ + if (0 == SLos2_threadID) return; + atEnd = 1; /* set flag and wait until thread ends */ + while (atEnd) {DosSleep (0);} + + CloseSem(); + + /* close the keyboard */ + KbdSetStatus(&initialKbdInfo, 0); /* restore original state */ + SLos2_threadID = 0; +} + +#define keyWaiting() (endBuf != startBuf) + +/* sleep for *tsecs tenths of a sec waiting for input */ + +int _SLsys_input_pending(int tsecs) +{ + if (keyWaiting()) return 1; + + /* Convert tsecs to units of 20 ms */ + tsecs = tsecs * 5; + + /* If tsecs is less than 0, it represents millisecs */ + if (tsecs < 0) + tsecs = -tsecs / 100; + + while (tsecs > 0) + { + DosSleep(20); /* 20 ms or 1/50 sec */ + if (keyWaiting()) break; + tsecs--; + } + return (tsecs); +} + +unsigned int _SLsys_getkey () +{ + unsigned int c; + unsigned char scan; + + int tsecs = 300; + + if (!keyWaiting()) + while (!_SLsys_input_pending(tsecs)); + + /* read codes from buffer */ + RequestSem(); + startBuf = (startBuf + 1) % BUFFER_LEN; + c = threadKeys [startBuf].ascii; + scan = threadKeys [startBuf].scan; + ReleaseSem(); + + switch (c) + { + case 8: + if (scan == 0x0E) c = 127; + break; + + case 0xE0: + case 0: + c = _SLpc_convert_scancode (scan, 0, 1); + break; + + default: + break; + } + return (c); +} + +int SLang_set_abort_signal (void (*dum)(int)) +{ + (void) dum; + return 0; +} + +int SLtt_set_mouse_mode (int mode, int force) +{ + /* FIXME: Priority=low */ + (void) mode; + (void) force; + + return -1; +} diff --git a/libslang/src/slospath.c b/libslang/src/slospath.c new file mode 100644 index 0000000..697a248 --- /dev/null +++ b/libslang/src/slospath.c @@ -0,0 +1,227 @@ +/* Pathname intrinsic functions */ +/* Copyright (c) 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#ifdef VMS +# include +#else +# include +#endif + + +static void path_concat (char *a, char *b) +{ + SLang_push_malloced_string (SLpath_dircat (a,b)); +} + +static void path_extname (char *path) +{ +#ifdef VMS + char *p; +#endif + + path = SLpath_extname (path); +#ifndef VMS + SLang_push_string (path); +#else + p = strchr (path, ';'); + if (p == NULL) + (void)SLang_push_string (p); + else + (void)SLang_push_malloced_string (SLmake_nstring (path, (unsigned int)(p - path))); +#endif +} + +static void path_basename (char *path) +{ + (void) SLang_push_string (SLpath_basename (path)); +} + +static void path_dirname (char *path) +{ + (void) SLang_push_malloced_string (SLpath_dirname (path)); +} + +static void path_sans_extname (char *path) +{ + (void) SLang_push_malloced_string (SLpath_pathname_sans_extname (path)); +} + +static char *Load_Path; +int SLpath_set_load_path (char *path) +{ + if (path == NULL) + { + SLang_free_slstring (Load_Path); + Load_Path = NULL; + return 0; + } + + path = SLang_create_slstring (path); + if (path == NULL) + return -1; + + if (Load_Path != NULL) + SLang_free_slstring (Load_Path); + + Load_Path = path; + return 0; +} + +char *SLpath_get_load_path (void) +{ + return SLang_create_slstring (Load_Path); +} + + +static char *get_load_path (void) +{ + if (Load_Path == NULL) + return ""; + return Load_Path; +} + +static void set_load_path (char *path) +{ + (void) SLpath_set_load_path (path); +} + +static char *more_recent (char *a, char *b) +{ + unsigned long ta, tb; + struct stat st; + + if (a == NULL) + return b; + if (b == NULL) + return a; + + if (-1 == stat (a, &st)) + return b; + ta = (unsigned long) st.st_mtime; + if (-1 == stat (b, &st)) + return a; + tb = (unsigned long) st.st_mtime; + + if (tb >= ta) + return b; + + return a; +} + + +/* returns SLmalloced string */ +static char *find_file (char *path, char *file) +{ + char *dirfile; + char *extname; + char *filebuf; + char *filesl, *fileslc; + unsigned int len; + + if (NULL != (dirfile = SLpath_find_file_in_path (path, file))) + return dirfile; + + /* Not found, or an error occured. */ + if (SLang_Error) + return NULL; + + extname = SLpath_extname (file); + if (*extname != 0) + return NULL; + + /* No extension. So look for .slc and .sl forms */ + len = (extname - file); + filebuf = SLmalloc (len + 5); + strcpy (filebuf, file); + strcpy (filebuf + len, ".sl"); + + filesl = SLpath_find_file_in_path (path, filebuf); + if ((filesl == NULL) && SLang_Error) + { + SLfree (filebuf); + return NULL; + } + strcpy (filebuf + len, ".slc"); + fileslc = SLpath_find_file_in_path (path, filebuf); + SLfree (filebuf); + + dirfile = more_recent (filesl, fileslc); + + if (dirfile != filesl) + SLfree (filesl); + if (dirfile != fileslc) + SLfree (fileslc); + + return dirfile; +} + +char *_SLpath_find_file (char *file) +{ + char *path; + char *dirfile; + + if (file == NULL) + return NULL; + + path = Load_Path; + if ((path == NULL) || (*path == 0)) + path = "."; + + dirfile = find_file (path, file); + + if (dirfile != NULL) + { + file = SLang_create_slstring (dirfile); + SLfree (dirfile); + return file; + } + + SLang_verror (SL_OBJ_NOPEN, "Unable to locate %s on load path", file); + return NULL; +} + +static void get_path_delimiter (void) +{ + (void) SLang_push_char ((char) SLpath_get_delimiter ()); +} + +#if 0 +static void set_path_delimiter (int *d) +{ + (void) SLpath_set_delimiter (*d); +} +#endif +static SLang_Intrin_Fun_Type Path_Name_Table [] = +{ + MAKE_INTRINSIC_S("set_slang_load_path", set_load_path, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("get_slang_load_path", get_load_path, SLANG_STRING_TYPE), + MAKE_INTRINSIC_0("path_get_delimiter", get_path_delimiter, SLANG_VOID_TYPE), + /* MAKE_INTRINSIC_I("path_set_delimiter", set_path_delimiter, SLANG_VOID_TYPE), */ + MAKE_INTRINSIC_SS("path_concat", path_concat, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_extname", path_extname, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_dirname", path_dirname, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_basename", path_basename, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_sans_extname", path_sans_extname, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_is_absolute", SLpath_is_absolute_path, SLANG_INT_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +int SLang_init_ospath (void) +{ + if (-1 == SLadd_intrin_fun_table(Path_Name_Table, "__OSPATH__")) + return -1; + + return 0; +} + + diff --git a/libslang/src/slpack.c b/libslang/src/slpack.c new file mode 100644 index 0000000..f98fbaf --- /dev/null +++ b/libslang/src/slpack.c @@ -0,0 +1,785 @@ +/* Pack objects as a binary string */ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include + +#include "slang.h" +#include "_slang.h" + +#ifndef isdigit +# define isdigit(c) (((c)>='0')&&((c)<= '9')) +#endif +#ifndef isspace +# define isspace(c) (((c)==' ') || ((c)=='\t') || ((c)=='\n')) +#endif + +/* format description: + * + * s = string (null padded) + * S = string (space padded) + * c = signed char + * C = unsigned char + * h = short + * H = unsigned short + * i = int + * I = unsigned int + * l = long + * L = unsigned long + * j = 16 bit signed integer (short) + * J = 16 bit unsigned integer (short) + * k = 32 bit signed integer (long) + * K = 32 bit unsigned integer (long) + * f = float (native format) + * F = 32 bit double + * d = double (native format) + * D = 64 bit double + * x = null pad byte + * > = big-endian mode + * < = little-endian mode + * = = native mode + */ + +#define NATIVE_ORDER 0 +#define BIGENDIAN_ORDER 1 +#define LILENDIAN_ORDER 2 +static int Native_Byte_Order = NATIVE_ORDER; + +typedef struct +{ + char format_type; + unsigned char data_type; + unsigned int repeat; + unsigned int sizeof_type; + char pad; + int byteorder; + int is_scalar; +} +Format_Type; + +static int get_int_type_for_size (unsigned int size, unsigned char *s, unsigned char *u) +{ + if (sizeof (int) == size) + { + if (s != NULL) *s = SLANG_INT_TYPE; + if (u != NULL) *u = SLANG_UINT_TYPE; + return 0; + } + + if (sizeof (short) == size) + { + if (s != NULL) *s = SLANG_SHORT_TYPE; + if (u != NULL) *u = SLANG_USHORT_TYPE; + return 1; + } + + if (sizeof (long) == size) + { + if (s != NULL) *s = SLANG_LONG_TYPE; + if (u != NULL) *u = SLANG_ULONG_TYPE; + return 1; + } + + if (s != NULL) *s = 0; + if (u != NULL) *u = 0; + SLang_verror (SL_NOT_IMPLEMENTED, + "This OS does not support a %u byte int", size); + return -1; +} + +static int get_float_type_for_size (unsigned int size, unsigned char *s) +{ + if (sizeof (float) == size) + { + *s = SLANG_FLOAT_TYPE; + return 0; + } + + if (sizeof (double) == size) + { + *s = SLANG_DOUBLE_TYPE; + return 0; + } + + SLang_verror (SL_NOT_IMPLEMENTED, + "This OS does not support a %u byte float", size); + return -1; +} + +static int parse_a_format (char **format, Format_Type *ft) +{ + char *f; + char ch; + unsigned repeat; + + f = *format; + + while (((ch = *f++) != 0) + && isspace (ch)) + ; + + switch (ch) + { + default: + ft->byteorder = NATIVE_ORDER; + break; + + case '=': + ft->byteorder = NATIVE_ORDER; + ch = *f++; + break; + + case '>': + ft->byteorder = BIGENDIAN_ORDER; + ch = *f++; + break; + + case '<': + ft->byteorder = LILENDIAN_ORDER; + ch = *f++; + break; + } + + if (ch == 0) + { + f--; + *format = f; + return 0; + } + + ft->format_type = ch; + ft->repeat = 1; + + if (isdigit (*f)) + { + repeat = (unsigned int) (*f - '0'); + f++; + + while (isdigit (*f)) + { + unsigned int repeat10 = 10 * repeat + (unsigned int)(*f - '0'); + + /* Check overflow */ + if (repeat != repeat10 / 10) + { + SLang_verror (SL_OVERFLOW, + "Repeat count too large in [un]pack format"); + return -1; + } + repeat = repeat10; + f++; + } + ft->repeat = repeat; + } + + *format = f; + + ft->is_scalar = 1; + ft->pad = 0; + + switch (ft->format_type) + { + default: + SLang_verror (SL_NOT_IMPLEMENTED, + "[un]pack format character '%c' not supported", ft->format_type); + return -1; + + case 'D': + ft->sizeof_type = 8; + if (-1 == get_float_type_for_size (8, &ft->data_type)) + return -1; + break; + + case 'd': + ft->data_type = SLANG_DOUBLE_TYPE; + ft->sizeof_type = sizeof (double); + break; + + case 'F': + ft->sizeof_type = 4; + if (-1 == get_float_type_for_size (4, &ft->data_type)) + return -1; + break; + case 'f': + ft->data_type = SLANG_FLOAT_TYPE; + ft->sizeof_type = sizeof (float); + break; + + case 'h': + ft->data_type = SLANG_SHORT_TYPE; + ft->sizeof_type = sizeof (short); + break; + case 'H': + ft->data_type = SLANG_USHORT_TYPE; + ft->sizeof_type = sizeof (unsigned short); + break; + case 'i': + ft->data_type = SLANG_INT_TYPE; + ft->sizeof_type = sizeof (int); + break; + case 'I': + ft->data_type = SLANG_UINT_TYPE; + ft->sizeof_type = sizeof (unsigned int); + break; + case 'l': + ft->data_type = SLANG_LONG_TYPE; + ft->sizeof_type = sizeof (long); + break; + case 'L': + ft->data_type = SLANG_ULONG_TYPE; + ft->sizeof_type = sizeof (unsigned long); + break; + + /* 16 bit ints */ + case 'j': + ft->sizeof_type = 2; + if (-1 == get_int_type_for_size (2, &ft->data_type, NULL)) + return -1; + break; + case 'J': + ft->sizeof_type = 2; + if (-1 == get_int_type_for_size (2, NULL, &ft->data_type)) + return -1; + break; + + /* 32 bit ints */ + case 'k': + ft->sizeof_type = 4; + if (-1 == get_int_type_for_size (4, &ft->data_type, NULL)) + return -1; + break; + case 'K': + ft->sizeof_type = 4; + if (-1 == get_int_type_for_size (4, NULL, &ft->data_type)) + return -1; + break; + + case 'x': + ft->sizeof_type = 1; + ft->data_type = 0; + break; + + case 'c': + ft->sizeof_type = 1; + ft->data_type = SLANG_CHAR_TYPE; + break; + + case 'C': + ft->data_type = SLANG_UCHAR_TYPE; + ft->sizeof_type = 1; + break; + + case 'S': + case 'A': + ft->pad = ' '; + case 'a': + case 's': + ft->data_type = SLANG_BSTRING_TYPE; + ft->sizeof_type = 1; + ft->is_scalar = 0; + break; + } + return 1; +} + +static int compute_size_for_format (char *format, unsigned int *num_bytes) +{ + unsigned int size; + Format_Type ft; + int status; + + *num_bytes = size = 0; + + while (1 == (status = parse_a_format (&format, &ft))) + size += ft.repeat * ft.sizeof_type; + + *num_bytes = size; + return status; +} + +static void byte_swap64 (unsigned char *ss, unsigned int n) /*{{{*/ +{ + unsigned char *p, *pmax, ch; + + if (n == 0) return; + p = (unsigned char *) ss; + pmax = p + 8 * n; + while (p < pmax) + { + ch = *p; + *p = *(p + 7); + *(p + 7) = ch; + + ch = *(p + 6); + *(p + 6) = *(p + 1); + *(p + 1) = ch; + + ch = *(p + 5); + *(p + 5) = *(p + 2); + *(p + 2) = ch; + + ch = *(p + 4); + *(p + 4) = *(p + 3); + *(p + 3) = ch; + + p += 8; + } +} + +/*}}}*/ +static void byte_swap32 (unsigned char *ss, unsigned int n) /*{{{*/ +{ + unsigned char *p, *pmax, ch; + + p = (unsigned char *) ss; + pmax = p + 4 * n; + while (p < pmax) + { + ch = *p; + *p = *(p + 3); + *(p + 3) = ch; + + ch = *(p + 1); + *(p + 1) = *(p + 2); + *(p + 2) = ch; + p += 4; + } +} + +/*}}}*/ +static void byte_swap16 (unsigned char *p, unsigned int nread) /*{{{*/ +{ + unsigned char *pmax, ch; + + pmax = p + 2 * nread; + while (p < pmax) + { + ch = *p; + *p = *(p + 1); + *(p + 1) = ch; + p += 2; + } +} + +/*}}}*/ + +static int byteswap (int order, unsigned char *b, unsigned int size, unsigned int num) +{ + if (Native_Byte_Order == order) + return 0; + + switch (size) + { + case 2: + byte_swap16 (b, num); + break; + case 4: + byte_swap32 (b, num); + break; + case 8: + byte_swap64 (b, num); + break; + default: + return -1; + } + + return 0; +} + +static void check_native_byte_order (void) +{ + unsigned short x; + + if (Native_Byte_Order != NATIVE_ORDER) + return; + + x = 0xFF; + if (*(unsigned char *)&x == 0xFF) + Native_Byte_Order = LILENDIAN_ORDER; + else + Native_Byte_Order = BIGENDIAN_ORDER; +} + +static SLang_BString_Type * +pack_according_to_format (char *format, unsigned int nitems) +{ + unsigned int size, num; + unsigned char *buf, *b; + SLang_BString_Type *bs; + Format_Type ft; + + buf = NULL; + + if (-1 == compute_size_for_format (format, &size)) + goto return_error; + + if (NULL == (buf = (unsigned char *) SLmalloc (size + 1))) + goto return_error; + + b = buf; + + while (1 == parse_a_format (&format, &ft)) + { + unsigned char *ptr; + unsigned int repeat; + + repeat = ft.repeat; + if (ft.data_type == 0) + { + memset ((char *) b, ft.pad, repeat); + b += repeat; + continue; + } + + if (ft.is_scalar) + { + unsigned char *bstart; + num = repeat; + + bstart = b; + while (repeat != 0) + { + unsigned int nelements; + SLang_Array_Type *at; + + if (nitems == 0) + { + SLang_verror (SL_INVALID_PARM, + "Not enough items for pack format"); + goto return_error; + } + + if (-1 == SLang_pop_array_of_type (&at, ft.data_type)) + goto return_error; + + nelements = at->num_elements; + if (repeat < nelements) + nelements = repeat; + repeat -= nelements; + + nelements = nelements * ft.sizeof_type; + memcpy ((char *)b, (char *)at->data, nelements); + + b += nelements; + SLang_free_array (at); + nitems--; + } + + if (ft.byteorder != NATIVE_ORDER) + byteswap (ft.byteorder, bstart, ft.sizeof_type, num); + + continue; + } + + /* Otherwise we have a string */ + if (-1 == SLang_pop_bstring (&bs)) + goto return_error; + + ptr = SLbstring_get_pointer (bs, &num); + if (repeat < num) num = repeat; + memcpy ((char *)b, (char *)ptr, num); + b += num; + repeat -= num; + memset ((char *)b, ft.pad, repeat); + SLbstring_free (bs); + b += repeat; + nitems--; + } + + *b = 0; + bs = SLbstring_create_malloced (buf, size, 0); + if (bs == NULL) + goto return_error; + + SLdo_pop_n (nitems); + return bs; + + return_error: + SLdo_pop_n (nitems); + if (buf != NULL) + SLfree ((char *) buf); + + return NULL; +} + +void _SLpack (void) +{ + SLang_BString_Type *bs; + char *fmt; + int nitems; + + check_native_byte_order (); + + nitems = SLang_Num_Function_Args; + if (nitems <= 0) + { + SLang_verror (SL_SYNTAX_ERROR, + "pack: not enough arguments"); + return; + } + + if ((-1 == SLreverse_stack (nitems)) + || (-1 == SLang_pop_slstring (&fmt))) + bs = NULL; + else + { + bs = pack_according_to_format (fmt, (unsigned int)nitems - 1); + SLang_free_slstring (fmt); + } + + SLang_push_bstring (bs); + SLbstring_free (bs); +} + +void _SLunpack (char *format, SLang_BString_Type *bs) +{ + Format_Type ft; + unsigned char *b; + unsigned int len; + unsigned int num_bytes; + + check_native_byte_order (); + + if (-1 == compute_size_for_format (format, &num_bytes)) + return; + + b = SLbstring_get_pointer (bs, &len); + if (b == NULL) + return; + + if (len < num_bytes) + { + SLang_verror (SL_INVALID_PARM, + "unpack format %s is too large for input string", + format); + return; + } + + while (1 == parse_a_format (&format, &ft)) + { + char *str, *s; + + if (ft.repeat == 0) + continue; + + if (ft.data_type == 0) + { /* skip padding */ + b += ft.repeat; + continue; + } + + if (ft.is_scalar) + { + SLang_Array_Type *at; + int dims; + + if (ft.repeat == 1) + { + SLang_Class_Type *cl; + + cl = _SLclass_get_class (ft.data_type); + memcpy ((char *)cl->cl_transfer_buf, (char *)b, ft.sizeof_type); + if (ft.byteorder != NATIVE_ORDER) + byteswap (ft.byteorder, (unsigned char *)cl->cl_transfer_buf, ft.sizeof_type, 1); + + if (-1 == (cl->cl_apush (ft.data_type, cl->cl_transfer_buf))) + return; + b += ft.sizeof_type; + continue; + } + + dims = (int) ft.repeat; + at = SLang_create_array (ft.data_type, 0, NULL, &dims, 1); + if (at == NULL) + return; + + num_bytes = ft.repeat * ft.sizeof_type; + memcpy ((char *)at->data, (char *)b, num_bytes); + if (ft.byteorder != NATIVE_ORDER) + byteswap (ft.byteorder, (unsigned char *)at->data, ft.sizeof_type, ft.repeat); + + if (-1 == SLang_push_array (at, 1)) + return; + + b += num_bytes; + continue; + } + + len = ft.repeat; + str = SLmalloc (len + 1); + if (str == NULL) + return; + + memcpy ((char *) str, (char *)b, len); + str [len] = 0; + + if (ft.pad == ' ') + { + unsigned int new_len; + + s = str + len; + while (s > str) + { + s--; + if ((*s != ' ') && (*s != 0)) + { + s++; + break; + } + *s = 0; + } + new_len = (unsigned int) (s - str); + + if (new_len != len) + { + s = SLrealloc (str, new_len + 1); + if (s == NULL) + { + SLfree (str); + return; + } + str = s; + len = new_len; + } + } + + /* Avoid a bstring if possible */ + s = SLmemchr (str, 0, len); + if (s == NULL) + { + if (-1 == SLang_push_malloced_string (str)) + return; + } + else + { + SLang_BString_Type *new_bs; + + new_bs = SLbstring_create_malloced ((unsigned char *)str, len, 1); + if (new_bs == NULL) + return; + + if (-1 == SLang_push_bstring (new_bs)) + { + SLfree (str); + return; + } + SLbstring_free (new_bs); + } + + b += ft.repeat; + } +} + +unsigned int _SLpack_compute_size (char *format) +{ + unsigned int n; + + n = 0; + (void) compute_size_for_format (format, &n); + return n; +} + +void _SLpack_pad_format (char *format) +{ + unsigned int len, max_len; + Format_Type ft; + char *buf, *b; + + check_native_byte_order (); + + /* Just check the syntax */ + if (-1 == compute_size_for_format (format, &max_len)) + return; + + /* This should be sufficient to handle any needed xyy padding characters. + * I cannot see how this will be overrun + */ + max_len = 4 * (strlen (format) + 1); + if (NULL == (buf = SLmalloc (max_len + 1))) + return; + + b = buf; + len = 0; + while (1 == parse_a_format (&format, &ft)) + { + struct { char a; short b; } s_h; + struct { char a; int b; } s_i; + struct { char a; long b; } s_l; + struct { char a; float b; } s_f; + struct { char a; double b; } s_d; + unsigned int pad; + + if (ft.repeat == 0) + continue; + + if (ft.data_type == 0) + { /* pad */ + sprintf (b, "x%u", ft.repeat); + b += strlen (b); + len += ft.repeat; + continue; + } + + switch (ft.data_type) + { + default: + case SLANG_STRING_TYPE: + case SLANG_BSTRING_TYPE: + case SLANG_CHAR_TYPE: + case SLANG_UCHAR_TYPE: + pad = 0; + break; + + case SLANG_SHORT_TYPE: + case SLANG_USHORT_TYPE: + pad = ((unsigned int) ((char *)&s_h.b - (char *)&s_h.a)); + break; + + case SLANG_INT_TYPE: + case SLANG_UINT_TYPE: + pad = ((unsigned int) ((char *)&s_i.b - (char *)&s_i.a)); + break; + + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: + pad = ((unsigned int) ((char *)&s_l.b - (char *)&s_l.a)); + break; + + case SLANG_FLOAT_TYPE: + pad = ((unsigned int) ((char *)&s_f.b - (char *)&s_f.a)); + break; + + case SLANG_DOUBLE_TYPE: + pad = ((unsigned int) ((char *)&s_d.b - (char *)&s_d.a)); + break; + } + + /* Pad to a length that is an integer multiple of pad. */ + if (pad) + pad = pad * ((len + pad - 1)/pad) - len; + + if (pad) + { + sprintf (b, "x%u", pad); + b += strlen (b); + len += pad; + } + + *b++ = ft.format_type; + if (ft.repeat > 1) + { + sprintf (b, "%u", ft.repeat); + b += strlen (b); + } + + len += ft.repeat * ft.sizeof_type; + } + *b = 0; + + (void) SLang_push_malloced_string (buf); +} diff --git a/libslang/src/slparse.c b/libslang/src/slparse.c new file mode 100644 index 0000000..f0a2c63 --- /dev/null +++ b/libslang/src/slparse.c @@ -0,0 +1,1970 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static SLang_Load_Type *LLT; +int _SLang_Compile_Line_Num_Info; + +static void free_token (_SLang_Token_Type *t) +{ + register unsigned int nrefs = t->num_refs; + + if (nrefs == 0) + return; + + if (nrefs == 1) + { + if (t->free_sval_flag) + { + if (t->type == BSTRING_TOKEN) + SLbstring_free (t->v.b_val); + else + _SLfree_hashed_string (t->v.s_val, strlen (t->v.s_val), t->hash); + t->v.s_val = NULL; + } + } + + t->num_refs = nrefs - 1; +} + +static void init_token (_SLang_Token_Type *t) +{ + memset ((char *) t, 0, sizeof (_SLang_Token_Type)); +#if _SLANG_HAS_DEBUG_CODE + t->line_number = -1; +#endif +} + +/* Allow room for one push back of a token. This is necessary for + * multiple assignment. + */ +static unsigned int Use_Next_Token; +static _SLang_Token_Type Next_Token; +#if _SLANG_HAS_DEBUG_CODE +static int Last_Line_Number = -1; +#endif + +static int unget_token (_SLang_Token_Type *ctok) +{ + if (SLang_Error) + return -1; + if (Use_Next_Token != 0) + { + _SLparse_error ("unget_token failed", ctok, 0); + return -1; + } + + Use_Next_Token++; + Next_Token = *ctok; + init_token (ctok); + return 0; +} + +static int get_token (_SLang_Token_Type *ctok) +{ + if (ctok->num_refs) + free_token (ctok); + + if (Use_Next_Token) + { + Use_Next_Token--; + *ctok = Next_Token; + return ctok->type; + } + + return _SLget_token (ctok); +} + +static int compile_token (_SLang_Token_Type *t) +{ +#if _SLANG_HAS_DEBUG_CODE + if (_SLang_Compile_Line_Num_Info + && (t->line_number != Last_Line_Number) + && (t->line_number != -1)) + { + _SLang_Token_Type tok; + tok.type = LINE_NUM_TOKEN; + tok.v.long_val = Last_Line_Number = t->line_number; + (*_SLcompile_ptr) (&tok); + } +#endif + (*_SLcompile_ptr) (t); + return 0; +} + +typedef struct +{ +#define USE_PARANOID_MAGIC 0 +#if USE_PARANOID_MAGIC + unsigned long magic; +#endif + _SLang_Token_Type *stack; + unsigned int len; + unsigned int size; +} +Token_List_Type; + +#define MAX_TOKEN_LISTS 16 +static Token_List_Type Token_List_Stack [MAX_TOKEN_LISTS]; +static unsigned int Token_List_Stack_Depth = 0; +static Token_List_Type *Token_List = NULL; + +static void init_token_list (Token_List_Type *t) +{ + t->size = 0; + t->len = 0; + t->stack = NULL; +#if USE_PARANOID_MAGIC + t->magic = 0xABCDEF12; +#endif +} + +static void free_token_list (Token_List_Type *t) +{ + _SLang_Token_Type *s; + + if (t == NULL) + return; +#if USE_PARANOID_MAGIC + if (t->magic != 0xABCDEF12) + { + SLang_doerror ("Magic error."); + return; + } +#endif + s = t->stack; + if (s != NULL) + { + _SLang_Token_Type *smax = s + t->len; + while (s != smax) + { + if (s->num_refs) free_token (s); + s++; + } + + SLfree ((char *) t->stack); + } + + memset ((char *) t, 0, sizeof (Token_List_Type)); +} + +static Token_List_Type *push_token_list (void) +{ + if (Token_List_Stack_Depth == MAX_TOKEN_LISTS) + { + _SLparse_error ("Token list stack size exceeded", NULL, 0); + return NULL; + } + + Token_List = Token_List_Stack + Token_List_Stack_Depth; + Token_List_Stack_Depth++; + init_token_list (Token_List); + return Token_List; +} + +static int pop_token_list (int do_free) +{ + if (Token_List_Stack_Depth == 0) + { + if (SLang_Error == 0) + _SLparse_error ("Token list stack underflow", NULL, 0); + return -1; + } + Token_List_Stack_Depth--; + + if (do_free) free_token_list (Token_List); + + if (Token_List_Stack_Depth != 0) + Token_List = Token_List_Stack + (Token_List_Stack_Depth - 1); + else + Token_List = NULL; + + return 0; +} + +static int check_token_list_space (Token_List_Type *t, unsigned int delta_size) +{ + _SLang_Token_Type *st; + unsigned int len; +#if USE_PARANOID_MAGIC + if (t->magic != 0xABCDEF12) + { + SLang_doerror ("Magic error."); + return -1; + } +#endif + len = t->len + delta_size; + if (len <= t->size) return 0; + + if (delta_size < 4) + { + delta_size = 4; + len = t->len + delta_size; + } + + st = (_SLang_Token_Type *) SLrealloc((char *) t->stack, + len * sizeof(_SLang_Token_Type)); + if (st == NULL) + { + _SLparse_error ("Malloc error", NULL, 0); + return -1; + } + + memset ((char *) (st + t->len), 0, delta_size); + + t->stack = st; + t->size = len; + return 0; +} + +static int append_token (_SLang_Token_Type *t) +{ + if (-1 == check_token_list_space (Token_List, 1)) + return -1; + + Token_List->stack [Token_List->len] = *t; + Token_List->len += 1; + t->num_refs = 0; /* stealing it */ + return 0; +} + +static int append_token_of_type (unsigned char t) +{ + _SLang_Token_Type *tok; + + if (-1 == check_token_list_space (Token_List, 1)) + return -1; + + /* The memset when the list was created ensures that the other fields + * are properly initialized. + */ + tok = Token_List->stack + Token_List->len; + init_token (tok); + tok->type = t; + Token_List->len += 1; + return 0; +} + +static _SLang_Token_Type *get_last_token (void) +{ + unsigned int len; + + if ((Token_List == NULL) + || (0 == (len = Token_List->len))) + return NULL; + + len--; + return Token_List->stack + len; +} + +/* This function does NOT free the list. */ +static int compile_token_list_with_fun (int dir, Token_List_Type *list, + int (*f)(_SLang_Token_Type *)) +{ + _SLang_Token_Type *t0, *t1; + + if (list == NULL) + return -1; + + if (f == NULL) + f = compile_token; + + t0 = list->stack; + t1 = t0 + list->len; + + if (dir < 0) + { + /* backwards */ + + while ((SLang_Error == 0) && (t1 > t0)) + { + t1--; + (*f) (t1); + } + return 0; + } + + /* forward */ + while ((SLang_Error == 0) && (t0 < t1)) + { + (*f) (t0); + t0++; + } + return 0; +} + +static int compile_token_list (void) +{ + if (Token_List == NULL) + return -1; + + compile_token_list_with_fun (1, Token_List, NULL); + pop_token_list (1); + return 0; +} + +/* Take all elements in the list from pos2 to the end and exchange them + * with the elements at pos1, e.g., + * ...ABCDEabc ==> ...abcABCDE + * where pos1 denotes A and pos2 denotes a. + */ +static int token_list_element_exchange (unsigned int pos1, unsigned int pos2) +{ + _SLang_Token_Type *s, *s1, *s2; + unsigned int len, nloops; + + if (Token_List == NULL) + return -1; + + s = Token_List->stack; + len = Token_List->len; + + if ((s == NULL) || (len == 0) + || (pos2 >= len)) + return -1; + + /* This may not be the most efficient algorithm but the number to swap + * is most-likely going to be small, e.g, 3 + * The algorithm is to rotate the list. The particular rotation + * direction was chosen to make insert_token fast. + * It works like: + * @ ABCabcde --> BCabcdeA --> CabcdeAB --> abcdefAB + * which is optimal for Abcdef sequence produced by function calls. + * + * Profiling indicates that nloops is almost always 1, whereas the inner + * loop can loop many times (e.g., 9 times). + */ + + s2 = s + (len - 1); + s1 = s + pos1; + nloops = pos2 - pos1; + + while (nloops) + { + _SLang_Token_Type save; + + s = s1; + save = *s; + + while (s < s2) + { + *s = *(s + 1); + s++; + } + *s = save; + + nloops--; + } + return 0; +} + +#if 0 +static int insert_token (_SLang_Token_Type *t, unsigned int pos) +{ + if (-1 == append_token (t)) + return -1; + + return token_list_element_exchange (pos, Token_List->len - 1); +} +#endif +static void compile_token_of_type (unsigned char t) +{ + _SLang_Token_Type tok; + +#if _SLANG_HAS_DEBUG_CODE + tok.line_number = -1; +#endif + tok.type = t; + compile_token(&tok); +} + +static void statement (_SLang_Token_Type *); +static void compound_statement (_SLang_Token_Type *); +static void expression_with_parenthesis (_SLang_Token_Type *); +static void handle_semicolon (_SLang_Token_Type *); +static void statement_list (_SLang_Token_Type *); +static void variable_list (_SLang_Token_Type *, unsigned char); +static void struct_declaration (_SLang_Token_Type *); +static void define_function_args (_SLang_Token_Type *); +static void typedef_definition (_SLang_Token_Type *); +static void function_args_expression (_SLang_Token_Type *, int); +static void expression (_SLang_Token_Type *); +static void expression_with_commas (_SLang_Token_Type *, int); +static void simple_expression (_SLang_Token_Type *); +static void unary_expression (_SLang_Token_Type *); +static void postfix_expression (_SLang_Token_Type *); +static int check_for_lvalue (unsigned char, _SLang_Token_Type *); +/* static void primary_expression (_SLang_Token_Type *); */ +static void block (_SLang_Token_Type *); +static void inline_array_expression (_SLang_Token_Type *); +static void array_index_expression (_SLang_Token_Type *); +static void do_multiple_assignment (_SLang_Token_Type *); +static void try_multiple_assignment (_SLang_Token_Type *); +#if 0 +static void not_implemented (char *what) +{ + char err [256]; + sprintf (err, "Expression not implemented: %s", what); + _SLparse_error (err, NULL, 0); +} +#endif +static void rpn_parse_line (_SLang_Token_Type *tok) +{ + do + { + /* multiple RPN tokens possible when the file looks like: + * . + * . + */ + if (tok->type != RPN_TOKEN) + compile_token (tok); + free_token (tok); + } + while (EOF_TOKEN != _SLget_rpn_token (tok)); +} + +static int get_identifier_token (_SLang_Token_Type *tok) +{ + if (IDENT_TOKEN == get_token (tok)) + return IDENT_TOKEN; + + _SLparse_error ("Expecting identifier", tok, 0); + return tok->type; +} + +static void define_function (_SLang_Token_Type *ctok, unsigned char type) +{ + _SLang_Token_Type fname; + + switch (type) + { + case STATIC_TOKEN: + type = DEFINE_STATIC_TOKEN; + break; + + case PUBLIC_TOKEN: + type = DEFINE_PUBLIC_TOKEN; + break; + + case PRIVATE_TOKEN: + type = DEFINE_PRIVATE_TOKEN; + } + + init_token (&fname); + if (IDENT_TOKEN != get_identifier_token (&fname)) + { + free_token (&fname); + return; + } + + compile_token_of_type(OPAREN_TOKEN); + get_token (ctok); + define_function_args (ctok); + compile_token_of_type(FARG_TOKEN); + + if (ctok->type == OBRACE_TOKEN) + compound_statement(ctok); + + else if (ctok->type != SEMICOLON_TOKEN) + { + _SLparse_error("Expecting {", ctok, 0); + free_token (&fname); + return; + } + + fname.type = type; + compile_token (&fname); + free_token (&fname); +} + +/* statement: + * compound-statement + * if ( expression ) statement + * if ( expression ) statement else statement + * !if ( expression ) statement + * loop ( expression ) statement + * _for ( expression ) statement + * foreach ( expression ) statement + * foreach (expression ) using (expression-list) statement + * while ( expression ) statement + * do statement while (expression) ; + * for ( expressionopt ; expressionopt ; expressionopt ) statement + * ERROR_BLOCK statement + * EXIT_BLOCK statement + * USER_BLOCK0 statement + * USER_BLOCK1 statement + * USER_BLOCK2 statement + * USER_BLOCK3 statement + * USER_BLOCK4 statement + * forever statement + * break ; + * continue ; + * return expressionopt ; + * variable variable-list ; + * struct struct-decl ; + * define identifier function-args ; + * define identifier function-args compound-statement + * switch ( expression ) statement + * rpn-line + * at-line + * push ( expression ) + * ( expression ) = expression ; + * expression ; + * expression : + */ + +/* Note: This function does not return with a new token. It is up to the + * calling routine to handle that. + */ +static void statement (_SLang_Token_Type *ctok) +{ + unsigned char type; + + if (SLang_Error) + return; + + LLT->parse_level += 1; + + switch (ctok->type) + { + case OBRACE_TOKEN: + compound_statement (ctok); + break; + + case IF_TOKEN: + case IFNOT_TOKEN: + type = ctok->type; + get_token (ctok); + expression_with_parenthesis (ctok); + block (ctok); + + if (ELSE_TOKEN != get_token (ctok)) + { + compile_token_of_type (type); + unget_token (ctok); + break; + } + get_token (ctok); + block (ctok); + if (type == IF_TOKEN) type = ELSE_TOKEN; else type = NOTELSE_TOKEN; + compile_token_of_type (type); + break; + + /* case IFNOT_TOKEN: */ + case LOOP_TOKEN: + case _FOR_TOKEN: + type = ctok->type; + get_token (ctok); + expression_with_parenthesis (ctok); + block (ctok); + compile_token_of_type (type); + break; + + case FOREACH_TOKEN: + get_token (ctok); + expression_with_parenthesis (ctok); + + if (NULL == push_token_list ()) + break; + + append_token_of_type (ARG_TOKEN); + if (ctok->type == USING_TOKEN) + { + if (OPAREN_TOKEN != get_token (ctok)) + { + _SLparse_error ("Expected 'using ('", ctok, 0); + break; + } + get_token (ctok); + function_args_expression (ctok, 0); + } + append_token_of_type (EARG_TOKEN); + + compile_token_list (); + + block (ctok); + compile_token_of_type (FOREACH_TOKEN); + break; + + case WHILE_TOKEN: + get_token (ctok); + compile_token_of_type (OBRACE_TOKEN); + expression_with_parenthesis (ctok); + compile_token_of_type (CBRACE_TOKEN); + block (ctok); + compile_token_of_type (WHILE_TOKEN); + break; + + case DO_TOKEN: + get_token (ctok); + block (ctok); + + if (WHILE_TOKEN != get_token (ctok)) + { + _SLparse_error("Expecting while", ctok, 0); + break; + } + + get_token (ctok); + + compile_token_of_type (OBRACE_TOKEN); + expression_with_parenthesis (ctok); + compile_token_of_type (CBRACE_TOKEN); + compile_token_of_type (DOWHILE_TOKEN); + handle_semicolon (ctok); + break; + + case FOR_TOKEN: + + /* Look for (exp_opt ; exp_opt ; exp_opt ) */ + + if (OPAREN_TOKEN != get_token (ctok)) + { + _SLparse_error("Expecting (.", ctok, 0); + break; + } + + if (NULL == push_token_list ()) + break; + + append_token_of_type (OBRACE_TOKEN); + if (SEMICOLON_TOKEN != get_token (ctok)) + { + expression (ctok); + if (ctok->type != SEMICOLON_TOKEN) + { + _SLparse_error("Expecting ;", ctok, 0); + break; + } + } + append_token_of_type (CBRACE_TOKEN); + + append_token_of_type (OBRACE_TOKEN); + if (SEMICOLON_TOKEN != get_token (ctok)) + { + expression (ctok); + if (ctok->type != SEMICOLON_TOKEN) + { + _SLparse_error("Expecting ;", ctok, 0); + break; + } + } + append_token_of_type (CBRACE_TOKEN); + + append_token_of_type (OBRACE_TOKEN); + if (CPAREN_TOKEN != get_token (ctok)) + { + expression (ctok); + if (ctok->type != CPAREN_TOKEN) + { + _SLparse_error("Expecting ).", ctok, 0); + break; + } + } + append_token_of_type (CBRACE_TOKEN); + + compile_token_list (); + + get_token (ctok); + block (ctok); + compile_token_of_type (FOR_TOKEN); + break; + + case ERRBLK_TOKEN: + case EXITBLK_TOKEN: + case USRBLK0_TOKEN: + case USRBLK1_TOKEN: + case USRBLK2_TOKEN: + case USRBLK3_TOKEN: + case USRBLK4_TOKEN: + case FOREVER_TOKEN: + type = ctok->type; + get_token (ctok); + block (ctok); + compile_token_of_type (type); + break; + + case BREAK_TOKEN: + case CONT_TOKEN: + compile_token_of_type (ctok->type); + get_token (ctok); + handle_semicolon (ctok); + break; + + case RETURN_TOKEN: + if (SEMICOLON_TOKEN != get_token (ctok)) + { + if (NULL == push_token_list ()) + break; + + expression (ctok); + + if (ctok->type != SEMICOLON_TOKEN) + { + _SLparse_error ("Expecting ;", ctok, 0); + break; + } + compile_token_list (); + } + compile_token_of_type (RETURN_TOKEN); + handle_semicolon (ctok); + break; + + case STATIC_TOKEN: + case PRIVATE_TOKEN: + case PUBLIC_TOKEN: + type = ctok->type; + get_token (ctok); + if (ctok->type == VARIABLE_TOKEN) + { + get_token (ctok); + variable_list (ctok, type); + handle_semicolon (ctok); + break; + } + if (ctok->type == DEFINE_TOKEN) + { + define_function (ctok, type); + break; + } + _SLparse_error ("Expecting 'variable' or 'define'", ctok, 0); + break; + + case VARIABLE_TOKEN: + get_token (ctok); + variable_list (ctok, OBRACKET_TOKEN); + handle_semicolon (ctok); + break; + + case TYPEDEF_TOKEN: + get_token (ctok); + if (NULL == push_token_list ()) + break; + typedef_definition (ctok); + compile_token_list (); + + handle_semicolon (ctok); + break; + + case DEFINE_TOKEN: + define_function (ctok, DEFINE_TOKEN); + break; + + case SWITCH_TOKEN: + get_token (ctok); + expression_with_parenthesis (ctok); + + while ((SLang_Error == 0) + && (OBRACE_TOKEN == ctok->type)) + { + compile_token_of_type (OBRACE_TOKEN); + compound_statement (ctok); + compile_token_of_type (CBRACE_TOKEN); + get_token (ctok); + } + compile_token_of_type (SWITCH_TOKEN); + unget_token (ctok); + break; + + case EOF_TOKEN: + break; +#if 0 + case PUSH_TOKEN: + get_token (ctok); + expression_list_with_parenthesis (ctok); + handle_semicolon (ctok); + break; +#endif + + case SEMICOLON_TOKEN: + handle_semicolon (ctok); + break; + + case RPN_TOKEN: + if (POUND_TOKEN == get_token (ctok)) + _SLcompile_byte_compiled (); + else if (ctok->type != EOF_TOKEN) + rpn_parse_line (ctok); + break; + + case OPAREN_TOKEN: /* multiple assignment */ + try_multiple_assignment (ctok); + if (ctok->type == COLON_TOKEN) + compile_token_of_type (COLON_TOKEN); + else handle_semicolon (ctok); + break; + + default: + + if (NULL == push_token_list ()) + break; + + expression (ctok); + compile_token_list (); + + if (ctok->type == COLON_TOKEN) + compile_token_of_type (COLON_TOKEN); + else handle_semicolon (ctok); + break; + } + + LLT->parse_level -= 1; +} + +static void block (_SLang_Token_Type *ctok) +{ + compile_token_of_type (OBRACE_TOKEN); + statement (ctok); + compile_token_of_type (CBRACE_TOKEN); +} + +/* + * statement-list: + * statement + * statement-list statement + */ +static void statement_list (_SLang_Token_Type *ctok) +{ + while ((SLang_Error == 0) + && (ctok->type != CBRACE_TOKEN) + && (ctok->type != EOF_TOKEN)) + { + statement(ctok); + get_token (ctok); + } +} + +/* compound-statement: + * { statement-list } + */ +static void compound_statement (_SLang_Token_Type *ctok) +{ + /* ctok->type is OBRACE_TOKEN here */ + get_token (ctok); + statement_list(ctok); + if (CBRACE_TOKEN != ctok->type) + { + _SLparse_error ("Expecting '}'", ctok, 0); + return; + } +} + +/* This function is only called from statement. */ +static void expression_with_parenthesis (_SLang_Token_Type *ctok) +{ + if (ctok->type != OPAREN_TOKEN) + { + _SLparse_error("Expecting (", ctok, 0); + return; + } + + if (NULL == push_token_list ()) + return; + + get_token (ctok); + expression (ctok); + + if (ctok->type != CPAREN_TOKEN) + _SLparse_error("Expecting )", ctok, 0); + + compile_token_list (); + + get_token (ctok); +} + +static void handle_semicolon (_SLang_Token_Type *ctok) +{ + if ((ctok->type == SEMICOLON_TOKEN) + || (ctok->type == EOF_TOKEN)) + return; + + _SLparse_error ("Expecting ;", ctok, 0); +} + +void _SLparse_start (SLang_Load_Type *llt) +{ + _SLang_Token_Type ctok; + SLang_Load_Type *save_llt; + unsigned int save_use_next_token; + _SLang_Token_Type save_next_token; + Token_List_Type *save_list; +#if _SLANG_HAS_DEBUG_CODE + int save_last_line_number = Last_Line_Number; + + Last_Line_Number = -1; +#endif + save_use_next_token = Use_Next_Token; + save_next_token = Next_Token; + save_list = Token_List; + save_llt = LLT; + LLT = llt; + + init_token (&Next_Token); + Use_Next_Token = 0; + init_token (&ctok); + get_token (&ctok); + + llt->parse_level = 0; + statement_list (&ctok); + + if ((SLang_Error == 0) + && (ctok.type != EOF_TOKEN)) + _SLparse_error ("Parse ended prematurely", &ctok, 0); + + + if (SLang_Error) + { + if (SLang_Error < 0) /* severe error */ + save_list = NULL; + + while (Token_List != save_list) + { + if (-1 == pop_token_list (1)) + break; /* ??? when would this happen? */ + } + } + + free_token (&ctok); + LLT = save_llt; + if (Use_Next_Token) + free_token (&Next_Token); + Use_Next_Token = save_use_next_token; + Next_Token = save_next_token; +#if _SLANG_HAS_DEBUG_CODE + Last_Line_Number = save_last_line_number; +#endif +} + +/* variable-list: + * variable-decl + * variable-decl variable-list + * + * variable-decl: + * identifier + * identifier = simple-expression + */ +static void variable_list (_SLang_Token_Type *name_token, unsigned char variable_type) +{ + int declaring; + _SLang_Token_Type tok; + + if (name_token->type != IDENT_TOKEN) + { + _SLparse_error ("Expecting a variable name", name_token, 0); + return; + } + + declaring = 0; + do + { + if (declaring == 0) + { + declaring = 1; + compile_token_of_type (variable_type); + } + + compile_token (name_token); + + init_token (&tok); + if (ASSIGN_TOKEN == get_token (&tok)) + { + compile_token_of_type (CBRACKET_TOKEN); + declaring = 0; + + get_token (&tok); + + push_token_list (); + simple_expression (&tok); + compile_token_list (); + + name_token->type = _SCALAR_ASSIGN_TOKEN; + compile_token (name_token); + } + + free_token (name_token); + *name_token = tok; + } + while ((name_token->type == COMMA_TOKEN) + && (IDENT_TOKEN == get_token (name_token))); + + if (declaring) compile_token_of_type (CBRACKET_TOKEN); +} + +/* struct-declaration: + * struct { struct-field-list }; + * + * struct-field-list: + * struct-field-name , struct-field-list + * struct-field-name + * + * Generates code: "field-name-1" ... "field-name-N" N STRUCT_TOKEN + */ +static void struct_declaration (_SLang_Token_Type *ctok) +{ + int n; + _SLang_Token_Type num_tok; + + if (ctok->type != OBRACE_TOKEN) + { + _SLparse_error ("Expecting {", ctok, 0); + return; + } + + n = 0; + while (IDENT_TOKEN == get_token (ctok)) + { + n++; + ctok->type = STRING_TOKEN; + append_token (ctok); + if (COMMA_TOKEN != get_token (ctok)) + break; + } + + if (ctok->type != CBRACE_TOKEN) + { + _SLparse_error ("Expecting }", ctok, 0); + return; + } + if (n == 0) + { + _SLparse_error ("struct requires at least 1 field", ctok, 0); + return; + } + + init_token (&num_tok); + num_tok.type = INT_TOKEN; + num_tok.v.long_val = n; + append_token (&num_tok); + append_token_of_type (STRUCT_TOKEN); + + get_token (ctok); +} + +/* struct-declaration: + * typedef struct { struct-field-list } Type_Name; + * + * struct-field-list: + * struct-field-name , struct-field-list + * struct-field-name + * + * Generates code: "field-name-1" ... "field-name-N" N STRUCT_TOKEN typedef + */ +static void typedef_definition (_SLang_Token_Type *t) +{ + + if (t->type != STRUCT_TOKEN) + { + _SLparse_error ("Expecting `struct'", t, 0); + return; + } + get_token (t); + + struct_declaration (t); + if (t->type != IDENT_TOKEN) + { + _SLparse_error ("Expecting identifier", t, 0); + return; + } + + t->type = STRING_TOKEN; + append_token (t); + append_token_of_type (TYPEDEF_TOKEN); + + get_token (t); +} + +/* function-args: + * ( args-dec-opt ) + * + * args-decl-opt: + * identifier + * args-decl , identifier + */ +static void define_function_args (_SLang_Token_Type *ctok) +{ + if (CPAREN_TOKEN == get_token (ctok)) + { + get_token (ctok); + return; + } + + compile_token_of_type(OBRACKET_TOKEN); + + while ((SLang_Error == 0) + && (ctok->type == IDENT_TOKEN)) + { + compile_token (ctok); + if (COMMA_TOKEN != get_token (ctok)) + break; + + get_token (ctok); + } + + if (CPAREN_TOKEN != ctok->type) + { + _SLparse_error("Expecting )", ctok, 0); + return; + } + compile_token_of_type(CBRACKET_TOKEN); + + get_token (ctok); +} + +void try_multiple_assignment (_SLang_Token_Type *ctok) +{ + /* This is called with ctok->type == OPAREN_TOKEN. We have no idea + * what follows this. There are various possibilities such as: + * @ () = x; + * @ ( expression ) = x; + * @ ( expression ) ; + * @ ( expression ) OP expression; + * @ ( expression ) [expression] = expression; + * and only the first two constitute a multiple assignment. The last + * two forms create the difficulty. + * + * Here is the plan. First parse (expression) and then check next token. + * If it is an equal operator, then it will be parsed as a multiple + * assignment. In fact, that is the easy part. + * + * The hard part stems from the fact that by parsing (expression), we + * have effectly truncated the parse if (expression) is part of a binary + * or unary expression. Somehow, the parsing must be resumed. The trick + * here is to use a dummy literal that generates no code: NO_OP_LITERAL + * Using it, we just call 'expression' and proceed. + */ + + if (NULL == push_token_list ()) + return; + + get_token (ctok); + + if (ctok->type != CPAREN_TOKEN) + { + expression_with_commas (ctok, 1); + if (ctok->type != CPAREN_TOKEN) + { + _SLparse_error ("Expecting )", ctok, 0); + return; + } + } + + switch (get_token (ctok)) + { + case ASSIGN_TOKEN: + case PLUSEQS_TOKEN: + case MINUSEQS_TOKEN: + case TIMESEQS_TOKEN: + case DIVEQS_TOKEN: + case BOREQS_TOKEN: + case BANDEQS_TOKEN: + do_multiple_assignment (ctok); + pop_token_list (1); + break; + + default: + unget_token (ctok); + ctok->type = NO_OP_LITERAL; + expression (ctok); + compile_token_list (); + break; + } +} + +/* Note: expression never gets compiled directly. Rather, it gets + * appended to the token list and then compiled by a calling + * routine. + */ + +/* expression: + * simple_expression + * simple-expression , expression + * + */ +static void expression_with_commas (_SLang_Token_Type *ctok, int save_comma) +{ + while (SLang_Error == 0) + { + if (ctok->type != COMMA_TOKEN) + { + if (ctok->type == CPAREN_TOKEN) + return; + + simple_expression (ctok); + + if (ctok->type != COMMA_TOKEN) + break; + } + if (save_comma) append_token (ctok); + get_token (ctok); + } +} + +static void expression (_SLang_Token_Type *ctok) +{ + expression_with_commas (ctok, 0); +} + +/* priority levels of binary operations */ +static unsigned char Binop_Level[] = +{ +/* ADD_TOKEN */ 2, +/* SUB_TOKEN */ 2, +/* MUL_TOKEN */ 1, +/* DIV_TOKEN */ 1, +/* LT_TOKEN */ 4, +/* LE_TOKEN */ 4, +/* GT_TOKEN */ 4, +/* GE_TOKEN */ 4, +/* EQ_TOKEN */ 5, +/* NE_TOKEN */ 5, +/* AND_TOKEN */ 9, +/* OR_TOKEN */ 10, +/* MOD_TOKEN */ 1, +/* BAND_TOKEN */ 6, +/* SHL_TOKEN */ 3, +/* SHR_TOKEN */ 3, +/* BXOR_TOKEN */ 7, +/* BOR_TOKEN */ 8, +/* POUND_TOKEN */ 1 /* Matrix Multiplication */ +}; + +/* % Note: simple-expression groups operators OP1 at same level. The + * % actual implementation will not do this. + * simple-expression: + * unary-expression + * binary-expression BINARY-OP unary-expression + * andelse xxelse-expression-list + * orelse xxelse-expression-list + * + * xxelse-expression-list: + * { expression } + * xxelse-expression-list { expression } + * binary-expression: + * unary-expression + * unary-expression BINARY-OP binary-expression + */ +static void simple_expression (_SLang_Token_Type *ctok) +{ + unsigned char type; + unsigned char op_stack [64]; + unsigned char level_stack [64]; + unsigned char level; + unsigned int op_num; + + switch (ctok->type) + { + case ANDELSE_TOKEN: + case ORELSE_TOKEN: + type = ctok->type; + if (OBRACE_TOKEN != get_token (ctok)) + { + _SLparse_error ("Expecting '{'", ctok, 0); + return; + } + + while (ctok->type == OBRACE_TOKEN) + { + append_token (ctok); + get_token (ctok); + expression (ctok); + if (CBRACE_TOKEN != ctok->type) + { + _SLparse_error("Expecting }", ctok, 0); + return; + } + append_token (ctok); + get_token (ctok); + } + append_token_of_type (type); + return; + + /* avoid unary-expression if possible */ + case STRING_TOKEN: + append_token (ctok); + get_token (ctok); + break; + + default: + unary_expression (ctok); + break; + } + + if (SEMICOLON_TOKEN == (type = ctok->type)) + return; + + op_num = 0; + + while ((SLang_Error == 0) + && (IS_BINARY_OP(type))) + { + level = Binop_Level[type - FIRST_BINARY_OP]; + + while ((op_num > 0) && (level_stack [op_num - 1] <= level)) + append_token_of_type (op_stack [--op_num]); + + if (op_num >= sizeof (op_stack) - 1) + { + _SLparse_error ("Binary op stack overflow", ctok, 0); + return; + } + + op_stack [op_num] = type; + level_stack [op_num] = level; + op_num++; + + get_token (ctok); + unary_expression (ctok); + type = ctok->type; + } + + while (op_num > 0) + append_token_of_type(op_stack[--op_num]); +} + +/* unary-expression: + * postfix-expression + * ++ postfix-expression + * -- postfix-expression + * case unary-expression + * OP3 unary-expression + * (OP3: + - ~ & not @) + * + * Note: This grammar permits: case case case WHATEVER + */ +static void unary_expression (_SLang_Token_Type *ctok) +{ + unsigned char save_unary_ops [16]; + unsigned int num_unary_ops; + unsigned char type; + _SLang_Token_Type *last_token; + + num_unary_ops = 0; + while (SLang_Error == 0) + { + type = ctok->type; + + switch (type) + { + case PLUSPLUS_TOKEN: + case MINUSMINUS_TOKEN: + get_token (ctok); + postfix_expression (ctok); + check_for_lvalue (type, NULL); + goto out_of_switch; + + case ADD_TOKEN: + get_token (ctok); /* skip it-- it's unary here */ + break; + + case SUB_TOKEN: + (void) get_token (ctok); + if (IS_INTEGER_TOKEN (ctok->type)) + { + ctok->v.long_val = -ctok->v.long_val; + break; + } + + if (num_unary_ops == 16) + goto stack_overflow_error; + save_unary_ops [num_unary_ops++] = CHS_TOKEN; + break; + + case DEREF_TOKEN: + case BNOT_TOKEN: + case NOT_TOKEN: + case CASE_TOKEN: + if (num_unary_ops == 16) + goto stack_overflow_error; + + save_unary_ops [num_unary_ops++] = type; + get_token (ctok); + break; + + /* Try to avoid ->postfix_expression->primary_expression + * subroutine calls. + */ + case STRING_TOKEN: + append_token (ctok); + get_token (ctok); + goto out_of_switch; + + default: + postfix_expression (ctok); + goto out_of_switch; + } + } + + out_of_switch: + if (num_unary_ops == 0) + return; + + if ((DEREF_TOKEN == save_unary_ops[num_unary_ops - 1]) + && (NULL != (last_token = get_last_token ())) + && (IS_ASSIGN_TOKEN(last_token->type))) + { + /* FIXME: Priority=medium + * This needs generalized so that things like @a.y = 1 will work properly. + */ + if ((num_unary_ops != 1) + || (last_token->type != _SCALAR_ASSIGN_TOKEN)) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Only derefence assignments to simple variables are possible"); + return; + } + + last_token->type += (_DEREF_ASSIGN_TOKEN - _SCALAR_ASSIGN_TOKEN); + return; + } + + while (num_unary_ops) + { + num_unary_ops--; + append_token_of_type (save_unary_ops [num_unary_ops]); + } + return; + + stack_overflow_error: + _SLparse_error ("Too many unary operators.", ctok, 0); +} + +static int combine_namespace_tokens (_SLang_Token_Type *a, _SLang_Token_Type *b) +{ + char *sa, *sb, *sc; + unsigned int lena, lenb; + unsigned long hash; + + /* This is somewhat of a hack. Combine the TWO identifier names + * (NAMESPACE) and (name) into the form NAMESPACE->name. Then when the + * byte compiler compiles the object it will not be found. It will then + * check for this hack and make the appropriate namespace lookup. + */ + + sa = a->v.s_val; + sb = b->v.s_val; + + lena = strlen (sa); + lenb = strlen (sb); + + sc = SLmalloc (lena + lenb + 3); + if (sc == NULL) + return -1; + + strcpy (sc, sa); + strcpy (sc + lena, "->"); + strcpy (sc + lena + 2, sb); + + sb = _SLstring_make_hashed_string (sc, lena + lenb + 2, &hash); + SLfree (sc); + if (sb == NULL) + return -1; + + /* I can free this string because no other token should be referencing it. + * (num_refs == 1). + */ + _SLfree_hashed_string (sa, lena, a->hash); + a->v.s_val = sb; + a->hash = hash; + + return 0; +} + +static void append_identifier_token (_SLang_Token_Type *ctok) +{ + _SLang_Token_Type *last_token; + + append_token (ctok); + + if (NAMESPACE_TOKEN != get_token (ctok)) + return; + + if (IDENT_TOKEN != get_token (ctok)) + { + _SLparse_error ("Expecting name-space identifier", ctok, 0); + return; + } + + last_token = get_last_token (); + if (-1 == combine_namespace_tokens (last_token, ctok)) + return; + + (void) get_token (ctok); +} + +static int get_identifier_expr_token (_SLang_Token_Type *ctok) +{ + _SLang_Token_Type next_token; + + if (IDENT_TOKEN != get_identifier_token (ctok)) + return -1; + + init_token (&next_token); + if (NAMESPACE_TOKEN != get_token (&next_token)) + { + unget_token (&next_token); + return IDENT_TOKEN; + } + + if (IDENT_TOKEN != get_identifier_token (&next_token)) + { + free_token (&next_token); + return -1; + } + + if (-1 == combine_namespace_tokens (ctok, &next_token)) + { + free_token (&next_token); + return -1; + } + free_token (&next_token); + return IDENT_TOKEN; +} + +/* postfix-expression: + * primary-expression + * postfix-expression [ expression ] + * postfix-expression ( function-args-expression ) + * postfix-expression . identifier + * postfix-expression ^ unary-expression + * postfix-expression ++ + * postfix-expression -- + * postfix-expression = simple-expression + * postfix-expression += simple-expression + * postfix-expression -= simple-expression + * + * primary-expression: + * literal + * identifier-expr + * ( expression_opt ) + * [ inline-array-expression ] + * &identifier-expr + * struct-definition + * __tmp(identifier-expr) + * + * identifier-expr: + * identifier + * identifier->identifier + */ +static void postfix_expression (_SLang_Token_Type *ctok) +{ + unsigned int start_pos, end_pos; + unsigned char type; + + if (Token_List == NULL) + return; + + start_pos = Token_List->len; + + switch (ctok->type) + { + case IDENT_TOKEN: + append_identifier_token (ctok); + break; + + case CHAR_TOKEN: + case SHORT_TOKEN: + case INT_TOKEN: + case LONG_TOKEN: + case UCHAR_TOKEN: + case USHORT_TOKEN: + case UINT_TOKEN: + case ULONG_TOKEN: + case STRING_TOKEN: + case BSTRING_TOKEN: +#ifdef SLANG_HAS_FLOAT + case DOUBLE_TOKEN: + case FLOAT_TOKEN: +#endif +#ifdef SLANG_HAS_COMPLEX + case COMPLEX_TOKEN: +#endif + append_token (ctok); + get_token (ctok); + break; + + case OPAREN_TOKEN: + if (CPAREN_TOKEN != get_token (ctok)) + { + expression (ctok); + if (ctok->type != CPAREN_TOKEN) + _SLparse_error("Expecting )", ctok, 0); + } + get_token (ctok); + break; + + case BAND_TOKEN: + if (IDENT_TOKEN != get_identifier_expr_token (ctok)) + break; + + ctok->type = _REF_TOKEN; + append_token (ctok); + get_token (ctok); + break; + + case OBRACKET_TOKEN: + get_token (ctok); + inline_array_expression (ctok); + break; + + case NO_OP_LITERAL: + /* This token was introduced by try_multiple_assignment. There, + * a new token_list was pushed and (expression) was evaluated. + * NO_OP_LITERAL represents the result of expression. However, + * we need to tweak the start_pos variable to point to the beginning + * of the token list to complete the equivalence. + */ + start_pos = 0; + get_token (ctok); + break; + + case STRUCT_TOKEN: + get_token (ctok); + struct_declaration (ctok); + break; + + case TMP_TOKEN: + get_token (ctok); + if (ctok->type == OPAREN_TOKEN) + { + if (IDENT_TOKEN == get_identifier_expr_token (ctok)) + { + ctok->type = TMP_TOKEN; + append_token (ctok); + get_token (ctok); + if (ctok->type == CPAREN_TOKEN) + { + get_token (ctok); + break; + } + } + } + _SLparse_error ("Expecting form __tmp(NAME)", ctok, 0); + break; + + default: + if (IS_INTERNAL_FUNC(ctok->type)) + { + append_token (ctok); + get_token (ctok); + } + else + _SLparse_error("Expecting a PRIMARY", ctok, 0); + } + + while (SLang_Error == 0) + { + end_pos = Token_List->len; + type = ctok->type; + switch (type) + { + case OBRACKET_TOKEN: /* X[args] ==> [args] X ARRAY */ + get_token (ctok); + append_token_of_type (ARG_TOKEN); + if (ctok->type != CBRACKET_TOKEN) + array_index_expression (ctok); + + if (ctok->type != CBRACKET_TOKEN) + { + _SLparse_error ("Expecting ']'", ctok, 0); + return; + } + get_token (ctok); + /* append_token_of_type (EARG_TOKEN); -- ARRAY_TOKEN implicitely does this */ + token_list_element_exchange (start_pos, end_pos); + append_token_of_type (ARRAY_TOKEN); + break; + + case OPAREN_TOKEN: + /* f(args) ==> args f */ + if (CPAREN_TOKEN != get_token (ctok)) + { + function_args_expression (ctok, 1); + token_list_element_exchange (start_pos, end_pos); + } + else get_token (ctok); + break; + + case DOT_TOKEN: + /* S.a ==> "a" S DOT + * This means that if S is X[b], then X[b].a ==> a b X ARRAY DOT + * and f(a).X[b].c ==> "c" b "X" a f . ARRAY . + * Also, f(a).X[b] = g(x); ==> x g b "X" a f . + */ + if (IDENT_TOKEN != get_identifier_token (ctok)) + return; + + ctok->type = DOT_TOKEN; + append_token (ctok); + get_token (ctok); + break; + + case PLUSPLUS_TOKEN: + case MINUSMINUS_TOKEN: + check_for_lvalue (type, NULL); + get_token (ctok); + break; + + case ASSIGN_TOKEN: + case PLUSEQS_TOKEN: + case MINUSEQS_TOKEN: + case TIMESEQS_TOKEN: + case DIVEQS_TOKEN: + case BOREQS_TOKEN: + case BANDEQS_TOKEN: + check_for_lvalue (type, NULL); + get_token (ctok); + simple_expression (ctok); + token_list_element_exchange (start_pos, end_pos); + break; + + case POW_TOKEN: + get_token (ctok); + unary_expression (ctok); + append_token_of_type (POW_TOKEN); + break; + + default: + return; + } + } +} + +static void function_args_expression (_SLang_Token_Type *ctok, int handle_num_args) +{ + unsigned char last_type, this_type; + + if (handle_num_args) append_token_of_type (ARG_TOKEN); + + last_type = COMMA_TOKEN; + + while (SLang_Error == 0) + { + this_type = ctok->type; + + switch (this_type) + { + case COMMA_TOKEN: + if (last_type == COMMA_TOKEN) + append_token_of_type (_NULL_TOKEN); + get_token (ctok); + break; + + case CPAREN_TOKEN: + if (last_type == COMMA_TOKEN) + append_token_of_type (_NULL_TOKEN); + if (handle_num_args) append_token_of_type (EARG_TOKEN); + get_token (ctok); + return; + + default: + simple_expression (ctok); + if ((ctok->type != COMMA_TOKEN) + && (ctok->type != CPAREN_TOKEN)) + { + _SLparse_error ("Expecting ')'", ctok, 0); + break; + } + } + last_type = this_type; + } +} + +static int check_for_lvalue (unsigned char eqs_type, _SLang_Token_Type *ctok) +{ + unsigned char type; + + if ((ctok == NULL) + && (NULL == (ctok = get_last_token ()))) + return -1; + + type = ctok->type; + + eqs_type -= ASSIGN_TOKEN; + + if (type == IDENT_TOKEN) + eqs_type += _SCALAR_ASSIGN_TOKEN; + else if (type == ARRAY_TOKEN) + eqs_type += _ARRAY_ASSIGN_TOKEN; + else if (type == DOT_TOKEN) + eqs_type += _STRUCT_ASSIGN_TOKEN; + else + { + _SLparse_error ("Expecting LVALUE", ctok, 0); + return -1; + } + + ctok->type = eqs_type; + return 0; +} + +static void array_index_expression (_SLang_Token_Type *ctok) +{ + unsigned int num_commas; + + num_commas = 0; + while (1) + { + switch (ctok->type) + { + case COLON_TOKEN: + if (num_commas) + _SLparse_error ("Misplaced ':'", ctok, 0); + return; + + case TIMES_TOKEN: + append_token_of_type (_INLINE_WILDCARD_ARRAY_TOKEN); + get_token (ctok); + break; + + case COMMA_TOKEN: + _SLparse_error ("Misplaced ','", ctok, 0); + return; + + default: + simple_expression (ctok); + } + + if (ctok->type != COMMA_TOKEN) + return; + num_commas++; + get_token (ctok); + } +} + +/* inline-array-expression: + * array_index_expression + * simple_expression : simple_expression + * simple_expression : simple_expression : simple_expression + */ +static void inline_array_expression (_SLang_Token_Type *ctok) +{ + int num_colons = 0; + + append_token_of_type (ARG_TOKEN); + + if (ctok->type == COLON_TOKEN) /* [:...] */ + append_token_of_type (_NULL_TOKEN); + else if (ctok->type != CBRACKET_TOKEN) + array_index_expression (ctok); + + if (ctok->type == COLON_TOKEN) + { + num_colons++; + if ((COLON_TOKEN == get_token (ctok)) + || (ctok->type == CBRACKET_TOKEN)) + append_token_of_type (_NULL_TOKEN); + else + simple_expression (ctok); + + if (ctok->type == COLON_TOKEN) + { + num_colons++; + get_token (ctok); + simple_expression (ctok); + } + } + + if (ctok->type != CBRACKET_TOKEN) + { + _SLparse_error ("Expecting ']'", ctok, 0); + return; + } + + /* append_token_of_type (EARG_TOKEN); */ + if (num_colons) + append_token_of_type (_INLINE_IMPLICIT_ARRAY_TOKEN); + else + append_token_of_type (_INLINE_ARRAY_TOKEN); + get_token (ctok); +} + +static void do_multiple_assignment (_SLang_Token_Type *ctok) +{ + _SLang_Token_Type *s; + unsigned int i, k, len; + unsigned char assign_type; + + assign_type = ctok->type; + + /* The LHS token list has already been pushed. Here we do the RHS + * so push to another token list, process it, then come back to + * LHS for assignment. + */ + if (NULL == push_token_list ()) + return; + + get_token (ctok); + expression (ctok); + compile_token_list (); + + if (SLang_Error) + return; + + /* Finally compile the LHS of the assignment expression + * that has been saved. + */ + s = Token_List->stack; + len = Token_List->len; + + if (len == 0) + { + compile_token_of_type (POP_TOKEN); + return; + } + + while (len > 0) + { + /* List is of form: + * a , b, c d e, f , g , , , h , + * The missing expressions will be replaced by a POP + * ,,a + */ + + /* Start from back looking for a COMMA */ + k = len - 1; + if (s[k].type == COMMA_TOKEN) + { + compile_token_of_type (POP_TOKEN); + len = k; + continue; + } + + if (-1 == check_for_lvalue (assign_type, s + k)) + return; + + i = 0; + while (1) + { + if (s[k].type == COMMA_TOKEN) + { + i = k + 1; + break; + } + + if (k == 0) + break; + + k--; + } + + while (i < len) + { + compile_token (s + i); + i++; + } + + len = k; + } + + if (s[0].type == COMMA_TOKEN) + compile_token_of_type (POP_TOKEN); +} + diff --git a/libslang/src/slpath.c b/libslang/src/slpath.c new file mode 100644 index 0000000..987ef47 --- /dev/null +++ b/libslang/src/slpath.c @@ -0,0 +1,398 @@ +/* Pathname and filename functions */ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#ifdef HAVE_IO_H +# include +#endif + +#include +#include +#include +#include + +#include +#include + +#include "slang.h" +#include "_slang.h" + +/* In this file, all file names are assumed to be specified in the Unix + * format, or in the native format. + * + * Aboout VMS: + * VMS pathnames are a mess. In general, they look like + * node::device:[dir.dir]file.ext;version + * and I do not know of a well-defined Unix representation for them. So, + * I am going to punt and encourage users to stick to the native + * representation. + */ + +#if defined(IBMPC_SYSTEM) +# define PATH_SEP '\\' +# define DRIVE_SPECIFIER ':' +# define SEARCH_PATH_DELIMITER ';' +# define THIS_DIR_STRING "." +#else +# if defined(VMS) +# define PATH_SEP ']' +# define DRIVE_SPECIFIER ':' +# define SEARCH_PATH_DELIMITER ' ' +# define THIS_DIR_STRING "[]" /* Is this correct?? */ +# else +# define PATH_SEP '/' +# define UNIX_PATHNAMES_OK +# define SEARCH_PATH_DELIMITER ':' +# define THIS_DIR_STRING "." +# endif +#endif + +#ifdef UNIX_PATHNAMES_OK +# define IS_PATH_SEP(x) ((x) == PATH_SEP) +#else +# define IS_PATH_SEP(x) (((x) == PATH_SEP) || ((x) == '/')) +#endif + +static char Path_Delimiter = SEARCH_PATH_DELIMITER; + +/* If file is /a/b/c/basename, this function returns a pointer to basename */ +char *SLpath_basename (char *file) +{ + char *b; + + if (file == NULL) return NULL; + b = file + strlen (file); + + while (b != file) + { + b--; + if (IS_PATH_SEP(*b)) + return b + 1; +#ifdef DRIVE_SPECIFIER + if (*b == DRIVE_SPECIFIER) + return b + 1; +#endif + } + + return b; +} + +/* Returns a malloced string */ +char *SLpath_pathname_sans_extname (char *file) +{ + char *b; + + file = SLmake_string (file); + if (file == NULL) + return NULL; + + b = file + strlen (file); + + while (b != file) + { + b--; + if (*b == '.') + { + *b = 0; + return file; + } + } + + return file; +} + +/* If path looks like: A/B/C/D/whatever, it returns A/B/C/D as a malloced + * string. + */ +char *SLpath_dirname (char *file) +{ + char *b; + + if (file == NULL) return NULL; + b = file + strlen (file); + + while (b != file) + { + b--; + if (IS_PATH_SEP(*b)) + { + if (b == file) b++; + break; + } + +#ifdef DRIVE_SPECIFIER + if (*b == DRIVE_SPECIFIER) + { + b++; + break; + } +#endif + } + + if (b == file) + return SLmake_string (THIS_DIR_STRING); + + return SLmake_nstring (file, (unsigned int) (b - file)); +} + +/* Note: VMS filenames also contain version numbers. The caller will have + * to deal with that. + * + * The extension includes the '.'. If no extension is present, "" is returned. + */ +char *SLpath_extname (char *file) +{ + char *b; + + if (NULL == (file = SLpath_basename (file))) + return NULL; + + b = file + strlen (file); + while (b != file) + { + b--; + if (*b == '.') + return b; + } + + if (*b == '.') + return b; + + /* Do not return a literal "" */ + return file + strlen (file); +} + +#ifdef IBMPC_SYSTEM +static void convert_slashes (char *f) +{ + while (*f) + { + if (*f == '/') *f = PATH_SEP; + f++; + } +} +#endif + +int SLpath_is_absolute_path (char *name) +{ + if (name == NULL) + return -1; + +#ifdef UNIX_PATHNAMES_OK + return (*name == '/'); +#else + if (IS_PATH_SEP (*name)) + return 1; + +# ifdef DRIVE_SPECIFIER + /* Look for a drive specifier */ + while (*name) + { + if (*name == DRIVE_SPECIFIER) + return 1; + + name++; + } +# endif + + return 0; +#endif +} + + +/* This returns a MALLOCED string */ +char *SLpath_dircat (char *dir, char *name) +{ + unsigned int len, dirlen; + char *file; +#ifndef VMS + int requires_fixup; +#endif + + if (name == NULL) + name = ""; + + if ((dir == NULL) || (SLpath_is_absolute_path (name))) + dir = ""; + + /* Both VMS and MSDOS have default directories associated with each drive. + * That is, the meaning of something like C:X depends upon more than just + * the syntax of the string. Since this concept has more power under VMS + * it will be honored here. However, I am going to treat C:X as C:\X + * under MSDOS. + * + * Note!!! + * VMS has problems of its own regarding path names, so I am simply + * going to strcat. Hopefully the VMS RTL is smart enough to deal with + * the result. + */ + dirlen = strlen (dir); +#ifndef VMS + requires_fixup = (dirlen && (0 == IS_PATH_SEP(dir[dirlen - 1]))); +#endif + + len = dirlen + strlen (name) + 2; + if (NULL == (file = SLmalloc (len))) + return NULL; + + strcpy (file, dir); + +#ifndef VMS + if (requires_fixup) + file[dirlen++] = PATH_SEP; +#endif + + strcpy (file + dirlen, name); + +#if defined(IBMPC_SYSTEM) + convert_slashes (file); +#endif + + return file; +} + +int SLpath_file_exists (char *file) +{ + struct stat st; + int m; + +#if defined(__os2__) && !defined(S_IFMT) +/* IBM VA3 doesn't declare S_IFMT */ +# define S_IFMT (S_IFDIR | S_IFCHR | S_IFREG) +#endif + +#ifdef _S_IFDIR +# ifndef S_IFDIR +# define S_IFDIR _S_IFDIR +# endif +#endif + +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +#endif + + if (file == NULL) + return -1; + + if (stat(file, &st) < 0) return 0; + m = st.st_mode; + + if (S_ISDIR(m)) return (2); + return 1; +} + +/* By relatively-absolute, I mean paths of the form ./foo, + * and ../foo/bar. But not foo/bar. + */ +static int is_relatively_absolute (char *file) +{ + if (file == NULL) + return -1; + if (SLpath_is_absolute_path (file)) + return 1; + +#if defined(VMS) + return (*file == '['); +#else + if (*file == '.') file++; + if (*file == '.') file++; + return (*file == PATH_SEP); +#endif +} + +char *SLpath_find_file_in_path (char *path, char *name) +{ + unsigned int max_path_len; + unsigned int this_path_len; + char *file, *dir; + char *p; + unsigned int nth; + + if ((path == NULL) || (*path == 0) + || (name == NULL) || (*name == 0)) + return NULL; + + if (is_relatively_absolute (name)) + { + if (0 == SLpath_file_exists (name)) + return NULL; + return SLmake_string (name); + } + + /* Allow "." to mean the current directory on all systems */ + if ((path[0] == '.') && (path[1] == 0)) + { + if (0 == SLpath_file_exists (name)) + return NULL; + return SLpath_dircat (THIS_DIR_STRING, name); + } + + max_path_len = 0; + this_path_len = 0; + p = path; + while (*p != 0) + { + if (*p++ == Path_Delimiter) + { + if (this_path_len > max_path_len) max_path_len = this_path_len; + this_path_len = 0; + } + else this_path_len++; + } + if (this_path_len > max_path_len) max_path_len = this_path_len; + max_path_len++; + + if (NULL == (dir = SLmalloc (max_path_len))) + return NULL; + + nth = 0; + while (-1 != SLextract_list_element (path, nth, Path_Delimiter, + dir, max_path_len)) + { + nth++; + if (*dir == 0) + continue; + + if (NULL == (file = SLpath_dircat (dir, name))) + { + SLfree (dir); + return NULL; + } + + if (1 == SLpath_file_exists (file)) + { + SLfree (dir); + return file; + } + + SLfree (file); + } + + SLfree (dir); + return NULL; +} + +int SLpath_get_delimiter (void) +{ + return Path_Delimiter; +} + +int SLpath_set_delimiter (int d) +{ + char ch = (char) d; + if (ch == 0) + return -1; + + Path_Delimiter = ch; + return 0; +} diff --git a/libslang/src/slposdir.c b/libslang/src/slposdir.c new file mode 100644 index 0000000..1564a3d --- /dev/null +++ b/libslang/src/slposdir.c @@ -0,0 +1,1059 @@ +/* file intrinsics for S-Lang */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if defined(__unix__) || (defined (__os2__) && defined (__EMX__)) +# include +#endif + +#ifdef HAVE_IO_H +# include /* for chmod */ +#endif + +#if defined(__BORLANDC__) +# include +# include +#endif + +#ifdef HAVE_FCNTL_H +# include +#endif +#ifdef HAVE_SYS_FCNTL_H +# include +#endif + +#ifdef __unix__ +# include +#endif + +#if defined(__BORLANDC__) +# include +#endif + +#if defined(_MSC_VER) +# include +#endif + +#if defined(__DECC) && defined(VMS) +# include +# include +#endif + +#ifdef VMS +# include +#else +# include +#endif + +#if defined(VMS) +# define USE_LISTDIR_INTRINSIC 0 +#else +# define USE_LISTDIR_INTRINSIC 1 +#endif + +#if USE_LISTDIR_INTRINSIC + +#if defined(__WIN32__) +# include +#else +# if defined(__OS2__) && defined(__IBMC__) +# define INCL_DOS +# define INCL_ERRORS +# include +# include +# include +# else +# ifdef HAVE_DIRENT_H +# include +# else +# ifdef HAVE_DIRECT_H +# include +# else +# define dirent direct +# define NEED_D_NAMLEN +# if HAVE_SYS_NDIR_H +# include +# endif +# if HAVE_SYS_DIR_H +# include +# endif +# if HAVE_NDIR_H +# include +# endif +# endif +# endif +# endif +#endif + +#endif /* USE_LISTDIR_INTRINSIC */ + +#include + +#include "slang.h" +#include "_slang.h" + +typedef struct +{ + struct stat st; + int st_opt_attrs; +} +Stat_Type; + +static SLang_CStruct_Field_Type Stat_Struct [] = +{ + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_dev, "st_dev", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_ino, "st_ino", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_mode, "st_mode", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_nlink, "st_nlink", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_uid, "st_uid", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_gid, "st_gid", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_rdev, "st_rdev", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_size, "st_size", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_atime, "st_atime", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_mtime, "st_mtime", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st.st_ctime, "st_ctime", 0), + MAKE_CSTRUCT_INT_FIELD(Stat_Type, st_opt_attrs, "st_opt_attrs", 0), + SLANG_END_CSTRUCT_TABLE +}; + +static int push_stat_struct (struct stat *st, int opt_attrs) +{ + Stat_Type s; + + s.st = *st; + s.st_opt_attrs = opt_attrs; + return SLang_push_cstruct ((VOID_STAR) &s, Stat_Struct); +} + +static void stat_cmd (char *file) +{ + struct stat st; + int status; + int opt_attrs; + + status = stat (file, &st); + +#if defined(__MSDOS__) || defined(__WIN32__) + if (status == -1) + { + unsigned int len = strlen (file); + if (len && ((file[len-1] == '\\') || (file[len-1] == '/'))) + { + file = SLmake_nstring (file, len-1); + if (file == NULL) + return; + + status = stat (file, &st); + SLfree (file); + } + } +#endif + if (status == -1) + { + _SLerrno_errno = errno; + SLang_push_null (); + return; + } + +#ifdef __WIN32__ + opt_attrs = GetFileAttributes (file); +#else + opt_attrs = 0; +#endif + + push_stat_struct (&st, opt_attrs); +} + +static void lstat_cmd (char *file) +{ +#ifdef HAVE_LSTAT + struct stat st; + int opt_attrs; + + if (-1 == lstat (file, &st)) + { + _SLerrno_errno = errno; + SLang_push_null (); + return; + } + +#ifdef __WIN32__ + opt_attrs = GetFileAttributes (file); +#else + opt_attrs = 0; +#endif + + push_stat_struct (&st, opt_attrs); +#else + stat_cmd (file); +#endif +} + +/* Well, it appears that on some systems, these are not defined. Here I + * provide them. These are derived from the Linux stat.h file. + */ + +#ifdef __os2__ +# ifdef __IBMC__ +/* IBM VA3 doesn't declare S_IFMT */ +# define S_IFMT (S_IFDIR | S_IFCHR | S_IFREG) +# endif +#endif + +#ifndef S_ISLNK +# ifdef S_IFLNK +# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) 0 +# endif +#endif + +#ifndef S_ISREG +# ifdef S_IFREG +# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +# else +# define S_ISREG(m) 0 +# endif +#endif + +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +#endif + +#ifndef S_ISCHR +# ifdef S_IFCHR +# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +# else +# define S_ISCHR(m) 0 +# endif +#endif + +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) 0 +# endif +#endif + +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) 0 +# endif +#endif + +#ifndef S_ISSOCK +# ifdef S_IFSOCK +# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) +# else +# define S_ISSOCK(m) 0 +# endif +#endif + +static char stat_is_cmd (char *what, int *mode_ptr) +{ + int ret; + int st_mode = *mode_ptr; + + if (!strcmp (what, "sock")) ret = S_ISSOCK(st_mode); + else if (!strcmp (what, "fifo")) ret = S_ISFIFO(st_mode); + else if (!strcmp (what, "blk")) ret = S_ISBLK(st_mode); + else if (!strcmp (what, "chr")) ret = S_ISCHR(st_mode); + else if (!strcmp (what, "dir")) ret = S_ISDIR(st_mode); + else if (!strcmp (what, "reg")) ret = S_ISREG(st_mode); + else if (!strcmp (what, "lnk")) ret = S_ISLNK(st_mode); + else + { + SLang_verror (SL_INVALID_PARM, "stat_is: Unrecognized type: %s", what); + return -1; + } + + return (char) (ret != 0); +} + +#ifdef HAVE_READLINK +static void readlink_cmd (char *s) +{ + char buf[2048]; + int n; + + n = readlink (s, buf, sizeof (buf)-1); + if (n == -1) + { + _SLerrno_errno = errno; + s = NULL; + } + else + { + buf[n] = 0; + s = buf; + } + + (void) SLang_push_string (s); +} +#endif + +static int chmod_cmd (char *file, int *mode) +{ + if (-1 == chmod(file, (mode_t) *mode)) + { + _SLerrno_errno = errno; + return -1; + } + return 0; +} + +#ifdef HAVE_CHOWN +static int chown_cmd (char *file, int *owner, int *group) +{ + int ret; + + if (-1 == (ret = chown(file, (uid_t) *owner, (gid_t) *group))) + _SLerrno_errno = errno; + return ret; +} +#endif + +/* add trailing slash to dir */ +static void fixup_dir (char *dir) +{ +#ifndef VMS + int n; + + if ((n = strlen(dir)) > 1) + { + n--; +#if defined(IBMPC_SYSTEM) + if ( dir[n] != '/' && dir[n] != '\\' ) + strcat(dir, "\\" ); +#else + if (dir[n] != '/' ) + strcat(dir, "/" ); +#endif + } +#endif /* !VMS */ +} + +static void slget_cwd (void) +{ + char cwd[1024]; + char *p; + +#ifndef HAVE_GETCWD + p = getwd (cwd); +#else +# if defined (__EMX__) + p = _getcwd2(cwd, 1022); /* includes drive specifier */ +# else + p = getcwd(cwd, 1022); /* djggp includes drive specifier */ +# endif +#endif + + if (p == NULL) + { + _SLerrno_errno = errno; + SLang_push_null (); + return; + } + +#ifndef VMS +#ifdef __GO32__ + /* You never know about djgpp since it favors unix */ + { + char ch; + p = cwd; + while ((ch = *p) != 0) + { + if (ch == '/') *p = '\\'; + p++; + } + } +#endif + fixup_dir (cwd); +#endif + SLang_push_string (cwd); +} + +static int chdir_cmd (char *s) +{ + int ret; + + while (-1 == (ret = chdir (s))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +} + +#ifdef VMS +static int remove_cmd (char *); +/* If the file looks like xxx, then change it to xxx.dir. If + * it looks like A:[B.xxx] then change it to A:[B]xxx.dir. + */ + +static char *vms_convert_dirspec_to_vms_dir (char *str) +{ + char *s; + char *version; + unsigned int len; + char *dot; + + len = strlen (str); + + version = strchr (str, ';'); + if (version == NULL) + version = str + len; + /* version points to the version of the input string */ + + + if (NULL == (s = SLmalloc (len + 8)))/* allow extra space to work with */ + return NULL; + + len = (unsigned int) (version - str); + strncpy (s, str, len); + s[len] = 0; + str = s; + + /* Lowercase the whole thing */ + while (*s != 0) + { + *s = LOWER_CASE(*s); + s++; + } + + if ((s > str) + && (s[-1] != ']')) + { + if ((s >= str + 4) + && (0 == strcmp (s - 4, ".dir"))) + s -= 4; + goto add_dir_version; + } + + /* Check for one of two possibilities: + * + * dev:[x] --> dev:x + * dev:[a.x] --> dev:[a]x + */ + + if (NULL == (dot = strchr (str, '.'))) + { + /* First possibility */ + if (NULL == (s = strchr (str, '['))) + return str; /* let someone else figure this out */ + while (s[1] != ']') + { + s[0] = s[1]; + s++; + } + *s = 0; + goto add_dir_version; + } + + while (NULL != (s = strchr (dot + 1, '.'))) + dot = s; + + *dot = ']'; + s = str + (len - 1); + + /* Drop */ + + add_dir_version: + strcpy (s, ".dir"); + strcpy (s+4, version); + return str; +} +#endif + +static int rmdir_cmd (char *s) +{ +#ifdef VMS + int status; + + if (NULL == (s = vms_convert_dirspec_to_vms_dir (s))) + return -1; + + status = remove_cmd (s); + SLfree (s); + + return status; + +#else + int ret; + + while (-1 == (ret = rmdir (s))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +#endif +} + +static int remove_cmd (char *s) +{ + int ret; +#ifdef VMS +# define REMOVE delete +#else +# ifdef REAL_UNIX_SYSTEM +# define REMOVE unlink +# else +# define REMOVE remove +# endif +#endif + + while (-1 == (ret = REMOVE (s))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +} + +static int rename_cmd (char *oldpath, char *newpath) +{ + int ret; + while (-1 == (ret = rename (oldpath, newpath))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +} + +static int mkdir_cmd (char *s, int *mode_ptr) +{ + int ret; + + (void) mode_ptr; + errno = 0; + +#if defined (__MSDOS__) && !defined(__GO32__) +# define MKDIR(x,y) mkdir(x) +#else +# if defined (__os2__) && !defined (__EMX__) +# define MKDIR(x,y) mkdir(x) +# else +# if defined (__WIN32__) && !defined (__CYGWIN32__) +# define MKDIR(x,y) mkdir(x) +# else +# define MKDIR mkdir +# endif +# endif +#endif + + while (-1 == (ret = MKDIR(s, *mode_ptr))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +} + +#ifdef HAVE_MKFIFO +static int mkfifo_cmd (char *path, int *mode) +{ + if (-1 == mkfifo (path, *mode)) + { + _SLerrno_errno = errno; + return -1; + } + return 0; +} +#endif + +#if USE_LISTDIR_INTRINSIC + +static void free_dir_list (char **list, unsigned int num) +{ + unsigned int i; + + if (list == NULL) + return; + + for (i = 0; i < num; i++) + SLang_free_slstring (list[i]); + SLfree ((char *) list); +} + +#if defined(__WIN32__) || defined(__os2__) && defined(__IBMC__) +static int build_dirlist (char *file, char *opt, char ***listp, unsigned int *nump, unsigned int *maxnum) +{ +# ifdef __WIN32__ + DWORD status; + HANDLE h; + WIN32_FIND_DATA fd; +# else + APIRET rc; + FILESTATUS3 status; + HDIR h; + FILEFINDBUF3 fd; + ULONG cFileNames; +# endif + char *pat; + unsigned int len; + char **list; + unsigned int num; + unsigned int max_num; + int hok; + + /* If an option is present, assume ok to list hidden files. Later + * I will formalize this. + */ + hok = (opt != NULL); + +# ifdef __WIN32__ + status = GetFileAttributes (file); +# else + rc = DosQueryPathInfo(file, FIL_STANDARD, &status, sizeof(FILESTATUS3)); +# endif + + +# ifdef __WIN32__ + if (status == (DWORD)-1) + { + _SLerrno_errno = ENOENT; + return -1; + } + if (0 == (status & FILE_ATTRIBUTE_DIRECTORY)) + { + _SLerrno_errno = ENOTDIR; + return -1; + } +# else + if ((rc != 0) || (status.attrFile & FILE_DIRECTORY) == 0) + { + /* ENOTDIR isn't defined in VA3. */ + _SLerrno_errno = ENOENT; + return -1; + } +# endif + + len = strlen (file); + pat = SLmalloc (len + 3); + if (pat == NULL) + return -1; + + strcpy (pat, file); + file = pat; + while (*file != 0) + { + if (*file == '/') *file = '\\'; + file++; + } + + if (len && (pat[len-1] != '\\')) + { + pat[len] = '\\'; + len++; + } + pat[len++] = '*'; + pat[len] = 0; + + num = 0; + max_num = 50; + list = (char **)SLmalloc (max_num * sizeof(char *)); + if (list == NULL) + { + SLfree (pat); + return -1; + } + +# ifdef __WIN32__ + h = FindFirstFile(pat, &fd); + if (h == INVALID_HANDLE_VALUE) + { + if (ERROR_NO_MORE_FILES != GetLastError()) + { + SLfree (pat); + SLfree ((char *)list); + return -1; + } + } +# else + h = HDIR_CREATE; + cFileNames = 1; + rc = DosFindFirst(pat, &h, FILE_READONLY | FILE_DIRECTORY | + FILE_ARCHIVED, &fd, sizeof(fd), &cFileNames, FIL_STANDARD); + if (rc != 0) + { + if (rc != ERROR_NO_MORE_FILES) + { + SLfree (pat); + SLfree ((char *)list); + return -1; + } + } +# endif + else while (1) + { + /* Do not include hidden files in the list. Also, do not + * include "." and ".." entries. + */ +#ifdef __WIN32__ + file = fd.cFileName; +#else + file = fd.achName; +#endif + if ( +#ifdef __WIN32__ + (hok || (0 == (fd.dwFileAttributes & FILE_ATTRIBUTE_HIDDEN))) +#else + (hok || (0 == (fd.attrFile & FILE_HIDDEN))) +#endif + && ((*file != '.') + || ((0 != strcmp (file, ".")) + && (0 != strcmp (file, ".."))))) + { + if (num == max_num) + { + char **new_list; + + max_num += 100; + new_list = (char **)SLrealloc ((char *)list, max_num * sizeof (char *)); + if (new_list == NULL) + goto return_error; + + list = new_list; + } + + file = SLang_create_slstring (file); + if (file == NULL) + goto return_error; + + list[num] = file; + num++; + } + +#ifdef __WIN32__ + if (FALSE == FindNextFile(h, &fd)) + { + if (ERROR_NO_MORE_FILES == GetLastError()) + { + FindClose (h); + break; + } + + _SLerrno_errno = errno; + FindClose (h); + goto return_error; + } +#else + cFileNames = 1; + rc = DosFindNext(h, &fd, sizeof(fd), &cFileNames); + if (rc != 0) + { + if (rc == ERROR_NO_MORE_FILES) + { + DosFindClose (h); + break; + } + + _SLerrno_errno = errno; + DosFindClose (h); + goto return_error; + } +#endif + } + + SLfree (pat); + *maxnum = max_num; + *nump = num; + *listp = list; + return 0; + + return_error: + free_dir_list (list, num); + SLfree (pat); + return -1; +} + +#else /* NOT __WIN32__ */ + +static int build_dirlist (char *dir, char *opt, char ***listp, unsigned int *nump, unsigned int *maxnum) +{ + DIR *dp; + struct dirent *ep; + unsigned int num_files; + unsigned int max_num_files; + char **list; + + (void) opt; + + if (NULL == (dp = opendir (dir))) + { + _SLerrno_errno = errno; + return -1; + } + + num_files = max_num_files = 0; + list = NULL; + while (NULL != (ep = readdir (dp))) + { + unsigned int len; + char *name; + + name = ep->d_name; +# ifdef NEED_D_NAMLEN + len = ep->d_namlen; +# else + len = strlen (name); +# endif + if ((*name == '.') && (len <= 2)) + { + if (len == 1) continue; + if (name [1] == '.') continue; + } + + if (num_files == max_num_files) + { + char **new_list; + + max_num_files += 100; + if (NULL == (new_list = (char **) SLrealloc ((char *)list, max_num_files * sizeof(char *)))) + goto return_error; + + list = new_list; + } + + if (NULL == (list[num_files] = SLang_create_nslstring (name, len))) + goto return_error; + + num_files++; + } + + closedir (dp); + *nump = num_files; + *maxnum = max_num_files; + *listp = list; + return 0; + + return_error: + if (dp != NULL) + closedir (dp); + free_dir_list (list, num_files); + return -1; +} +# endif /* NOT __WIN32__ */ + +static void listdir_cmd (char *dir, char *opt) +{ + SLang_Array_Type *at; + unsigned int num_files; + unsigned int max_num_files; + int inum_files; + char **list; + + if (-1 == build_dirlist (dir, opt, &list, &num_files, &max_num_files)) + { + SLang_push_null (); + return; + } + /* If max_num_files == 0, then num_files == 0 and list == NULL. + * The realloc step below will malloc list for us. + */ + if (num_files + 1 < max_num_files) + { + char **new_list; + if (NULL == (new_list = (char **) SLrealloc ((char *)list, (num_files + 1)* sizeof(char*)))) + { + free_dir_list (list, num_files); + SLang_push_null (); + return; + } + list = new_list; + } + + inum_files = (int) num_files; + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) list, &inum_files, 1))) + { + free_dir_list (list, num_files); + SLang_push_null (); + return; + } + + /* Allow the array to free this list if push fails */ + if (-1 == SLang_push_array (at, 1)) + SLang_push_null (); +} + +static void listdir_cmd_wrap (void) +{ + char *s, *sopt; + + sopt = NULL; + switch (SLang_Num_Function_Args) + { + case 2: + if (-1 == SLang_pop_slstring (&sopt)) + return; + case 1: + if (-1 == SLang_pop_slstring (&s)) + { + SLang_free_slstring (sopt); + return; + } + break; + default: + SLang_verror (SL_INVALID_PARM, "usage: listdir (string, [opt-string]"); + return; + } + + listdir_cmd (s, sopt); + SLang_free_slstring (s); + SLang_free_slstring (sopt); +} + +#endif /* USE_LISTDIR_INTRINSIC */ + +#ifdef HAVE_UMASK +static int umask_cmd (int *u) +{ + return umask (*u); +} +#endif + +static SLang_Intrin_Fun_Type PosixDir_Name_Table [] = +{ +#ifdef HAVE_READLINK + MAKE_INTRINSIC_S("readlink", readlink_cmd, SLANG_VOID_TYPE), +#endif + MAKE_INTRINSIC_S("lstat_file", lstat_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("stat_file", stat_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SI("stat_is", stat_is_cmd, SLANG_CHAR_TYPE), +#ifdef HAVE_MKFIFO + MAKE_INTRINSIC_SI("mkfifo", mkfifo_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_CHOWN + MAKE_INTRINSIC_SII("chown", chown_cmd, SLANG_INT_TYPE), +#endif + MAKE_INTRINSIC_SI("chmod", chmod_cmd, SLANG_INT_TYPE), +#ifdef HAVE_UMASK + MAKE_INTRINSIC_I("umask", umask_cmd, SLANG_INT_TYPE), +#endif + MAKE_INTRINSIC_0("getcwd", slget_cwd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SI("mkdir", mkdir_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("chdir", chdir_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("rmdir", rmdir_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("remove", remove_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SS("rename", rename_cmd, SLANG_INT_TYPE), +#if USE_LISTDIR_INTRINSIC + MAKE_INTRINSIC("listdir", listdir_cmd_wrap, SLANG_VOID_TYPE, 0), +#endif + SLANG_END_INTRIN_FUN_TABLE +}; + +static SLang_IConstant_Type PosixDir_Consts [] = +{ +#ifndef S_IRWXU +# define S_IRWXU 00700 +#endif + MAKE_ICONSTANT("S_IRWXU", S_IRWXU), +#ifndef S_IRUSR +# define S_IRUSR 00400 +#endif + MAKE_ICONSTANT("S_IRUSR", S_IRUSR), +#ifndef S_IWUSR +# define S_IWUSR 00200 +#endif + MAKE_ICONSTANT("S_IWUSR", S_IWUSR), +#ifndef S_IXUSR +# define S_IXUSR 00100 +#endif + MAKE_ICONSTANT("S_IXUSR", S_IXUSR), +#ifndef S_IRWXG +# define S_IRWXG 00070 +#endif + MAKE_ICONSTANT("S_IRWXG", S_IRWXG), +#ifndef S_IRGRP +# define S_IRGRP 00040 +#endif + MAKE_ICONSTANT("S_IRGRP", S_IRGRP), +#ifndef S_IWGRP +# define S_IWGRP 00020 +#endif + MAKE_ICONSTANT("S_IWGRP", S_IWGRP), +#ifndef S_IXGRP +# define S_IXGRP 00010 +#endif + MAKE_ICONSTANT("S_IXGRP", S_IXGRP), +#ifndef S_IRWXO +# define S_IRWXO 00007 +#endif + MAKE_ICONSTANT("S_IRWXO", S_IRWXO), +#ifndef S_IROTH +# define S_IROTH 00004 +#endif + MAKE_ICONSTANT("S_IROTH", S_IROTH), +#ifndef S_IWOTH +# define S_IWOTH 00002 +#endif + MAKE_ICONSTANT("S_IWOTH", S_IWOTH), +#ifndef S_IXOTH +# define S_IXOTH 00001 +#endif + MAKE_ICONSTANT("S_IXOTH", S_IXOTH), +#ifdef __WIN32__ + MAKE_ICONSTANT("FILE_ATTRIBUTE_ARCHIVE", FILE_ATTRIBUTE_ARCHIVE), + MAKE_ICONSTANT("FILE_ATTRIBUTE_COMPRESSED", FILE_ATTRIBUTE_COMPRESSED), + MAKE_ICONSTANT("FILE_ATTRIBUTE_NORMAL", FILE_ATTRIBUTE_NORMAL), + MAKE_ICONSTANT("FILE_ATTRIBUTE_DIRECTORY", FILE_ATTRIBUTE_DIRECTORY), + MAKE_ICONSTANT("FILE_ATTRIBUTE_HIDDEN", FILE_ATTRIBUTE_HIDDEN), + MAKE_ICONSTANT("FILE_ATTRIBUTE_READONLY", FILE_ATTRIBUTE_READONLY), + MAKE_ICONSTANT("FILE_ATTRIBUTE_SYSTEM", FILE_ATTRIBUTE_SYSTEM), + MAKE_ICONSTANT("FILE_ATTRIBUTE_TEMPORARY", FILE_ATTRIBUTE_TEMPORARY), +#endif + SLANG_END_ICONST_TABLE +}; + +static int Initialized; + +int SLang_init_posix_dir (void) +{ + if (Initialized) + return 0; + + if ((-1 == SLadd_intrin_fun_table(PosixDir_Name_Table, "__POSIX_DIR__")) + || (-1 == SLadd_iconstant_table (PosixDir_Consts, NULL)) + || (-1 == _SLerrno_init ())) + return -1; + + Initialized = 1; + + return 0; +} + diff --git a/libslang/src/slposio.c b/libslang/src/slposio.c new file mode 100644 index 0000000..ee9d50a --- /dev/null +++ b/libslang/src/slposio.c @@ -0,0 +1,568 @@ +/* This module implements an interface to posix system calls */ +/* file stdio intrinsics for S-Lang */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if defined(__unix__) || (defined (__os2__) && defined (__EMX__)) +# include +#endif + +#ifdef HAVE_FCNTL_H +# include +#endif +#ifdef HAVE_SYS_FCNTL_H +# include +#endif + +#ifdef __unix__ +# include +#endif + +#ifdef HAVE_IO_H +# include +#endif + +#if defined(__BORLANDC__) +# include +#endif + +#if defined(__DECC) && defined(VMS) +# include +# include +#endif + +#ifdef VMS +# include +#else +# include +#endif + +#include + +#include "slang.h" +#include "_slang.h" + +struct _SLFile_FD_Type +{ + char *name; + unsigned int num_refs; /* reference counting */ + int fd; + SLang_MMT_Type *stdio_mmt; /* fdopen'd stdio object */ + + /* methods */ + int (*close)(int); + int (*read) (int, char *, unsigned int *); + int (*write)(int, char *, unsigned int *); +}; + +static int close_method (int fd) +{ + return close (fd); +} + +static int write_method (int fd, char *buf, unsigned int *nump) +{ + int num; + + if (-1 == (num = write (fd, buf, *nump))) + { + *nump = 0; + return -1; + } + + *nump = (unsigned int) num; + return 0; +} + +static int read_method (int fd, char *buf, unsigned int *nump) +{ + int num; + + num = read (fd, buf, *nump); + if (num == -1) + { + *nump = 0; + return -1; + } + *nump = (unsigned int) num; + return 0; +} + +static int check_fd (int fd) +{ + if (fd == -1) + { +#ifdef EBADF + _SLerrno_errno = EBADF; +#endif + return -1; + } + + return 0; +} + +static int posix_close (SLFile_FD_Type *f) +{ + if (-1 == check_fd (f->fd)) + return -1; + + if ((f->close != NULL) + && (-1 == f->close (f->fd))) + { + _SLerrno_errno = errno; + return -1; + } + + if (f->stdio_mmt != NULL) + { + SLang_free_mmt (f->stdio_mmt); + f->stdio_mmt = NULL; + } + + f->fd = -1; + return 0; +} + +/* Usage: Uint write (f, buf); */ +static void posix_write (SLFile_FD_Type *f, SLang_BString_Type *bstr) +{ + unsigned int len; + char *p; + + if ((-1 == check_fd (f->fd)) + || (NULL == (p = (char *)SLbstring_get_pointer (bstr, &len)))) + { + SLang_push_integer (-1); + return; + } + + if (-1 == f->write (f->fd, p, &len)) + { + _SLerrno_errno = errno; + SLang_push_integer (-1); + return; + } + + (void) SLang_push_uinteger (len); +} + +/* Usage: nn = read (f, &buf, n); */ +static void posix_read (SLFile_FD_Type *f, SLang_Ref_Type *ref, unsigned int *nbytes) +{ + unsigned int len; + char *b; + SLang_BString_Type *bstr; + + b = NULL; + + len = *nbytes; + if ((-1 == check_fd (f->fd)) + || (NULL == (b = SLmalloc (len + 1)))) + goto return_error; + + if (-1 == f->read (f->fd, b, &len)) + { + _SLerrno_errno = errno; + goto return_error; + } + + if (len != *nbytes) + { + char *b1 = SLrealloc (b, len + 1); + if (b1 == NULL) + goto return_error; + b = b1; + } + + bstr = SLbstring_create_malloced ((unsigned char *) b, len, 0); + if (bstr != NULL) + { + if ((-1 != SLang_assign_to_ref (ref, SLANG_BSTRING_TYPE, (VOID_STAR)&bstr)) + && (-1 != SLang_push_uinteger (len))) + return; + + SLbstring_free (bstr); + b = NULL; + /* drop */ + } + + return_error: + if (b != NULL) SLfree ((char *)b); + (void) SLang_assign_to_ref (ref, SLANG_NULL_TYPE, NULL); + (void) SLang_push_integer (-1); +} + +SLFile_FD_Type *SLfile_create_fd (char *name, int fd) +{ + SLFile_FD_Type *f; + + if (NULL == (f = (SLFile_FD_Type *) SLmalloc (sizeof (SLFile_FD_Type)))) + return NULL; + + memset ((char *) f, 0, sizeof (SLFile_FD_Type)); + if (NULL == (f->name = SLang_create_slstring (name))) + { + SLfree ((char *)f); + return NULL; + } + + f->fd = fd; + f->num_refs = 1; + + f->close = close_method; + f->read = read_method; + f->write = write_method; + + return f; +} + +SLFile_FD_Type *SLfile_dup_fd (SLFile_FD_Type *f0) +{ + SLFile_FD_Type *f; + int fd0, fd; + + if (f0 == NULL) + return NULL; + fd0 = f0->fd; + if (-1 == check_fd (fd0)) + return NULL; + + while (-1 == (fd = dup (fd0))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + return NULL; + } + + if (NULL == (f = SLfile_create_fd (f0->name, fd))) + { + f0->close (fd); + return NULL; + } + + return f; +} + +int SLfile_get_fd (SLFile_FD_Type *f, int *fd) +{ + if (f == NULL) + return -1; + + *fd = f->fd; + if (-1 == check_fd (*fd)) + return -1; + + return 0; +} + +void SLfile_free_fd (SLFile_FD_Type *f) +{ + if (f == NULL) + return; + + if (f->num_refs > 1) + { + f->num_refs -= 1; + return; + } + + if (f->fd != -1) + { + if (f->close != NULL) + (void) f->close (f->fd); + + f->fd = -1; + } + + if (f->stdio_mmt != NULL) + SLang_free_mmt (f->stdio_mmt); + + SLfree ((char *) f); +} + +static int pop_string_int (char **s, int *i) +{ + *s = NULL; + if ((-1 == SLang_pop_integer (i)) + || (-1 == SLang_pop_slstring (s))) + return -1; + + return 0; +} + +static int pop_string_int_int (char **s, int *a, int *b) +{ + *s = NULL; + if ((-1 == SLang_pop_integer (b)) + || (-1 == pop_string_int (s, a))) + return -1; + + return 0; +} + +static void posix_open (void) +{ + char *file; + int mode, flags; + SLFile_FD_Type *f; + + switch (SLang_Num_Function_Args) + { + case 3: + if (-1 == pop_string_int_int (&file, &flags, &mode)) + { + SLang_push_null (); + return; + } + break; + + case 2: + default: + if (-1 == pop_string_int (&file, &flags)) + return; + mode = 0777; + break; + } + + f = SLfile_create_fd (file, -1); + if (f == NULL) + { + SLang_free_slstring (file); + SLang_push_null (); + return; + } + SLang_free_slstring (file); + + if (-1 == (f->fd = open (f->name, flags, mode))) + { + _SLerrno_errno = errno; + SLfile_free_fd (f); + SLang_push_null (); + return; + } + + if (-1 == SLfile_push_fd (f)) + SLang_push_null (); + SLfile_free_fd (f); +} + +static void posix_fileno (void) +{ + FILE *fp; + SLang_MMT_Type *mmt; + int fd; + SLFile_FD_Type *f; + char *name; + + if (-1 == SLang_pop_fileptr (&mmt, &fp)) + { + SLang_push_null (); + return; + } + name = SLang_get_name_from_fileptr (mmt); + fd = fileno (fp); + + f = SLfile_create_fd (name, fd); + if (f != NULL) + f->close = NULL; /* prevent fd from being closed + * when it goes out of scope + */ + SLang_free_mmt (mmt); + + if (-1 == SLfile_push_fd (f)) + SLang_push_null (); + SLfile_free_fd (f); +} + +static void posix_fdopen (SLFile_FD_Type *f, char *mode) +{ + if (f->stdio_mmt == NULL) + { + if (-1 == _SLstdio_fdopen (f->name, f->fd, mode)) + return; + + if (NULL == (f->stdio_mmt = SLang_pop_mmt (SLANG_FILE_PTR_TYPE))) + return; + } + + (void) SLang_push_mmt (f->stdio_mmt); +} + +static long posix_lseek (SLFile_FD_Type *f, long ofs, int whence) +{ + long status; + + if (-1 == (status = lseek (f->fd, ofs, whence))) + _SLerrno_errno = errno; + + return status; +} + +static int posix_isatty (void) +{ + int ret; + SLFile_FD_Type *f; + + if (SLang_peek_at_stack () == SLANG_FILE_PTR_TYPE) + { + SLang_MMT_Type *mmt; + FILE *fp; + + if (-1 == SLang_pop_fileptr (&mmt, &fp)) + return 0; /* invalid descriptor */ + + ret = isatty (fileno (fp)); + SLang_free_mmt (mmt); + return ret; + } + + if (-1 == SLfile_pop_fd (&f)) + return 0; + + ret = isatty (f->fd); + SLfile_free_fd (f); + + return ret; +} + +static void posix_dup (SLFile_FD_Type *f) +{ + if ((NULL == (f = SLfile_dup_fd (f))) + || (-1 == SLfile_push_fd (f))) + SLang_push_null (); + + SLfile_free_fd (f); +} + +#define I SLANG_INT_TYPE +#define V SLANG_VOID_TYPE +#define F SLANG_FILE_FD_TYPE +#define B SLANG_BSTRING_TYPE +#define R SLANG_REF_TYPE +#define U SLANG_UINT_TYPE +#define S SLANG_STRING_TYPE +#define L SLANG_LONG_TYPE +static SLang_Intrin_Fun_Type Fd_Name_Table [] = +{ + MAKE_INTRINSIC_0("fileno", posix_fileno, V), + MAKE_INTRINSIC_0("isatty", posix_isatty, I), + MAKE_INTRINSIC_0("open", posix_open, V), + MAKE_INTRINSIC_3("read", posix_read, V, F, R, U), + MAKE_INTRINSIC_3("lseek", posix_lseek, L, F, L, I), + MAKE_INTRINSIC_2("fdopen", posix_fdopen, V, F, S), + MAKE_INTRINSIC_2("write", posix_write, V, F, B), + MAKE_INTRINSIC_1("dup_fd", posix_dup, V, F), + MAKE_INTRINSIC_1("close", posix_close, I, F), + SLANG_END_INTRIN_FUN_TABLE +}; +#undef I +#undef V +#undef F +#undef B +#undef R +#undef S +#undef L +#undef U + +static SLang_IConstant_Type PosixIO_Consts [] = +{ +#ifdef O_RDONLY + MAKE_ICONSTANT("O_RDONLY", O_RDONLY), +#endif +#ifdef O_WRONLY + MAKE_ICONSTANT("O_WRONLY", O_WRONLY), +#endif +#ifdef O_RDWR + MAKE_ICONSTANT("O_RDWR", O_RDWR), +#endif +#ifdef O_APPEND + MAKE_ICONSTANT("O_APPEND", O_APPEND), +#endif +#ifdef O_CREAT + MAKE_ICONSTANT("O_CREAT", O_CREAT), +#endif +#ifdef O_EXCL + MAKE_ICONSTANT("O_EXCL", O_EXCL), +#endif +#ifdef O_NOCTTY + MAKE_ICONSTANT("O_NOCTTY", O_NOCTTY), +#endif +#ifdef O_NONBLOCK + MAKE_ICONSTANT("O_NONBLOCK", O_NONBLOCK), +#endif +#ifdef O_TRUNC + MAKE_ICONSTANT("O_TRUNC", O_TRUNC), +#endif +#ifndef O_BINARY +# define O_BINARY 0 +#endif + MAKE_ICONSTANT("O_BINARY", O_BINARY), +#ifndef O_TEXT +# define O_TEXT 0 +#endif + MAKE_ICONSTANT("O_TEXT", O_TEXT), + + SLANG_END_ICONST_TABLE +}; + +int SLfile_push_fd (SLFile_FD_Type *f) +{ + if (f == NULL) + return SLang_push_null (); + + f->num_refs += 1; + + if (0 == SLclass_push_ptr_obj (SLANG_FILE_FD_TYPE, (VOID_STAR) f)) + return 0; + + f->num_refs -= 1; + + return -1; +} + +int SLfile_pop_fd (SLFile_FD_Type **f) +{ + return SLclass_pop_ptr_obj (SLANG_FILE_FD_TYPE, (VOID_STAR *) f); +} + +static void destroy_fd_type (unsigned char type, VOID_STAR ptr) +{ + (void) type; + SLfile_free_fd (*(SLFile_FD_Type **) ptr); +} + +static int fd_push (unsigned char type, VOID_STAR v) +{ + (void) type; + return SLfile_push_fd (*(SLFile_FD_Type **)v); +} + +int SLang_init_posix_io (void) +{ + SLang_Class_Type *cl; + + if (NULL == (cl = SLclass_allocate_class ("FD_Type"))) + return -1; + cl->cl_destroy = destroy_fd_type; + (void) SLclass_set_push_function (cl, fd_push); + + if (-1 == SLclass_register_class (cl, SLANG_FILE_FD_TYPE, sizeof (SLFile_FD_Type), SLANG_CLASS_TYPE_PTR)) + return -1; + + if ((-1 == SLadd_intrin_fun_table(Fd_Name_Table, "__POSIXIO__")) + || (-1 == SLadd_iconstant_table (PosixIO_Consts, NULL)) + || (-1 == _SLerrno_init ())) + return -1; + + return 0; +} + diff --git a/libslang/src/slprepr.c b/libslang/src/slprepr.c new file mode 100644 index 0000000..8cb1f5f --- /dev/null +++ b/libslang/src/slprepr.c @@ -0,0 +1,569 @@ +/* Copyright (c) 1996, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/*--------------------------------*-C-*---------------------------------* + * File: slprepr.c + * + * preprocessing routines + */ +/*{{{ notes: */ +/* + * various preprocessing tokens supported + * + * #ifdef TOKEN1 TOKEN2 ... + * - True if any of TOKEN1 TOKEN2 ... are defined + * + * #ifndef TOKEN1 TOKEN2 ... + * - True if none of TOKEN1 TOKEN2 ... are defined + * + * #iftrue + * #ifnfalse + * #if true + * #if !false + * - always True + * + * #iffalse + * #ifntrue + * #if false + * #if !true + * - always False + * + * #if$ENV + * - True if the enviroment variable ENV is set + * + * #ifn$ENV + * #if !$ENV + * - True if the enviroment variable ENV is not set + * + * #if$ENV TOKEN1 TOKEN2 ... + * - True if the contents of enviroment variable ENV match + * any of TOKEN1 TOKEN2 ... + * + * #ifn$ENV TOKEN1 TOKEN2 ... + * #if !$ENV TOKEN1 TOKEN2 ... + * - True if the contents of enviroment variable ENV do not match + * any of TOKEN1 TOKEN2 ... + * + * NB: For $ENV, the tokens may contain wildcard characters: + * '?' - match any single character + * '*' - match any number of characters + * + * #ifexists TOKEN + * #ifnexists TOKEN + * #if !exists TOKEN + * - check if a variable/function exists + * + * #ifeval EXPRESSION + * #ifneval EXPRESSION + * #if !eval TOKEN + * - evaluates the EXPRESSION as an SLang expression + * + * #if (EXPRESSION) + * #if !(EXPRESSION) + * - as per '#ifeval' / '#ifneval', + * evaluates the EXPRESSION as a SLang expression + * - using '#ifn (EXPRESSION)' is possible, but deprecated + * + * #elif... + * #else + * #endif + * + * #stop + * - stop reading the entire file here, provided that the line + * would have been executed + * eg: + * #iffalse + * # stop + * #endif + * would NEVER stop + * + * # + * - start embedded text region + * # + * - end embedded text region + * + * All text, include other preprocessing directives, that occurs between + * the '#' and '#' directives will be ignored. + * This is useful for embedding other code or documentation. + * eg: + * # + * \chapter{My Documentation Effort} + * # + * NB: * although the current implementation only looks for sequences + * '#<' and '#' form + * for documentation purposes and to avoid future surprises. + * * do NOT attempt to nest these constructions + * + * GENERAL NOTES: + * Apart from the '#ifdef' and '#ifndef' constructions, we are quite + * generous with accepting whitespace and the alternative '!' form. + * eg., + * #ifTEST + * #ifnTEST + * #if TEST + * #if !TEST + * #if ! TEST + * + * mj olesen + *----------------------------------------------------------------------*/ +/*}}}*/ +/*{{{ includes: */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" +/*}}}*/ + +int (*SLprep_exists_hook) (char *, char); /* in "slang.h" */ +int (*_SLprep_eval_hook) (char *); /* in "_slang.h" */ + +/*{{{ SLprep_open_prep (), SLprep_close_prep () */ +int SLprep_open_prep (SLPreprocess_Type *pt) +{ + pt->this_level = 0; + pt->exec_level = 0; + pt->prev_exec_level = 0; + pt->comment_char = '%'; + pt->preprocess_char = '#'; + pt->flags = 0; + return 0; +} + +void SLprep_close_prep (SLPreprocess_Type *pt) +{ + (void) pt; +} +/*}}}*/ + +/*{{{ SLwildcard () */ +/*----------------------------------------------------------------------* + * Does `string' match `pattern' ? + * + * '*' in pattern matches any sub-string (including the null string) + * '?' matches any single char. + * + * Code taken from that donated by Paul Hudson + * to the fvwm project. + * It is public domain, no strings attached. No guarantees either. + *----------------------------------------------------------------------*/ +static int SLwildcard (char *pattern, char *string) +{ + if (pattern == NULL || *pattern == '\0' || !strcmp (pattern, "*")) + return 1; + else if (string == NULL) + return 0; + + while (*pattern && *string) switch (*pattern) + { + case '?': + /* match any single character */ + pattern++; + string++; + break; + + case '*': + /* see if rest of pattern matches any trailing */ + /* substring of the string. */ + if (*++pattern == '\0') + return 1; /* trailing * must match rest */ + + while (*string) + { + if (SLwildcard (pattern, string)) return 1; + string++; + } + return 0; + + /* break; */ + + default: + if (*pattern == '\\') + { + if (*++pattern == '\0') + pattern--; /* don't skip trailing backslash */ + } + if (*pattern++ != *string++) return 0; + break; + } + + return ((*string == '\0') + && ((*pattern == '\0') || !strcmp (pattern, "*"))); +} +/*}}}*/ + +#if defined(__16_BIT_SYSTEM__) +# define MAX_DEFINES 10 +#else +# define MAX_DEFINES 128 +#endif + +/* The extra one is for NULL termination */ +char *_SLdefines [MAX_DEFINES + 1]; + +int SLdefine_for_ifdef (char *s) /*{{{*/ +{ + unsigned int i; + + for (i = 0; i < MAX_DEFINES; i++) + { + char *s1 = _SLdefines [i]; + + if (s1 == s) + return 0; /* already defined (hashed string) */ + + if (s1 != NULL) + continue; + + s = SLang_create_slstring (s); + if (s == NULL) + return -1; + + _SLdefines[i] = s; + return 0; + } + return -1; +} +/*}}}*/ + +/*{{{ static functions */ +static int is_any_defined(char *buf, char comment) /*{{{*/ +{ + char *sys; + unsigned int i; + + while (1) + { + register char ch; + + /* Skip whitespace */ + while (((ch = *buf) == ' ') || (ch == '\t')) + buf++; + + if ((ch == '\n') || (ch == 0) || (ch == comment)) + return 0; + + i = 0; + while (NULL != (sys = _SLdefines [i++])) + { + unsigned int n; + + if (*sys != ch) + continue; + + n = strlen (sys); + if (0 == strncmp (buf, sys, n)) + { + char ch1 = *(buf + n); + + if ((ch1 == '\n') || (ch1 == 0) || + (ch1 == ' ') || (ch1 == '\t') || (ch1 == comment)) + return 1; + } + } + + /* Skip past word */ + while (((ch = *buf) != ' ') + && (ch != '\n') + && (ch != 0) + && (ch != '\t') + && (ch != comment)) + buf++; + } +} +/*}}}*/ + +static unsigned char *tokenize (unsigned char *buf, char *token, unsigned int len) +{ + register char *token_end; + + token_end = token + (len - 1); /* allow room for \0 */ + + while ((token < token_end) && (*buf > ' ')) + *token++ = *buf++; + + if (*buf > ' ') return NULL; /* token too long */ + + *token = '\0'; + + while ((*buf == ' ') || (*buf == '\t')) buf++; + + return buf; +} + +static int is_env_defined (char *buf, char comment) /*{{{*/ +{ + char * env, token [32]; + + if ((*buf <= ' ') || (*buf == comment)) return 0; /* no token */ + + if (NULL == (buf = (char *) tokenize ((unsigned char *) buf, + token, sizeof (token)))) + return 0; + + if (NULL == (env = getenv (token))) + return 0; /* ENV not defined */ + + if ((*buf == '\0') || (*buf == '\n') || (*buf == comment)) + return 1; /* no tokens, but getenv() worked */ + + do + { + buf = (char *) tokenize ((unsigned char *) buf, token, sizeof (token)); + if (buf == NULL) return 0; + + if (SLwildcard (token, env)) + return 1; + } + while (*buf && (*buf != '\n') && (*buf != comment)); + + return 0; +} +/*}}}*/ +/*}}}*/ + +int SLprep_line_ok (char *buf, SLPreprocess_Type *pt) /*{{{*/ +{ + int level, prev_exec_level, exec_level; + unsigned int flags; + + if ((buf == NULL) || (pt == NULL)) return 1; + + /* the '#stop' marker was already reached */ + if (pt->flags & SLPREP_STOP_READING) + return 0; + + /* local bookkeeping */ + level = pt->this_level; + exec_level = pt->exec_level; + prev_exec_level = pt->prev_exec_level; + flags = pt->flags; + + if (*buf != pt->preprocess_char) + { + /* ignore out-of-context or embedded text */ + if ((level != exec_level) || (flags & SLPREP_EMBEDDED_TEXT)) + return 0; + + if (*buf == '\n') return flags & SLPREP_BLANK_LINES_OK; + if (*buf == pt->comment_char) return flags & SLPREP_COMMENT_LINES_OK; + + return 1; + } + + buf++; + + /* + * Always allow '#!' to pass. This could be a shell script + * with something like '#! /usr/local/bin/slang' + */ + if ((*buf == '!') && (pt->preprocess_char == '#')) + return 0; + + /* Allow whitespace as in '# ifdef' */ + while ((*buf == ' ') || (*buf == '\t')) buf++; + + /* + * quick and dirty coding for '#' and '#' + * only bothers to differentiate between '#<' and '#' */ + pt->flags &= ~SLPREP_EMBEDDED_TEXT; + else /* likely a '#' */ + pt->flags |= SLPREP_EMBEDDED_TEXT; + + return 0; + } + + if (pt->flags & SLPREP_EMBEDDED_TEXT) + return 0; /* embedded text - ignore everything */ + + + if ((*buf < 'a') || (*buf > 'z')) /* something weird */ + return (level == exec_level); + + if ( !strncmp(buf, "stop", 4) ) + { + if (level == exec_level) /* signal stop if we're in scope */ + pt->flags |= SLPREP_STOP_READING; + return 0; /* swallow this tag */ + } + + if (!strncmp(buf, "endif", 5)) + { + if (level == exec_level) + { + exec_level--; + prev_exec_level = exec_level; + } + level--; + if (level < prev_exec_level) prev_exec_level = level; + goto done; + } + + if ((buf[0] == 'e') && (buf[1] == 'l')) /* else, elifdef, ... */ + { + if ((level == exec_level + 1) + && (prev_exec_level != level)) + { + /* We are in position to execute */ + buf += 2; + if ((buf[0] == 's') && (buf[1] == 'e')) + { + /* 'else' */ + exec_level = level; + goto done; + } + + /* + * drop through to 'if' testing. + * First set variable to value appropriate for 'if' testing. + */ + level--; /* now == to exec level */ + } + else + { + if (level == exec_level) + { + exec_level--; + } + goto done; + } + } + + if ((buf[0] == 'i') && (buf[1] == 'f')) + { + int test = 0; /* fallback value */ + int truth = 1; + buf += 2; + + if (level != exec_level) + { + level++; + goto done; /* Not interested */ + } + level++; + + if (buf[0] == 'n') + { + truth = !truth; + buf++; + } + + /* for 'ifdef' and 'ifndef' we are done */ + if (!strncmp (buf, "def", 3)) + { + test = is_any_defined(buf + 3, pt->comment_char); + } + else + { + /* + * the '#ifn' construction cannot have whitespace or '!' + * for the other forms, we can also accept + * 'if!..' instead of 'ifn...', or even 'if ...' or 'if ! ...' + */ + if (truth) + { + /* Allow some whitespace */ + while ((*buf == ' ') || (*buf == '\t')) buf++; + + if (*buf == '!') + { + /* the 'if !' form */ + truth = !truth; + buf++; + while ((*buf == ' ') || (*buf == '\t')) buf++; + } + } + + if (*buf == '$') + test = is_env_defined (buf + 1, pt->comment_char); + else if (*buf == '(' + && (_SLprep_eval_hook != NULL)) + test = (*_SLprep_eval_hook) (buf); + else if (!strncmp (buf, "eval", 4) + && (_SLprep_eval_hook != NULL)) + test = (*_SLprep_eval_hook) (buf + 4); + else if (!strncmp (buf, "exists", 6) + && (SLprep_exists_hook != NULL)) + test = (*SLprep_exists_hook) (buf + 6, pt->comment_char); + else if (!strncmp (buf, "true", 4)) + test = 1; + else if (strncmp (buf, "false", 5)) + return 1; /* unknown - let it bomb */ + } + + if (truth == test) prev_exec_level = exec_level = level; + } + else + { + return 1; /* let it bomb */ + } + + done: + + if (exec_level < 0) return 1; /* bad level - let it bomb */ + + pt->this_level = level; + pt->exec_level = exec_level; + pt->prev_exec_level = prev_exec_level; + return 0; +} +/*}}}*/ + +/*{{{ main() - for testing only */ +#if 0 +int main (int argc, char *argv[]) +{ + int i; + char buf[1024]; + SLPreprocess_Type pt; + + SLprep_open_prep (&pt); + SLdefine_for_ifdef ("UNIX"); + + /* super cheap getopts */ + for (i = 1; i < argc; i++) + { + char *p = argv[i]; + if (*p++ != '-') break; + if (*p == '-') break; + + if (*p == 'D') + { + SLdefine_for_ifdef (p + 1); + continue; + } + + while (*p) { + switch (*p) { + case 'B': pt.flags |= (SLPREP_BLANK_LINES_OK); break; + case 'C': pt.flags |= (SLPREP_COMMENT_LINES_OK); break; + case 'c': if (p[1]) pt.comment_char = *++p; break; + case 'p': if (p[1]) pt.preprocess_char = *++p; break; + default: + fprintf (stderr, "unknown flag '%c'\n", *p); + break; + } + p++; + } + } + + while (NULL != fgets (buf, sizeof (buf) - 1, stdin)) + { + if (SLprep_line_ok (buf, &pt)) + fputs (buf, stdout); + } + + SLprep_close_prep (&pt); + return 0; +} +#endif +/*}}}*/ diff --git a/libslang/src/slproc.c b/libslang/src/slproc.c new file mode 100644 index 0000000..1b81833 --- /dev/null +++ b/libslang/src/slproc.c @@ -0,0 +1,155 @@ +/* Process specific system calls */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#ifdef HAVE_IO_H +# include /* for chmod */ +#endif + +#ifdef HAVE_PROCESS_H +# include /* for getpid */ +#endif + +#if defined(__BORLANDC__) +# include +#endif + +#include +#include +#include +#include + +#include + +#include "slang.h" +#include "_slang.h" + +#ifdef HAVE_KILL +static int kill_cmd (int *pid, int *sig) +{ + int ret; + + if (-1 == (ret = kill ((pid_t) *pid, *sig))) + _SLerrno_errno = errno; + return ret; +} +#endif + +static int getpid_cmd (void) +{ + return getpid (); +} + +#ifdef HAVE_GETPPID +static int getppid_cmd (void) +{ + return getppid (); +} +#endif + +#ifdef HAVE_GETGID +static int getgid_cmd (void) +{ + return getgid (); +} +#endif + +#ifdef HAVE_GETEGID +static int getegid_cmd (void) +{ + return getegid (); +} +#endif + +#ifdef HAVE_GETEUID +static int geteuid_cmd (void) +{ + return geteuid (); +} +#endif + +#ifdef HAVE_GETUID +static int getuid_cmd (void) +{ + return getuid (); +} +#endif + +#ifdef HAVE_SETGID +static int setgid_cmd (int *gid) +{ + if (0 == setgid (*gid)) + return 0; + _SLerrno_errno = errno; + return -1; +} +#endif + +#ifdef HAVE_SETPGID +static int setpgid_cmd (int *pid, int *pgid) +{ + if (0 == setpgid (*pid, *pgid)) + return 0; + _SLerrno_errno = errno; + return -1; +} +#endif + +#ifdef HAVE_SETUID +static int setuid_cmd (int *uid) +{ + if (0 == setuid (*uid)) + return 0; + _SLerrno_errno = errno; + return -1; +} +#endif + +static SLang_Intrin_Fun_Type Process_Name_Table[] = +{ + MAKE_INTRINSIC_0("getpid", getpid_cmd, SLANG_INT_TYPE), + +#ifdef HAVE_GETPPID + MAKE_INTRINSIC_0("getppid", getppid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_GETGID + MAKE_INTRINSIC_0("getgid", getgid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_GETEGID + MAKE_INTRINSIC_0("getegid", getegid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_GETEUID + MAKE_INTRINSIC_0("geteuid", geteuid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_GETUID + MAKE_INTRINSIC_0("getuid", getuid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_SETGID + MAKE_INTRINSIC_I("setgid", setgid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_SETPGID + MAKE_INTRINSIC_II("setpgid", setpgid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_SETUID + MAKE_INTRINSIC_I("setuid", setuid_cmd, SLANG_INT_TYPE), +#endif + +#ifdef HAVE_KILL + MAKE_INTRINSIC_II("kill", kill_cmd, SLANG_INT_TYPE), +#endif + SLANG_END_INTRIN_FUN_TABLE +}; + +int SLang_init_posix_process (void) +{ + if ((-1 == SLadd_intrin_fun_table (Process_Name_Table, "__POSIX_PROCESS__")) + || (-1 == _SLerrno_init ())) + return -1; + return 0; +} diff --git a/libslang/src/slqsort.c b/libslang/src/slqsort.c new file mode 100644 index 0000000..385f0ae --- /dev/null +++ b/libslang/src/slqsort.c @@ -0,0 +1,257 @@ +/******************************************************************/ +/* qsort.c -- Non-Recursive ANSI Quicksort function */ +/* */ +/* Public domain by Raymond Gardner, Englewood CO February 1991 */ +/* */ +/* Usage: */ +/* qsort(base, nbr_elements, width_bytes, compare_function); */ +/* void *base; */ +/* size_t nbr_elements, width_bytes; */ +/* int (*compare_function)(const void *, const void *); */ +/* */ +/* Sorts an array starting at base, of length nbr_elements, each */ +/* element of size width_bytes, ordered via compare_function, */ +/* which is called as (*compare_function)(ptr_to_element1, */ +/* ptr_to_element2) and returns < 0 if element1 < element2, */ +/* 0 if element1 = element2, > 0 if element1 > element2. */ +/* Most refinements are due to R. Sedgewick. See "Implementing */ +/* Quicksort Programs", Comm. ACM, Oct. 1978, and Corrigendum, */ +/* Comm. ACM, June 1979. */ +/******************************************************************/ + +/* John E. Davis: modifed to use my coding style and made gcc warning + * clean. Also, the name changed to reflect the fact that the function + * carries state data. + */ + +#include /* for size_t definition */ + +/* prototypes */ +extern void _SLqsort (void *, size_t, size_t, + int (*)(void *, void *, void *), void *); + +static void swap_chars(char *, char *, size_t); + +/* + * Compile with -DSWAP_INTS if your machine can access an int at an + * arbitrary location with reasonable efficiency. Some machines + * cannot access an int at an odd address at all, so be careful. + */ + +#ifdef SWAP_INTS +static void swap_ints(char *, char *, size_t); +# define SWAP(a, b) (swap_func((char *)(a), (char *)(b), width)) +#else +# define SWAP(a, b) (swap_chars((char *)(a), (char *)(b), size)) +#endif + +#define COMP(a, b, c) ((*comp)((void *)(a), (void *)(b), (c))) + +#define T 7 +/* subfiles of T or fewer elements will be sorted by a simple insertion sort. + * Note! T must be at least 3 + */ + +void _SLqsort(void *basep, size_t nelems, size_t size, + int (*comp)(void *, void *, void *), void *cd) +{ + char *stack[40], **sp; /* stack and stack pointer */ + char *i, *j, *limit; /* scan and limit pointers */ + size_t thresh; /* size of T elements in bytes */ + char *base; /* base pointer as char * */ + +#ifdef SWAP_INTS + size_t width; /* width of array element */ + void (*swap_func)(char *, char *, size_t); /* swap func pointer*/ + + width = size; /* save size for swap routine */ + swap_func = swap_chars; /* choose swap function */ + if ( size % sizeof(int) == 0 ) + { + /* size is multiple of ints */ + width /= sizeof(int); /* set width in ints */ + swap_func = swap_ints; /* use int swap function */ + } +#endif + + base = (char *)basep; /* set up char * base pointer */ + thresh = T * size; /* init threshold */ + sp = stack; /* init stack pointer */ + limit = base + nelems * size;/* pointer past end of array */ + + while (1) + { + /* repeat until break... */ + if (limit > base + thresh) + { + /* if more than T elements, swap base with middle */ + SWAP((((limit-base)/size)/2)*size+base, base); + + i = base + size; /* i scans left to right */ + j = limit - size; /* j scans right to left */ + if (COMP(i, j, cd) > 0) /* Sedgewick's */ + SWAP(i, j); /* three-element sort */ + if (COMP(base, j, cd) > 0)/* sets things up */ + SWAP(base, j); /* so that */ + if (COMP(i, base,cd ) > 0)/* *i <= *base <= *j */ + SWAP(i, base); /* *base is pivot element */ + + while (1) + { + do + { + /* move i right until *i >= pivot */ + i += size; + } + while (COMP(i, base, cd) < 0); + + /* move j left until *j <= pivot */ + do + { + j -= size; + } + while (COMP(j, base, cd) > 0); + + /* if pointers crossed, break loop */ + if (i > j) break; + + SWAP(i, j); /* else swap elements, keep scanning*/ + } + + SWAP(base, j); /* move pivot into correct place */ + + if (j - base > limit - i) + { + /* if left subfile larger */ + sp[0] = base; /* stack left subfile base */ + sp[1] = j; /* and limit */ + base = i; /* sort the right subfile */ + } + else + { + /* else right subfile larger*/ + sp[0] = i; /* stack right subfile base */ + sp[1] = limit; /* and limit */ + limit = j; /* sort the left subfile */ + } + sp += 2; /* increment stack pointer */ + } + else + { + /* else subfile is small, use insertion sort */ + j = base; + i = j + size; + + while (i < limit) + { + while (COMP(j, j + size, cd) > 0) + { + SWAP(j, j+size); + if (j == base) + break; + j -= size; + } + + j = i; + i += size; + } + + if (sp == stack) /* done */ + break; + + /* if any entries on stack */ + sp -= 2; /* pop the base and limit */ + base = sp[0]; + limit = sp[1]; + } + } +} + +/* +** swap nbytes between a and b +*/ + +static void swap_chars(char *a, char *b, size_t nbytes) +{ + char tmp; + do + { + tmp = *a; *a++ = *b; *b++ = tmp; + } + while ( --nbytes ); +} + +#ifdef SWAP_INTS + +/* +** swap nints between a and b +*/ + +static void swap_ints(char *ap, char *bp, size_t nints) +{ + int *a = (int *)ap, *b = (int *)bp; + int tmp; + do + { + tmp = *a; *a++ = *b; *b++ = tmp; + } + while ( --nints ); +} + +#endif + +#ifdef TESTING + +#include +#include + +static int cmp_fun (void *a, void *b, void *c) +{ + double x, y; + double *xp, *yp; + double *data; + + data = (double *) c; + + xp = data + *(unsigned int *)a; + yp = data + *(unsigned int *)b; + + x = *xp; + y = *yp; + + if (x > y) return 1; else if (x < y) return -1; + if (xp > yp) return 1; + if (xp == yp) return 0; + return -1; +} + +#define ARRAY_SIZE 10000 +int main (int argc, char **argv) +{ + unsigned int i; + double x, dx; + unsigned int index_array [ARRAY_SIZE]; + double double_array [ARRAY_SIZE]; + + x = 0.0; + dx = 6.28 / ARRAY_SIZE; + for (i = 0; i < ARRAY_SIZE; i++) + { + double_array [i] = sin(x); + index_array [i] = i; + x += dx; + } + + _SLqsort ((void *) index_array, ARRAY_SIZE, + sizeof (unsigned int), cmp_fun, (void *) double_array); + + if (argc > 1) + for (i = 0; i < ARRAY_SIZE; i++) + { + fprintf (stdout, "%f\t%f\n", + double_array[i], double_array[index_array[i]]); + } + + return 0; +} +#endif diff --git a/libslang/src/slregexp.c b/libslang/src/slregexp.c new file mode 100644 index 0000000..d41ca15 --- /dev/null +++ b/libslang/src/slregexp.c @@ -0,0 +1,937 @@ +/* ed style regular expressions */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#define SET_BIT(b, n) b[(unsigned int) (n) >> 3] |= 1 << ((unsigned int) (n) % 8) +#define TEST_BIT(b, n) (b[(unsigned int)(n) >> 3] & (1 << ((unsigned int) (n) % 8))) +#define LITERAL 1 +#define RANGE 2 /* [...] */ +#define ANY 3 /* . */ +#define BOL 4 /* ^ */ +#define EOL 5 /* $ */ +#define NTH_MATCH 6 /* \1 \2 ... \9 */ +#define OPAREN 7 /* \( */ +#define CPAREN 0x8 /* \) */ +#define ANY_DIGIT 0x9 /* \d */ +#define BOW 0xA /* \< */ +#define EOW 0xB /* \> */ +#if 0 +#define NOT_LITERAL 0xC /* \~ */ +#endif +#define STAR 0x80 /* * */ +#define LEAST_ONCE 0x40 /* + */ +#define MAYBE_ONCE 0x20 /* ? */ +#define MANY 0x10 /* {n,m} */ +/* The rest are additions */ +#define YES_CASE (STAR | BOL) +#define NO_CASE (STAR | EOL) + +#define UPPERCASE(x) (cs ? (x) : UPPER_CASE(x)) +#define LOWERCASE(x) (cs ? (x) : LOWER_CASE(x)) + +static unsigned char Word_Chars[256]; +#define IS_WORD_CHAR(x) Word_Chars[(unsigned int) (x)] + +#if 0 +static int ctx->open_paren_number; +static char Closed_Paren_Matches[10]; + +static SLRegexp_Type *This_Reg; +static unsigned char *This_Str; +#endif + +typedef struct +{ + SLRegexp_Type *reg; + unsigned char *str; + unsigned int len; + char closed_paren_matches[10]; + int open_paren_number; +} +Re_Context_Type; + +static unsigned char *do_nth_match (Re_Context_Type *ctx, int n, unsigned char *str, unsigned char *estr) +{ + unsigned char *bpos; + + if (ctx->closed_paren_matches[n] == 0) + return NULL; + + bpos = ctx->reg->beg_matches[n] + ctx->str; + n = ctx->reg->end_matches[n]; + if (n == 0) return(str); + if (n > (int) (estr - str)) return (NULL); + + /* This needs fixed for case sensitive match */ + if (0 != strncmp((char *) str, (char *) bpos, (unsigned int) n)) return (NULL); + str += n; + return (str); +} + +/* returns pointer to the end of regexp or NULL */ +static unsigned char *regexp_looking_at (Re_Context_Type *ctx, register unsigned char *str, unsigned char *estr, unsigned char *buf, register int cs) +{ + register unsigned char p, p1; + unsigned char *save_str, *tmpstr; + int n, n0, n1; + int save_num_open; + char save_closed_matches[10]; + + p = *buf++; + + while (p != 0) + { + /* p1 = UPPERCASE(*buf); */ + /* if (str < estr) c = UPPERCASE(*str); */ + + switch((unsigned char) p) + { + case BOW: + if ((str != ctx->str) + && ((str >= estr) + || IS_WORD_CHAR(*(str - 1)) + || (0 == IS_WORD_CHAR(*str)))) return NULL; + break; + + case EOW: + if ((str < estr) + && IS_WORD_CHAR (*str)) return NULL; + break; + + case YES_CASE: cs = 1; break; + case NO_CASE: cs = 0; break; + + case OPAREN: + ctx->open_paren_number++; + ctx->reg->beg_matches[ctx->open_paren_number] = (int) (str - ctx->str); + break; + case CPAREN: + n = ctx->open_paren_number; + while (n > 0) + { + if (ctx->closed_paren_matches[n] != 0) + { + n--; + continue; + } + ctx->closed_paren_matches[n] = 1; + ctx->reg->end_matches[n] = (unsigned int) (str - (ctx->str + ctx->reg->beg_matches[n])); + break; + } + break; +#ifdef NOT_LITERAL + case NOT_LITERAL: + if ((str >= estr) || (*buf == UPPERCASE(*str))) return (NULL); + str++; buf++; + break; + + case MAYBE_ONCE | NOT_LITERAL: + save_str = str; + if ((str < estr) && (*buf != UPPERCASE(*str))) str++; + buf++; + goto match_rest; + + case NOT_LITERAL | LEAST_ONCE: /* match at least once */ + if ((str >= estr) || (UPPERCASE(*str) == UPPERCASE(*buf))) return (NULL); + str++; + /* drop */ + case STAR | NOT_LITERAL: + save_str = str; p1 = *buf; + while ((str < estr) && (UPPERCASE(*str) != p1)) str++; + buf++; + goto match_rest; + + /* this type consists of the expression + two bytes that + determine number of matches to perform */ + case MANY | NOT_LITERAL: + p1 = *buf; buf++; + n = n0 = (int) (unsigned char) *buf++; + /* minimum number to match--- could be 0 */ + n1 = (int) (unsigned char) *buf++; + /* maximum number to match */ + + while (n && (str < estr) && (p1 != UPPERCASE(*str))) + { + n--; + str++; + } + if (n) return (NULL); + + save_str = str; + n = n1 - n0; + while (n && (str < estr) && (p1 != UPPERCASE(*str))) + { + n--; + str++; + } + goto match_rest; +#endif /* NOT_LITERAL */ + case LITERAL: + if ((str >= estr) || (*buf != UPPERCASE(*str))) return (NULL); + str++; buf++; + break; + + case MAYBE_ONCE | LITERAL: + save_str = str; + if ((str < estr) && (*buf == UPPERCASE(*str))) str++; + buf++; + goto match_rest; + + case LITERAL | LEAST_ONCE: /* match at least once */ + if ((str >= estr) || (UPPERCASE(*str) != UPPERCASE(*buf))) return (NULL); + str++; + /* drop */ + case STAR | LITERAL: + save_str = str; p1 = *buf; + while ((str < estr) && (UPPERCASE(*str) == p1)) str++; + buf++; + goto match_rest; + + /* this type consists of the expression + two bytes that + determine number of matches to perform */ + case MANY | LITERAL: + p1 = *buf; buf++; + n = n0 = (int) (unsigned char) *buf++; + /* minimum number to match--- could be 0 */ + n1 = (int) (unsigned char) *buf++; + /* maximum number to match */ + + while (n && (str < estr) && (p1 == UPPERCASE(*str))) + { + n--; + str++; + } + if (n) return (NULL); + + save_str = str; + n = n1 - n0; + while (n && (str < estr) && (p1 == UPPERCASE(*str))) + { + n--; + str++; + } + goto match_rest; + + case NTH_MATCH: + if ((str = do_nth_match(ctx, (int) (unsigned char) *buf, str, estr)) == NULL) return(NULL); + buf++; + break; + + case MAYBE_ONCE | NTH_MATCH: + save_str = str; + tmpstr = do_nth_match (ctx, (int) (unsigned char) *buf, str, estr); + buf++; + if (tmpstr != NULL) + { + str = tmpstr; + goto match_rest; + } + continue; + + case LEAST_ONCE | NTH_MATCH: + if ((str = do_nth_match(ctx, (int) (unsigned char) *buf, str, estr)) == NULL) return(NULL); + /* drop */ + case STAR | NTH_MATCH: + save_str = str; + while (NULL != (tmpstr = do_nth_match(ctx, (int) (unsigned char) *buf, str, estr))) + { + str = tmpstr; + } + buf++; + goto match_rest; + + case MANY | NTH_MATCH: return(NULL); + /* needs done */ + + case RANGE: + if (str >= estr) return (NULL); + if (TEST_BIT(buf, UPPERCASE(*str)) == 0) return (NULL); + buf += 32; str++; + break; + + case MAYBE_ONCE | RANGE: + save_str = str; + if ((str < estr) && TEST_BIT(buf, UPPERCASE(*str))) str++; + buf += 32; + goto match_rest; + + case LEAST_ONCE | RANGE: + if ((str >= estr) || (0 == TEST_BIT(buf, UPPERCASE(*str)))) return NULL; + str++; + /* drop */ + case STAR | RANGE: + save_str = str; + while ((str < estr) && TEST_BIT(buf, UPPERCASE(*str))) str++; + buf += 32; + goto match_rest; + + /* The first 32 bytes correspond to the range and the two + * following bytes indicate the min and max number of matches. + */ + case MANY | RANGE: + /* minimum number to match--- could be 0 */ + n = n0 = (int) (unsigned char) *(buf + 32); + /* maximum number to match */ + n1 = (int) (unsigned char) *(buf + 33); + + while (n && (str < estr) && (TEST_BIT(buf, UPPERCASE(*str)))) + { + n--; + str++; + } + if (n) return (NULL); + save_str = str; + n = n1 - n0; + while (n && (str < estr) && (TEST_BIT(buf, UPPERCASE(*str)))) + { + n--; + str++; + } + buf += 34; /* 32 + 2 */ + goto match_rest; + + case ANY_DIGIT: + if ((str >= estr) || (*str > '9') || (*str < '0')) return (NULL); + str++; + break; + + case MAYBE_ONCE | ANY_DIGIT: + save_str = str; + if ((str < estr) && ((*str > '9') || (*str < '0'))) str++; + goto match_rest; + + case LEAST_ONCE | ANY_DIGIT: + if ((str >= estr) || ((*str > '9') || (*str < '0'))) return NULL; + str++; + /* drop */ + case STAR | ANY_DIGIT: + save_str = str; + while ((str < estr) && ((*str <= '9') && (*str >= '0'))) str++; + goto match_rest; + + case MANY | ANY_DIGIT: + /* needs finished */ + return (NULL); + + case ANY: + if ((str >= estr) || (*str == '\n')) return (NULL); + str++; + break; + + case MAYBE_ONCE | ANY: + save_str = str; + if ((str < estr) && (*str != '\n')) str++; + goto match_rest; + + case LEAST_ONCE | ANY: + if ((str >= estr) || (*str == '\n')) return (NULL); + str++; + /* drop */ + case STAR | ANY: + save_str = str; + while ((str < estr) && (*str != '\n')) str++; + goto match_rest; + + case MANY | ANY: + return (NULL); + /* needs finished */ + + case EOL: + if ((str >= estr) || (*str == '\n')) return (str); + return(NULL); + + default: return (NULL); + } + p = *buf++; + continue; + + match_rest: + if (save_str == str) + { + p = *buf++; + continue; + } + + /* if (p == EOL) + * { + * if (str < estr) return (NULL); else return (str); + * } + */ + + SLMEMCPY(save_closed_matches, ctx->closed_paren_matches, sizeof(save_closed_matches)); + save_num_open = ctx->open_paren_number; + while (str >= save_str) + { + tmpstr = regexp_looking_at (ctx, str, estr, buf, cs); + if (tmpstr != NULL) return(tmpstr); + SLMEMCPY(ctx->closed_paren_matches, save_closed_matches, sizeof(ctx->closed_paren_matches)); + ctx->open_paren_number = save_num_open; + str--; + } + return NULL; + } + if ((p != 0) && (p != EOL)) return (NULL); else return (str); +} + +static void +fixup_beg_end_matches (Re_Context_Type *ctx, SLRegexp_Type *r, unsigned char *str, unsigned char *epos) +{ + int i; + + if (str == NULL) + { + r->beg_matches[0] = -1; + r->end_matches[0] = 0; + SLMEMSET(ctx->closed_paren_matches, 0, sizeof(ctx->closed_paren_matches)); + } + else + { + r->beg_matches[0] = (int) (str - ctx->str); + r->end_matches[0] = (unsigned int) (epos - str); + } + + for (i = 1; i < 10; i++) + { + if (ctx->closed_paren_matches [i] == 0) + { + r->beg_matches[i] = -1; + r->end_matches[i] = 0; + } + } +} + +static void init_re_context (Re_Context_Type *ctx, SLRegexp_Type *reg, + unsigned char *str, unsigned int len) +{ + memset ((char *) ctx, 0, sizeof (Re_Context_Type)); + ctx->reg = reg; + ctx->str = str; + ctx->len = len; +} + +unsigned char *SLang_regexp_match(unsigned char *str, + unsigned int len, SLRegexp_Type *reg) +{ + register unsigned char c = 0, *estr = str + len; + int cs = reg->case_sensitive, lit = 0; + unsigned char *buf = reg->buf, *epos = NULL; + Re_Context_Type ctx_buf; + + if (reg->min_length > len) return NULL; + + init_re_context (&ctx_buf, reg, str, len); + + if (*buf == BOL) + { + if (NULL == (epos = regexp_looking_at (&ctx_buf, str, estr, buf + 1, cs))) + str = NULL; + + fixup_beg_end_matches (&ctx_buf, reg, str, epos); + return str; + } + + if (*buf == NO_CASE) + { + buf++; cs = 0; + } + + if (*buf == YES_CASE) + { + buf++; cs = 1; + } + + if (*buf == LITERAL) + { + lit = 1; + c = *(buf + 1); + } + else if ((*buf == OPAREN) && (*(buf + 1) == LITERAL)) + { + lit = 1; + c = *(buf + 2); + } + + while (1) + { + ctx_buf.open_paren_number = 0; + memset (ctx_buf.closed_paren_matches, 0, sizeof(ctx_buf.closed_paren_matches)); + /* take care of leading chars */ + if (lit) + { + while ((str < estr) && (c != UPPERCASE(*str))) str++; + if (str >= estr) + break; /* failed */ + } + + if (NULL != (epos = regexp_looking_at(&ctx_buf, str, estr, buf, cs))) + { + fixup_beg_end_matches (&ctx_buf, reg, str, epos); + return str; + } + if (str >= estr) + break; + str++; + } + fixup_beg_end_matches (&ctx_buf, reg, NULL, epos); + return NULL; +} + +static unsigned char *convert_digit(unsigned char *pat, int *nn) +{ + int n = 0, m = 0; + unsigned char c; + while (c = (unsigned char) *pat, (c <= '9') && (c >= '0')) + { + pat++; + n = 10 * n + (c - '0'); + m++; + } + if (m == 0) + { + return (NULL); + } + *nn = n; + return pat; +} + +#define ERROR return (int) (pat - reg->pat) + +/* Returns 0 if successful or offset in pattern of error */ +int SLang_regexp_compile (SLRegexp_Type *reg) +{ + register unsigned char *buf, *ebuf, *pat; + unsigned char *last = NULL, *tmppat; + register unsigned char c; + int i, reverse = 0, n, cs; + int oparen = 0, nparen = 0; + /* substring stuff */ + int count, last_count, this_max_mm = 0, max_mm = 0, ordinary_search, + no_osearch = 0, min_length = 0; + unsigned char *mm_p = NULL, *this_mm_p = NULL; + static int already_initialized; + + reg->beg_matches[0] = reg->end_matches[0] = 0; + buf = reg->buf; + ebuf = (reg->buf + reg->buf_len) - 2; /* make some room */ + pat = reg->pat; + cs = reg->case_sensitive; + + if (already_initialized == 0) + { + SLang_init_case_tables (); +#ifdef IBMPC_SYSTEM + SLmake_lut (Word_Chars, (unsigned char *) "_0-9a-zA-Z\200-\232\240-\245\341-\353", 0); +#else + SLmake_lut (Word_Chars, (unsigned char *) "_0-9a-zA-Z\277-\326\330-\336\340-\366\370-\376", 0); +#endif + already_initialized = 1; + } + + i = 1; while (i < 10) + { + reg->beg_matches[i] = -1; + reg->end_matches[i] = 0; + i++; + } + + if (*pat == '\\') + { + if (pat[1] == 'c') + { + cs = 1; + pat += 2; + no_osearch = 1; + } + else if (pat[1] == 'C') + { + cs = 0; + pat += 2; + no_osearch = 1; + } + } + + if (*pat == '^') + { + pat++; + *buf++ = BOL; + reg->must_match_bol = 1; + } + else reg->must_match_bol = 0; + + if (cs != reg->case_sensitive) + { + if (cs) *buf++ = YES_CASE; + else *buf++ = NO_CASE; + } + + *buf = 0; + + last_count = count = 0; + while ((c = *pat++) != 0) + { + if (buf >= ebuf - 3) + { + SLang_doerror ("Pattern too large to be compiled."); + ERROR; + } + + count++; + switch (c) + { + case '$': + if (*pat != 0) goto literal_char; + *buf++ = EOL; + break; + + case '\\': + c = *pat++; + no_osearch = 1; + switch(c) + { + case 'e': c = 033; goto literal_char; + case 'n': c = '\n'; goto literal_char; + case 't': c = '\t'; goto literal_char; + case 'C': cs = 0; *buf++ = NO_CASE; break; + case 'c': cs = 1; *buf++ = YES_CASE; break; + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + c = c - '0'; + if ((int) c > nparen) ERROR; + last = buf; + *buf++ = NTH_MATCH; *buf++ = c; + break; +#ifdef NOT_LITERAL + case '~': /* slang extension */ + if ((c = *pat) == 0) ERROR; + pat++; + last = buf; + *buf++ = NOT_LITERAL; + *buf++ = c; + min_length++; + break; +#endif + case 'd': /* slang extension */ + last = buf; + *buf++ = ANY_DIGIT; + min_length++; + break; + + case '<': + last = NULL; + *buf++ = BOW; + break; + + case '>': + last = NULL; + *buf++ = EOW; + break; + + case '{': + if (last == NULL) goto literal_char; + *last |= MANY; + tmppat = convert_digit(pat, &n); + if (tmppat == NULL) ERROR; + pat = tmppat; + *buf++ = n; + + min_length += (n - 1); + + if (*pat == '\\') + { + *buf++ = n; + } + else if (*pat == ',') + { + pat++; + if (*pat == '\\') + { + n = 255; + } + else + { + tmppat = convert_digit(pat, &n); + if (tmppat == NULL) ERROR; + pat = tmppat; + if (*pat != '\\') ERROR; + } + *buf++ = n; + } + else ERROR; + last = NULL; + pat++; + if (*pat != '}') ERROR; + pat++; + break; /* case '{' */ + + case '(': + oparen++; + if (oparen > 9) ERROR; + *buf++ = OPAREN; + break; + case ')': + if (oparen == 0) ERROR; + oparen--; + nparen++; + *buf++ = CPAREN; + break; + + case 0: ERROR; + default: + goto literal_char; + } + break; + + case '[': + + *buf = RANGE; + last = buf++; + + if (buf + 32 >= ebuf) ERROR; + + for (i = 0; i < 32; i++) buf[i] = 0; + c = *pat++; + if (c == '^') + { + reverse = 1; + SET_BIT(buf, '\n'); + c = *pat++; + } + + if (c == ']') + { + SET_BIT(buf, c); + c = *pat++; + } + while (c && (c != ']')) + { + if (c == '\\') + { + c = *pat++; + switch(c) + { + case 'n': c = '\n'; break; + case 't': c = '\t'; break; + case 0: ERROR; + } + } + + if (*pat == '-') + { + pat++; + while (c < *pat) + { + if (cs == 0) + { + SET_BIT(buf, UPPERCASE(c)); + SET_BIT(buf, LOWERCASE(c)); + } + else SET_BIT(buf, c); + c++; + } + } + if (cs == 0) + { + SET_BIT(buf, UPPERCASE(c)); + SET_BIT(buf, LOWERCASE(c)); + } + else SET_BIT(buf, c); + c = *pat++; + } + if (c != ']') ERROR; + if (reverse) for (i = 0; i < 32; i++) buf[i] = buf[i] ^ 0xFF; + reverse = 0; + buf += 32; + min_length++; + break; + + case '.': + last = buf; + *buf++ = ANY; + min_length++; + break; + + case '*': + if (last == NULL) goto literal_char; + *last |= STAR; + min_length--; + last = NULL; + break; + + case '+': + if (last == NULL) goto literal_char; + *last |= LEAST_ONCE; + last = NULL; + break; + + case '?': + if (last == NULL) goto literal_char; + *last |= MAYBE_ONCE; + last = NULL; + min_length--; + break; + + literal_char: + default: + /* This is to keep track of longest substring */ + min_length++; + this_max_mm++; + if (last_count + 1 == count) + { + if (this_max_mm == 1) + { + this_mm_p = buf; + } + else if (max_mm < this_max_mm) + { + mm_p = this_mm_p; + max_mm = this_max_mm; + } + } + else + { + this_mm_p = buf; + this_max_mm = 1; + } + + last_count = count; + + last = buf; + *buf++ = LITERAL; + *buf++ = UPPERCASE(c); + } + } + *buf = 0; + /* Check for ordinary search */ + ebuf = buf; + buf = reg->buf; + + if (no_osearch) ordinary_search = 0; + else + { + ordinary_search = 1; + while (buf < ebuf) + { + if (*buf != LITERAL) + { + ordinary_search = 0; + break; + } + buf += 2; + } + } + + reg->osearch = ordinary_search; + reg->must_match_str[15] = 0; + reg->min_length = (min_length > 0) ? (unsigned int) min_length : 0; + if (ordinary_search) + { + strncpy((char *) reg->must_match_str, (char *) reg->pat, 15); + reg->must_match = 1; + return(0); + } + /* check for longest substring of pattern */ + reg->must_match = 0; + if ((mm_p == NULL) && (this_mm_p != NULL)) mm_p = this_mm_p; + if (mm_p == NULL) + { + return (0); + } + n = 15; + pat = reg->must_match_str; + buf = mm_p; + while (n--) + { + if (*buf++ != LITERAL) break; + *pat++ = *buf++; + } + *pat = 0; + if (pat != reg->must_match_str) reg->must_match = 1; + return(0); +} + +char *SLregexp_quote_string (char *re, char *buf, unsigned int buflen) +{ + char ch; + char *b, *bmax; + + if (re == NULL) return NULL; + + b = buf; + bmax = buf + buflen; + + while (b < bmax) + { + switch (ch = *re++) + { + case 0: + *b = 0; + return buf; + + case '$': + case '\\': + case '[': + case ']': + case '.': + case '^': + case '*': + case '+': + case '?': + *b++ = '\\'; + if (b == bmax) break; + /* drop */ + + default: + *b++ = ch; + } + } + return NULL; +} + +#if 0 +#define MAX_EXP 4096 +int main(int argc, char **argv) +{ + FILE *fp; + char *regexp, *file; + char expbuf[MAX_EXP], buf[512]; + SLRegexp_Type reg; + + file = argv[2]; + regexp = argv[1]; + + if (NULL == (fp = fopen(file, "r"))) + { + fprintf(stderr, "File not open\n"); + return(1); + } + + reg.buf = expbuf; + reg.buf_len = MAX_EXP; + reg.pat = regexp; + reg.case_sensitive = 1; + + if (!regexp_compile(®)) while (NULL != fgets(buf, 511, fp)) + { + if (reg.osearch) + { + if (NULL == strstr(buf, reg.pat)) continue; + } + else + { + if (reg.must_match && (NULL == strstr(buf, reg.must_match_str))) continue; + if (0 == regexp_match(buf, buf + strlen(buf), ®)) continue; + } + + fputs(buf, stdout); + } + return (0); +} +#endif diff --git a/libslang/src/slrline.c b/libslang/src/slrline.c new file mode 100644 index 0000000..9df1600 --- /dev/null +++ b/libslang/src/slrline.c @@ -0,0 +1,836 @@ +/* SLang_read_line interface --- uses SLang tty stuff */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#ifdef REAL_UNIX_SYSTEM +int SLang_RL_EOF_Char = 4; +#else +int SLang_RL_EOF_Char = 26; +#endif + +int SLang_Rline_Quit; +static SLang_RLine_Info_Type *This_RLI; + +static unsigned char Char_Widths[256]; +static void position_cursor (int); + +static void rl_beep (void) +{ + putc(7, stdout); + fflush (stdout); +} + +/* editing functions */ +static int rl_bol (void) +{ + if (This_RLI->point == 0) return 0; + This_RLI->point = 0; + return 1; +} + +static int rl_eol (void) +{ + if (This_RLI->point == This_RLI->len) return 0; + This_RLI->point = This_RLI->len; + return 1; +} + +static int rl_right (void) +{ + if (This_RLI->point == This_RLI->len) return 0; + This_RLI->point++; + return 1; +} + +static int rl_left (void) +{ + if (This_RLI->point == 0) return 0; + This_RLI->point--; + return 1; +} + +static int rl_self_insert (void) +{ + unsigned char *pmin, *p; + + if (This_RLI->len == This_RLI->buf_len) + { + rl_beep (); + return 0; + } + + pmin = This_RLI->buf + This_RLI->point; + p = This_RLI->buf + This_RLI->len; + while (p > pmin) + { + *p = *(p - 1); + p--; + } + *pmin = SLang_Last_Key_Char; + + This_RLI->len++; + This_RLI->point++; + if ((This_RLI->curs_pos + 2 >= This_RLI->edit_width) + || (This_RLI->tt_insert == NULL) + || (Char_Widths[SLang_Last_Key_Char] != 1)) return 1; + + (*This_RLI->tt_insert)((char) SLang_Last_Key_Char); + /* update screen buf */ + p = This_RLI->old_upd + (This_RLI->len - 1); + pmin = This_RLI->old_upd + (This_RLI->point - 1); + while (p > pmin) + { + *p = *(p - 1); + p--; + } + *pmin = SLang_Last_Key_Char; + return 0; +} + +int SLang_rline_insert (char *s) +{ + unsigned char *pmin, *p; + int n; + + n = strlen (s); + if (n > This_RLI->buf_len - This_RLI->len) + n = This_RLI->buf_len - This_RLI->len; + + if (n == 0) return 0; + + pmin = This_RLI->buf + This_RLI->point; + p = This_RLI->buf + (This_RLI->len - 1); + + while (p >= pmin) + { + *(p + n) = *p; + p--; + } + SLMEMCPY ((char *) pmin, s, n); + + This_RLI->len += n; + This_RLI->point += n; + return n; +} + +static int rl_deln (int n) +{ + unsigned char *pmax, *p; + + p = This_RLI->buf + This_RLI->point; + pmax = This_RLI->buf + This_RLI->len; + + if (p + n > pmax) n = (int) (pmax - p); + while (p < pmax) + { + *p = *(p + n); + p++; + } + This_RLI->len -= n; + return n; +} + +static int rl_del (void) +{ + return rl_deln(1); +} + +static int rl_quote_insert (void) +{ + int err = SLang_Error; + SLang_Error = 0; + SLang_Last_Key_Char = (*This_RLI->getkey)(); + rl_self_insert (); + if (SLang_Error == SL_USER_BREAK) SLang_Error = 0; + else SLang_Error = err; + return 1; +} + +static int rl_trim (void) +{ + unsigned char *p, *pmax, *p1; + p = This_RLI->buf + This_RLI->point; + pmax = This_RLI->buf + This_RLI->len; + + if (p == pmax) + { + if (p == This_RLI->buf) return 0; + p--; + } + + if ((*p != ' ') && (*p != '\t')) return 0; + p1 = p; + while ((p1 < pmax) && ((*p1 == ' ') || (*p1 == '\t'))) p1++; + pmax = p1; + p1 = This_RLI->buf; + + while ((p >= p1) && ((*p == ' ') || (*p == '\t'))) p--; + if (p == pmax) return 0; + p++; + + This_RLI->point = (int) (p - p1); + return rl_deln ((int) (pmax - p)); +} + +static int rl_bdel (void) +{ + if (rl_left()) return rl_del(); + return 0; +} + +static int rl_deleol (void) +{ + if (This_RLI->point == This_RLI->len) return 0; + *(This_RLI->buf + This_RLI->point) = 0; + This_RLI->len = This_RLI->point; + return 1; +} + +static int rl_delete_line (void) +{ + This_RLI->point = 0; + *(This_RLI->buf + This_RLI->point) = 0; + This_RLI->len = 0; + return 1; +} + +static int rl_enter (void) +{ + *(This_RLI->buf + This_RLI->len) = 0; + SLang_Rline_Quit = 1; + return 1; +} + +static SLKeyMap_List_Type *RL_Keymap; + +/* This update is designed for dumb terminals. It assumes only that the + * terminal can backspace via ^H, and move cursor to start of line via ^M. + * There is a hook so the user can provide a more sophisticated update if + * necessary. + */ + +static void position_cursor (int col) +{ + unsigned char *p, *pmax; + int dc; + + if (col == This_RLI->curs_pos) + { + fflush (stdout); + return; + } + + if (This_RLI->tt_goto_column != NULL) + { + (*This_RLI->tt_goto_column)(col); + This_RLI->curs_pos = col; + fflush (stdout); + return; + } + + dc = This_RLI->curs_pos - col; + if (dc < 0) + { + p = This_RLI->new_upd + This_RLI->curs_pos; + pmax = This_RLI->new_upd + col; + while (p < pmax) putc((char) *p++, stdout); + } + else + { + if (dc < col) + { + while (dc--) putc(8, stdout); + } + else + { + putc('\r', stdout); + p = This_RLI->new_upd; + pmax = This_RLI->new_upd + col; + while (p < pmax) putc((char) *p++, stdout); + } + } + This_RLI->curs_pos = col; + fflush (stdout); +} + +static void erase_eol (SLang_RLine_Info_Type *rli) +{ + unsigned char *p, *pmax; + + p = rli->old_upd + rli->curs_pos; + pmax = rli->old_upd + rli->old_upd_len; + + while (p++ < pmax) putc(' ', stdout); + + rli->curs_pos = rli->old_upd_len; +} + +static unsigned char *spit_out(SLang_RLine_Info_Type *rli, unsigned char *p) +{ + unsigned char *pmax; + position_cursor ((int) (p - rli->new_upd)); + pmax = rli->new_upd + rli->new_upd_len; + while (p < pmax) putc((char) *p++, stdout); + rli->curs_pos = rli->new_upd_len; + return pmax; +} + +static void really_update (SLang_RLine_Info_Type *rli, int new_curs_position) +{ + unsigned char *b = rli->old_upd, *p = rli->new_upd, chb, chp; + unsigned char *pmax; + + if (rli->update_hook != NULL) + { + (*rli->update_hook)(p, rli->edit_width, new_curs_position); + } + else + { + pmax = p + rli->edit_width; + while (p < pmax) + { + chb = *b++; chp = *p++; + if (chb == chp) continue; + + if (rli->old_upd_len <= rli->new_upd_len) + { + /* easy one */ + (void) spit_out (rli, p - 1); + break; + } + spit_out(rli, p - 1); + erase_eol (rli); + break; + } + position_cursor (new_curs_position); + } + + /* update finished, so swap */ + + rli->old_upd_len = rli->new_upd_len; + p = rli->old_upd; + rli->old_upd = rli->new_upd; + rli->new_upd = p; +} + +static void RLupdate (SLang_RLine_Info_Type *rli) +{ + int len, dlen, start_len, prompt_len = 0, tw = 0, count; + int want_cursor_pos; + unsigned char *b, chb, *b_point, *p; + int no_echo; + + no_echo = rli->flags & SL_RLINE_NO_ECHO; + + b_point = (unsigned char *) (rli->buf + rli->point); + *(rli->buf + rli->len) = 0; + + /* expand characters for output buffer --- handle prompt first. + * Do two passes --- first to find out where to begin upon horiz + * scroll and the second to actually fill the buffer. */ + len = 0; + count = 2; /* once for prompt and once for buf */ + + b = (unsigned char *) rli->prompt; + while (count--) + { + if ((count == 0) && no_echo) + break; + + /* The prompt could be NULL */ + if (b != NULL) while ((chb = *b) != 0) + { + /* This will ensure that the screen is scrolled a third of the edit + * width each time */ + if (b_point == b) break; + dlen = Char_Widths[chb]; + if ((chb == '\t') && tw) + { + dlen = tw * ((len - prompt_len) / tw + 1) - (len - prompt_len); + } + len += dlen; + b++; + } + tw = rli->tab; + b = (unsigned char *) rli->buf; + if (count == 1) prompt_len = len; + } + + if (len < rli->edit_width - rli->dhscroll) start_len = 0; + else if ((rli->start_column > len) + || (rli->start_column + rli->edit_width <= len)) + { + start_len = len - (rli->edit_width - rli->dhscroll); + if (start_len < 0) start_len = 0; + } + else start_len = rli->start_column; + rli->start_column = start_len; + + want_cursor_pos = len - start_len; + + /* second pass */ + p = rli->new_upd; + + len = 0; + count = 2; + b = (unsigned char *) rli->prompt; + if (b == NULL) b = (unsigned char *) ""; + + while ((len < start_len) && (*b)) + { + len += Char_Widths[*b++]; + } + + tw = 0; + if (*b == 0) + { + b = (unsigned char *) rli->buf; + while (len < start_len) + { + len += Char_Widths[*b++]; + } + tw = rli->tab; + count--; + } + + len = 0; + while (count--) + { + if ((count == 0) && (no_echo)) + break; + + while ((len < rli->edit_width) && ((chb = *b++) != 0)) + { + dlen = Char_Widths[chb]; + if (dlen == 1) *p++ = chb; + else + { + if ((chb == '\t') && tw) + { + dlen = tw * ((len + start_len - prompt_len) / tw + 1) - (len + start_len - prompt_len); + len += dlen; /* ok since dlen comes out 0 */ + if (len > rli->edit_width) dlen = len - rli->edit_width; + while (dlen--) *p++ = ' '; + dlen = 0; + } + else + { + if (dlen == 3) + { + chb &= 0x7F; + *p++ = '~'; + } + + *p++ = '^'; + if (chb == 127) *p++ = '?'; + else *p++ = chb + '@'; + } + } + len += dlen; + } + /* if (start_len > prompt_len) break; */ + tw = rli->tab; + b = (unsigned char *) rli->buf; + } + + rli->new_upd_len = (int) (p - rli->new_upd); + while (p < rli->new_upd + rli->edit_width) *p++ = ' '; + really_update (rli, want_cursor_pos); +} + +void SLrline_redraw (SLang_RLine_Info_Type *rli) +{ + unsigned char *p = rli->new_upd; + unsigned char *pmax = p + rli->edit_width; + while (p < pmax) *p++ = ' '; + rli->new_upd_len = rli->edit_width; + really_update (rli, 0); + RLupdate (rli); +} + +static int rl_eof_insert (void) +{ + if (This_RLI->len == 0) + { + SLang_Last_Key_Char = SLang_RL_EOF_Char; + /* rl_self_insert (); */ + return rl_enter (); + } + return 0; +} + +/* This is very naive. It knows very little about nesting and nothing + * about quoting. + */ +static void blink_match (SLang_RLine_Info_Type *rli) +{ + unsigned char bra, ket; + unsigned int delta_column; + unsigned char *p, *pmin; + int dq_level, sq_level; + int level; + + pmin = rli->buf; + p = pmin + rli->point; + if (pmin == p) + return; + + ket = SLang_Last_Key_Char; + switch (ket) + { + case ')': + bra = '('; + break; + case ']': + bra = '['; + break; + case '}': + bra = '{'; + break; + default: + return; + } + + level = 0; + sq_level = dq_level = 0; + + delta_column = 0; + while (p > pmin) + { + char ch; + + p--; + delta_column++; + ch = *p; + + if (ch == ket) + { + if ((dq_level == 0) && (sq_level == 0)) + level++; + } + else if (ch == bra) + { + if ((dq_level != 0) || (sq_level != 0)) + continue; + + level--; + if (level == 0) + { + rli->point -= delta_column; + RLupdate (rli); + (*rli->input_pending)(10); + rli->point += delta_column; + RLupdate (rli); + break; + } + if (level < 0) + break; + } + else if (ch == '"') dq_level = !dq_level; + else if (ch == '\'') sq_level = !sq_level; + } +} + +int SLang_read_line (SLang_RLine_Info_Type *rli) +{ + unsigned char *p, *pmax; + SLang_Key_Type *key; + + SLang_Rline_Quit = 0; + This_RLI = rli; + p = rli->old_upd; pmax = p + rli->edit_width; + while (p < pmax) *p++ = ' '; + + /* Sanity checking */ + rli->len = strlen ((char *) rli->buf); + if (rli->len >= rli->buf_len) + { + rli->len = 0; + *rli->buf = 0; + } + if (rli->point > rli->len) rli->point = rli->len; + if (rli->point < 0) rli->point = 0; + + rli->curs_pos = rli->start_column = 0; + rli->new_upd_len = rli->old_upd_len = 0; + + This_RLI->last_fun = NULL; + if (rli->update_hook == NULL) + putc ('\r', stdout); + + RLupdate (rli); + + while (1) + { + key = SLang_do_key (RL_Keymap, (int (*)(void)) rli->getkey); + + if ((key == NULL) || (key->f.f == NULL)) + rl_beep (); + else + { + if ((SLang_Last_Key_Char == SLang_RL_EOF_Char) + && (*key->str == 2) + && (This_RLI->len == 0)) + rl_eof_insert (); + else if (key->type == SLKEY_F_INTRINSIC) + { + if ((key->f.f)()) + RLupdate (rli); + + if ((rli->flags & SL_RLINE_BLINK_MATCH) + && (rli->input_pending != NULL)) + blink_match (rli); + } + + if (SLang_Rline_Quit) + { + This_RLI->buf[This_RLI->len] = 0; + if (SLang_Error == SL_USER_BREAK) + { + SLang_Error = 0; + return -1; + } + return This_RLI->len; + } + } + if (key != NULL) + This_RLI->last_fun = key->f.f; + } +} + +static int rl_abort (void) +{ + rl_delete_line (); + return rl_enter (); +} + +/* TTY interface --- ANSI */ + +static void ansi_goto_column (int n) +{ + putc('\r', stdout); + if (n) fprintf(stdout, "\033[%dC", n); +} + +static void rl_select_line (SLang_Read_Line_Type *p) +{ + This_RLI->last = p; + strcpy ((char *) This_RLI->buf, (char *) p->buf); + This_RLI->point = This_RLI->len = strlen((char *) p->buf); +} +static int rl_next_line (void); +static int rl_prev_line (void) +{ + SLang_Read_Line_Type *prev; + + if (((This_RLI->last_fun != (FVOID_STAR) rl_prev_line) + && (This_RLI->last_fun != (FVOID_STAR) rl_next_line)) + || (This_RLI->last == NULL)) + { + prev = This_RLI->tail; + } + else prev = This_RLI->last->prev; + + if (prev == NULL) + { + rl_beep (); + return 0; + } + + rl_select_line (prev); + return 1; +} +static int rl_redraw (void) +{ + SLrline_redraw (This_RLI); + return 1; +} + +static int rl_next_line (void) +{ + SLang_Read_Line_Type *next; + + if (((This_RLI->last_fun != (FVOID_STAR) rl_prev_line) + && (This_RLI->last_fun != (FVOID_STAR) rl_next_line)) + || (This_RLI->last == NULL)) + { + rl_beep (); + return 0; + } + + next = This_RLI->last->next; + + if (next == NULL) + { + This_RLI->len = This_RLI->point = 0; + *This_RLI->buf = 0; + This_RLI->last = NULL; + } + else rl_select_line (next); + return 1; +} + +static SLKeymap_Function_Type SLReadLine_Functions[] = +{ + {"up", rl_prev_line}, + {"down", rl_next_line}, + {"bol", rl_bol}, + {"eol", rl_eol}, + {"right", rl_right}, + {"left", rl_left}, + {"self_insert", rl_self_insert}, + {"bdel", rl_bdel}, + {"del", rl_del}, + {"deleol", rl_deleol}, + {"enter", rl_enter}, + {"trim", rl_trim}, + {"quoted_insert", rl_quote_insert}, + {(char *) NULL, NULL} +}; + +int SLang_init_readline (SLang_RLine_Info_Type *rli) +{ + int ch; + char simple[2]; + + if (RL_Keymap == NULL) + { + simple[1] = 0; + if (NULL == (RL_Keymap = SLang_create_keymap ("ReadLine", NULL))) + return -1; + + RL_Keymap->functions = SLReadLine_Functions; + + /* This breaks under some DEC ALPHA compilers (scary!) */ +#ifndef __DECC + for (ch = ' '; ch < 256; ch++) + { + simple[0] = (char) ch; + SLkm_define_key (simple, (FVOID_STAR) rl_self_insert, RL_Keymap); + } +#else + ch = ' '; + while (1) + { + simple[0] = (char) ch; + SLkm_define_key (simple, (FVOID_STAR) rl_self_insert, RL_Keymap); + ch = ch + 1; + if (ch == 256) break; + } +#endif /* NOT __DECC */ + + simple[0] = SLang_Abort_Char; + SLkm_define_key (simple, (FVOID_STAR) rl_abort, RL_Keymap); + simple[0] = SLang_RL_EOF_Char; + SLkm_define_key (simple, (FVOID_STAR) rl_eof_insert, RL_Keymap); + +#ifndef IBMPC_SYSTEM + SLkm_define_key ("^[[A", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("^[[B", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("^[[C", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("^[[D", (FVOID_STAR) rl_left, RL_Keymap); + SLkm_define_key ("^[OA", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("^[OB", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("^[OC", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("^[OD", (FVOID_STAR) rl_left, RL_Keymap); +#else + SLkm_define_key ("^@H", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("^@P", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("^@M", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("^@K", (FVOID_STAR) rl_left, RL_Keymap); + SLkm_define_key ("^@S", (FVOID_STAR) rl_del, RL_Keymap); + SLkm_define_key ("^@O", (FVOID_STAR) rl_eol, RL_Keymap); + SLkm_define_key ("^@G", (FVOID_STAR) rl_bol, RL_Keymap); + + SLkm_define_key ("\xE0H", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("\xE0P", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("\xE0M", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("\xE0K", (FVOID_STAR) rl_left, RL_Keymap); + SLkm_define_key ("\xE0S", (FVOID_STAR) rl_del, RL_Keymap); + SLkm_define_key ("\xE0O", (FVOID_STAR) rl_eol, RL_Keymap); + SLkm_define_key ("\xE0G", (FVOID_STAR) rl_bol, RL_Keymap); +#endif + SLkm_define_key ("^C", (FVOID_STAR) rl_abort, RL_Keymap); + SLkm_define_key ("^E", (FVOID_STAR) rl_eol, RL_Keymap); + SLkm_define_key ("^G", (FVOID_STAR) rl_abort, RL_Keymap); + SLkm_define_key ("^I", (FVOID_STAR) rl_self_insert, RL_Keymap); + SLkm_define_key ("^A", (FVOID_STAR) rl_bol, RL_Keymap); + SLkm_define_key ("\r", (FVOID_STAR) rl_enter, RL_Keymap); + SLkm_define_key ("\n", (FVOID_STAR) rl_enter, RL_Keymap); + SLkm_define_key ("^K", (FVOID_STAR) rl_deleol, RL_Keymap); + SLkm_define_key ("^L", (FVOID_STAR) rl_deleol, RL_Keymap); + SLkm_define_key ("^V", (FVOID_STAR) rl_del, RL_Keymap); + SLkm_define_key ("^D", (FVOID_STAR) rl_del, RL_Keymap); + SLkm_define_key ("^F", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("^B", (FVOID_STAR) rl_left, RL_Keymap); + SLkm_define_key ("^?", (FVOID_STAR) rl_bdel, RL_Keymap); + SLkm_define_key ("^H", (FVOID_STAR) rl_bdel, RL_Keymap); + SLkm_define_key ("^P", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("^N", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("^R", (FVOID_STAR) rl_redraw, RL_Keymap); + SLkm_define_key ("`", (FVOID_STAR) rl_quote_insert, RL_Keymap); + SLkm_define_key ("\033\\", (FVOID_STAR) rl_trim, RL_Keymap); + if (SLang_Error) return -1; + } + + if (rli->prompt == NULL) rli->prompt = ""; + if (rli->keymap == NULL) rli->keymap = RL_Keymap; + rli->old_upd = rli->upd_buf1; + rli->new_upd = rli->upd_buf2; + *rli->buf = 0; + rli->point = 0; + + if (rli->flags & SL_RLINE_USE_ANSI) + { + if (rli->tt_goto_column == NULL) rli->tt_goto_column = ansi_goto_column; + } + + if (Char_Widths[0] == 2) return 0; + + for (ch = 0; ch < 32; ch++) Char_Widths[ch] = 2; + for (ch = 32; ch < 256; ch++) Char_Widths[ch] = 1; + Char_Widths[127] = 2; +#ifndef IBMPC_SYSTEM + for (ch = 128; ch < 160; ch++) Char_Widths[ch] = 3; +#endif + + return 0; +} + +SLang_Read_Line_Type *SLang_rline_save_line (SLang_RLine_Info_Type *rli) +{ + SLang_Read_Line_Type *rl; + unsigned char *buf; + + if ((rli == NULL) || (rli->buf == NULL)) + return NULL; + + if (NULL == (rl = (SLang_Read_Line_Type *) SLmalloc (sizeof (SLang_Read_Line_Type))) + || (NULL == (buf = (unsigned char *) SLmake_string ((char *)rli->buf)))) + { + SLfree ((char *)rl); + return NULL; + } + rl->buf = buf; + rl->buf_len = strlen ((char *)buf); + rl->num = rl->misc = 0; + rl->next = rl->prev = NULL; + + if (rli->tail != NULL) + { + rli->tail->next = rl; + rl->prev = rli->tail; + } + rli->tail = rl; + + return rl; +} diff --git a/libslang/src/slscanf.c b/libslang/src/slscanf.c new file mode 100644 index 0000000..c20302d --- /dev/null +++ b/libslang/src/slscanf.c @@ -0,0 +1,712 @@ +/* sscanf function for S-Lang */ +/* Copyright (c) 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" +#include +#include +#include + +#include "slang.h" +#include "_slang.h" + +static void init_map (unsigned char map[256], int base) +{ + memset ((char *) map, 0xFF, 256); + + map['0'] = 0; map['1'] = 1; map['2'] = 2; map['3'] = 3; + map['4'] = 4; map['5'] = 5; map['6'] = 6; map['7'] = 7; + if (base == 8) + return; + + map['8'] = 8; map['9'] = 9; + if (base == 10) + return; + + map['A'] = 10; map['B'] = 11; map['C'] = 12; map['D'] = 13; + map['E'] = 14; map['F'] = 15; map['a'] = 10; map['b'] = 11; + map['c'] = 12; map['d'] = 13; map['e'] = 14; map['f'] = 15; +} + +static char *get_sign (char *s, char *smax, int *sign) +{ + *sign = 1; + if (s + 1 < smax) + { + if (*s == '+') s++; + else if (*s == '-') + { + s++; + *sign = -1; + } + } + return s; +} + + +static int parse_long (char **sp, char *smax, long *np, + long base, unsigned char map[256]) +{ + char *s, *s0; + long n; + int sign; + + s = s0 = get_sign (*sp, smax, &sign); + + n = 0; + while (s < smax) + { + unsigned char value; + + value = map [(unsigned char) *s]; + if (value == 0xFF) + break; + + n = base * n + value; + s++; + } + + *sp = s; + if (s == s0) + return 0; + + *np = n * sign; + + return 1; +} + + +static int parse_int (char **sp, char *smax, int *np, + long base, unsigned char map[256]) +{ + long n; + int status; + + if (1 == (status = parse_long (sp, smax, &n, base, map))) + *np = (int) n; + return status; +} + +static int parse_short (char **sp, char *smax, short *np, + long base, unsigned char map[256]) +{ + long n; + int status; + + if (1 == (status = parse_long (sp, smax, &n, base, map))) + *np = (short) n; + return status; +} + +static int parse_ulong (char **sp, char *smax, unsigned long *np, + long base, unsigned char map[256]) +{ + return parse_long (sp, smax, (long *) np, base, map); +} + +static int parse_uint (char **sp, char *smax, unsigned int *np, + long base, unsigned char map[256]) +{ + return parse_int (sp, smax, (int *) np, base, map); +} + +static int parse_ushort (char **sp, char *smax, unsigned short *np, + long base, unsigned char map[256]) +{ + return parse_short (sp, smax, (short *) np, base, map); +} + +#if SLANG_HAS_FLOAT +/* + * In an ideal world, strtod would be the correct function to use. However, + * there may be problems relying on this function because some systems do + * not support and some that do get it wrong. So, I will handle the parsing + * of the string and let atof or strtod handle the arithmetic. + */ +static int parse_double (char **sp, char *smax, double *d) +{ + char *s, *s0; + int sign; + int expon; + unsigned char map[256]; + char buf[128]; + int has_leading_zeros; + char *start_pos, *sign_pos; + char *b, *bmax; + + start_pos = *sp; + s = get_sign (start_pos, smax, &sign); + if (s >= smax) + { + errno = _SLerrno_errno = EINVAL; + return 0; + } + + /* Prepare the buffer that will be passed to strtod */ + /* Allow the exponent to be 5 significant digits: E+xxxxx\0 */ + bmax = buf + (sizeof (buf) - 8); + buf[0] = '0'; buf[1] = '.'; + b = buf + 2; + + init_map (map, 10); + + /* Skip leading 0s */ + s0 = s; + while ((s < smax) && (*s == '0')) + s++; + has_leading_zeros = (s != s0); + + expon = 0; + while (s < smax) + { + unsigned char value = map [(unsigned char) *s]; + + if (value == 0xFF) + break; + + if (b < bmax) + *b++ = *s; + + expon++; + s++; + } + + if ((s < smax) && (*s == '.')) + { + s++; + if (b == buf + 2) /* nothing added yet */ + { + while ((s < smax) && (*s == '0')) + { + expon--; + s++; + } + } + + while (s < smax) + { + unsigned char value = map [(unsigned char) *s]; + + if (value == 0xFF) + break; + + if (b < bmax) + *b++ = *s; + s++; + } + } + + if ((b == buf + 2) + && (has_leading_zeros == 0)) + { + *sp = start_pos; + errno = EINVAL; + return 0; + } + + if ((s + 1 < smax) && ((*s == 'E') || (*s == 'e'))) + { + int e; + int esign; + + s0 = s; + s = get_sign (s + 1, smax, &esign); + sign_pos = s; + e = 0; + while (s < smax) + { + unsigned char value = map [(unsigned char) *s]; + if (value == 0xFF) + break; + if (e < 25000) /* avoid overflow if 16 bit */ + e = 10 * e + value; + s++; + } +#ifdef ERANGE + if (e >= 25000) + errno = ERANGE; +#endif + if (s == sign_pos) + s = s0; /* ...E-X */ + else + { + e = esign * e; + expon += e; + } + } + + if (expon != 0) + sprintf (b, "e%d", expon); + else + *b = 0; + + *sp = s; + + /* fprintf (stdout, "buf='%s'\n", buf); */ +#ifdef HAVE_STRTOD + *d = sign * strtod (buf, NULL); +#else + *d = sign * atof (buf); +#endif + return 1; +} + +static int parse_float (char **sp, char *smax, float *d) +{ + double x; + if (1 == parse_double (sp, smax, &x)) + { + *d = (float) x; + return 1; + } + return 0; +} +#endif /* SLANG_HAS_FLOAT */ + +static int parse_string (char **sp, char *smax, char **str) +{ + char *s, *s0; + + s0 = s = *sp; + while (s < smax) + { + if (isspace (*s)) + break; + s++; + } + if (NULL == (*str = SLang_create_nslstring (s0, (unsigned int) (s - s0)))) + return -1; + + *sp = s; + return 1; +} + +static int parse_bstring (char **sp, char *smax, char **str) +{ + char *s; + + s = *sp; + if (NULL == (*str = SLang_create_nslstring (s, (unsigned int) (smax - s)))) + return -1; + + *sp = smax; + return 1; +} + +static int parse_range (char **sp, char *smax, char **fp, char **str) +{ + char *s, *s0; + char *range; + char *f; + unsigned char map[256]; + unsigned char reverse; + + /* How can one represent a range with just '^'? The naive answer is + * is [^]. However, this may be interpreted as meaning any character + * but ']' and others. Let's assume that the user will not use a range + * to match '^'. + */ + f = *fp; + /* f is a pointer to (one char after) [...]. */ + if (*f == '^') + { + f++; + reverse = 1; + } + else reverse = 0; + + s0 = f; + if (*f == ']') + f++; + + while (1) + { + char ch = *f; + + if (ch == 0) + { + SLang_verror (SL_INVALID_PARM, "Unexpected end of range in format"); + return -1; + } + if (ch == ']') + break; + f++; + } + if (NULL == (range = SLmake_nstring (s0, (unsigned int) (f - s0)))) + return -1; + *fp = f + 1; /* skip ] */ + + SLmake_lut (map, (unsigned char *) range, reverse); + SLfree (range); + + s0 = s = *sp; + while ((s < smax) && map [(unsigned char) *s]) + s++; + + if (NULL == (*str = SLang_create_nslstring (s0, (unsigned int) (s - s0)))) + return -1; + + *sp = s; + return 1; +} + + +int _SLang_sscanf (void) +{ + int num; + unsigned int num_refs; + char *format; + char *input_string, *input_string_max; + char *f, *s; + unsigned char map8[256], map10[256], map16[256]; + + if (SLang_Num_Function_Args < 2) + { + SLang_verror (SL_INVALID_PARM, "Int_Type sscanf (str, format, ...)"); + return -1; + } + + num_refs = (unsigned int) SLang_Num_Function_Args; + if (-1 == SLreverse_stack (num_refs)) + return -1; + num_refs -= 2; + + if (-1 == SLang_pop_slstring (&input_string)) + return -1; + + if (-1 == SLang_pop_slstring (&format)) + { + SLang_free_slstring (input_string); + return -1; + } + + f = format; + s = input_string; + input_string_max = input_string + strlen (input_string); + + init_map (map8, 8); + init_map (map10, 10); + init_map (map16, 16); + + num = 0; + + while (num_refs != 0) + { + SLang_Object_Type obj; + SLang_Ref_Type *ref; + char *smax; + unsigned char *map; + int base; + int no_assign; + int is_short; + int is_long; + int status; + char chf; + unsigned int width; + int has_width; + + chf = *f++; + + if (chf == 0) + { + /* Hmmm.... what is the most useful thing to do?? */ +#if 1 + break; +#else + SLang_verror (SL_INVALID_PARM, "sscanf: format not big enough for output list"); + goto return_error; +#endif + } + + if (isspace (chf)) + { + s = _SLskip_whitespace (s); + continue; + } + + if ((chf != '%') + || ((chf = *f++) == '%')) + { + if (*s != chf) + break; + s++; + continue; + } + + no_assign = 0; + is_short = 0; + is_long = 0; + width = 0; + smax = input_string_max; + + /* Look for the flag character */ + if (chf == '*') + { + no_assign = 1; + chf = *f++; + } + + /* Width */ + has_width = isdigit (chf); + if (has_width) + { + f--; + (void) parse_uint (&f, f + strlen(f), &width, 10, map10); + chf = *f++; + } + + /* Now the type modifier */ + switch (chf) + { + case 'h': + is_short = 1; + chf = *f++; + break; + + case 'L': /* not implemented */ + case 'l': + is_long = 1; + chf = *f++; + break; + } + + status = -1; + + if ((chf != 'c') && (chf != '[')) + s = _SLskip_whitespace (s); + + if (has_width) + { + if (width > (unsigned int) (input_string_max - s)) + width = (unsigned int) (input_string_max - s); + smax = s + width; + } + + /* Now the format descriptor */ + + map = map10; + base = 10; + + try_again: /* used by i, x, and o, conversions */ + switch (chf) + { + case 0: + SLang_verror (SL_INVALID_PARM, "sscanf: Unexpected end of format"); + goto return_error; + case 'D': + is_long = 1; + case 'd': + if (is_short) + { + obj.data_type = SLANG_SHORT_TYPE; + status = parse_short (&s, smax, &obj.v.short_val, base, map); + } + else if (is_long) + { + obj.data_type = SLANG_LONG_TYPE; + status = parse_long (&s, smax, &obj.v.long_val, base, map); + } + else + { + obj.data_type = SLANG_INT_TYPE; + status = parse_int (&s, smax, &obj.v.int_val, base, map); + } + break; + + + case 'U': + is_long = 1; + case 'u': + if (is_short) + { + obj.data_type = SLANG_USHORT_TYPE; + status = parse_ushort (&s, smax, &obj.v.ushort_val, base, map); + } + else if (is_long) + { + obj.data_type = SLANG_ULONG_TYPE; + status = parse_ulong (&s, smax, &obj.v.ulong_val, base, map); + } + else + { + obj.data_type = SLANG_INT_TYPE; + status = parse_uint (&s, smax, &obj.v.uint_val, base, map); + } + break; + + case 'I': + is_long = 1; + case 'i': + if ((s + 1 >= smax) + || (*s != 0)) + chf = 'd'; + else if (((s[1] == 'x') || (s[1] == 'X')) + && (s + 2 < smax)) + { + s += 2; + chf = 'x'; + } + else chf = 'o'; + goto try_again; + + case 'O': + is_long = 1; + case 'o': + map = map8; + base = 8; + chf = 'd'; + goto try_again; + + case 'X': + is_long = 1; + case 'x': + base = 16; + map = map16; + chf = 'd'; + goto try_again; + + case 'E': + case 'F': + is_long = 1; + case 'e': + case 'f': + case 'g': +#if SLANG_HAS_FLOAT + if (is_long) + { + obj.data_type = SLANG_DOUBLE_TYPE; + status = parse_double (&s, smax, &obj.v.double_val); + } + else + { + obj.data_type = SLANG_FLOAT_TYPE; + status = parse_float (&s, smax, &obj.v.float_val); + } +#else + SLang_verror (SL_NOT_IMPLEMENTED, + "This version of the S-Lang does not support floating point"); + status = -1; +#endif + break; + + case 's': + obj.data_type = SLANG_STRING_TYPE; + status = parse_string (&s, smax, &obj.v.s_val); + break; + + case 'c': + if (has_width == 0) + { + obj.data_type = SLANG_UCHAR_TYPE; + obj.v.uchar_val = *s++; + status = 1; + break; + } + obj.data_type = SLANG_STRING_TYPE; + status = parse_bstring (&s, smax, &obj.v.s_val); + break; + + case '[': + obj.data_type = SLANG_STRING_TYPE; + status = parse_range (&s, smax, &f, &obj.v.s_val); + break; + + case 'n': + obj.data_type = SLANG_UINT_TYPE; + obj.v.uint_val = (unsigned int) (s - input_string); + status = 1; + break; + + default: + status = -1; + SLang_verror (SL_NOT_IMPLEMENTED, "format specifier '%c' is not supported", chf); + break; + } + + if (status == 0) + break; + + if (status == -1) + goto return_error; + + if (no_assign) + { + SLang_free_object (&obj); + continue; + } + + if (-1 == SLang_pop_ref (&ref)) + { + SLang_free_object (&obj); + goto return_error; + } + + if (-1 == SLang_push (&obj)) + { + SLang_free_object (&obj); + SLang_free_ref (ref); + goto return_error; + } + + if (-1 == _SLang_deref_assign (ref)) + { + SLang_free_ref (ref); + goto return_error; + } + SLang_free_ref (ref); + + num++; + num_refs--; + } + + if (-1 == SLdo_pop_n (num_refs)) + goto return_error; + + SLang_free_slstring (format); + SLang_free_slstring (input_string); + return num; + + return_error: + /* NULLS ok */ + SLang_free_slstring (format); + SLang_free_slstring (input_string); + return -1; +} + + +# if SLANG_HAS_FLOAT + +#ifndef HAVE_STDLIB_H +/* Oh dear. Where is the prototype for atof? If not in stdlib, then + * I do not know where. Not in math.h on some systems either. + */ +extern double atof (); +#endif + +double _SLang_atof (char *s) +{ + double x; + + s = _SLskip_whitespace (s); + errno = 0; + + if (1 != parse_double (&s, s + strlen (s), &x)) + { + if ((0 == strcmp ("NaN", s)) + || (0 == strcmp ("-Inf", s)) + || (0 == strcmp ("Inf", s))) + return atof (s); /* let this deal with it */ +#ifdef EINVAL + errno = _SLerrno_errno = EINVAL; +#endif + return 0.0; + } + if (errno) + _SLerrno_errno = errno; + return x; +} +#endif diff --git a/libslang/src/slscroll.c b/libslang/src/slscroll.c new file mode 100644 index 0000000..a959487 --- /dev/null +++ b/libslang/src/slscroll.c @@ -0,0 +1,450 @@ +/* SLang Scrolling Window Routines */ +/* Copyright (c) 1996, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static void find_window_bottom (SLscroll_Window_Type *win) +{ + unsigned int nrows; + unsigned int hidden_mask; + SLscroll_Type *bot, *cline, *last_bot; + unsigned int row; + + nrows = win->nrows; + hidden_mask = win->hidden_mask; + cline = win->current_line; + + win->window_row = row = 0; + last_bot = bot = win->top_window_line; + + while (row < nrows) + { + if (bot == cline) + win->window_row = row; + + last_bot = bot; + + if (bot == NULL) + break; + + bot = bot->next; + + if (hidden_mask) + { + while ((bot != NULL) && (bot->flags & hidden_mask)) + bot = bot->next; + } + + row++; + } + + win->bot_window_line = last_bot; +} + +static int find_top_to_recenter (SLscroll_Window_Type *win) +{ + unsigned int nrows; + unsigned int hidden_mask; + SLscroll_Type *prev, *last_prev, *cline; + + nrows = win->nrows; + cline = win->current_line; + hidden_mask = win->hidden_mask; + + nrows = nrows / 2; + + last_prev = prev = cline; + + while (nrows && (prev != NULL)) + { + nrows--; + last_prev = prev; + do + { + prev = prev->prev; + } + while (hidden_mask + && (prev != NULL) + && (prev->flags & hidden_mask)); + } + + if (prev == NULL) prev = last_prev; + + win->top_window_line = prev; + find_window_bottom (win); + + return 0; +} + +#define HAS_BORDER_CODE 1 +int SLscroll_find_top (SLscroll_Window_Type *win) +{ + unsigned int i; + SLscroll_Type *cline, *prev, *next; + SLscroll_Type *top_window_line; + unsigned int nrows; + unsigned int hidden_mask; + int scroll_mode; + unsigned int border; + + cline = win->current_line; + nrows = win->nrows; + scroll_mode = win->cannot_scroll; + border = win->border; + if (scroll_mode == 2) + border = 0; + + if ((cline == NULL) || (nrows <= 1)) + { + win->top_window_line = cline; + find_window_bottom (win); + return 0; + } + + hidden_mask = win->hidden_mask; + + /* Note: top_window_line might be a bogus pointer. This means that I cannot + * access it unless it really corresponds to a pointer in the buffer. + */ + top_window_line = win->top_window_line; + + if (top_window_line == NULL) + return find_top_to_recenter (win); + + /* Chances are that the current line is visible in the window. This means + * that the top window line should be above it. + */ + prev = cline; + + i = 0; + + while ((i < nrows) && (prev != NULL)) + { + if (prev == top_window_line) + { + SLscroll_Type *twl = top_window_line; + int dir = 0; + + if (i < border) dir = -1; else if (i + border >= nrows) dir = 1; + + if (dir) while (border) + { + if (dir < 0) twl = twl->prev; + else twl = twl->next; + + if (twl == NULL) + { + twl = top_window_line; + break; + } + if ((hidden_mask == 0) + || (0 == (twl->flags & hidden_mask))) + border--; + } + + win->top_window_line = twl; + find_window_bottom (win); + return 0; + } + + do + { + prev = prev->prev; + } + while (hidden_mask + && (prev != NULL) + && (prev->flags & hidden_mask)); + i++; + } + + /* Now check the borders of the window. Perhaps the current line lies + * outsider the border by a line. Only do this if terminal can scroll. + */ + + if (scroll_mode == 1) + return find_top_to_recenter (win); + else if (scroll_mode == -1) + scroll_mode = 0; + + next = cline->next; + while (hidden_mask + && (next != NULL) + && (next->flags & hidden_mask)) + next = next->next; + + if ((next != NULL) + && (next == top_window_line)) + { + /* The current line is one line above the window. This means user + * has moved up past the top of the window. If scroll_mode is set + * to scroll by pages, we need to do a page up. + */ + + win->top_window_line = cline; + find_window_bottom (win); + + if (scroll_mode) return SLscroll_pageup (win); + + return 0; + } + + prev = cline->prev; + + while (hidden_mask + && (prev != NULL) + && (prev->flags & hidden_mask)) + prev = prev->prev; + + if ((prev == NULL) + || (prev != win->bot_window_line)) + return find_top_to_recenter (win); + + /* It looks like cline is below window by one line. See what line should + * be at top to scroll it into view. Only do this unless we are scrolling + * by pages. + */ + if (scroll_mode) + { + win->top_window_line = cline; + find_window_bottom (win); + return 0; + } + + i = 2; + while ((i < nrows) && (prev != NULL)) + { + do + { + prev = prev->prev; + } + while (hidden_mask + && (prev != NULL) + && (prev->flags & hidden_mask)); + i++; + } + + if (prev != NULL) + { + win->top_window_line = prev; + find_window_bottom (win); + return 0; + } + + return find_top_to_recenter (win); +} + +int SLscroll_find_line_num (SLscroll_Window_Type *win) +{ + SLscroll_Type *cline, *l; + unsigned int n; + unsigned int hidden_mask; + + if (win == NULL) return -1; + + hidden_mask = win->hidden_mask; + cline = win->current_line; + + n = 1; + + l = win->lines; + while (l != cline) + { + if ((hidden_mask == 0) + || (0 == (l->flags & hidden_mask))) + n++; + + l = l->next; + } + + win->line_num = n; + n--; + + while (l != NULL) + { + if ((hidden_mask == 0) + || (0 == (l->flags & hidden_mask))) + n++; + l = l->next; + } + win->num_lines = n; + + return 0; +} + +unsigned int SLscroll_next_n (SLscroll_Window_Type *win, unsigned int n) +{ + unsigned int i; + unsigned int hidden_mask; + SLscroll_Type *l, *cline; + + if ((win == NULL) + || (NULL == (cline = win->current_line))) + return 0; + + hidden_mask = win->hidden_mask; + l = cline; + i = 0; + while (i < n) + { + l = l->next; + while (hidden_mask + && (l != NULL) && (l->flags & hidden_mask)) + l = l->next; + + if (l == NULL) + break; + + i++; + cline = l; + } + + win->current_line = cline; + win->line_num += i; + return i; +} + +unsigned int SLscroll_prev_n (SLscroll_Window_Type *win, unsigned int n) +{ + unsigned int i; + unsigned int hidden_mask; + SLscroll_Type *l, *cline; + + if ((win == NULL) + || (NULL == (cline = win->current_line))) + return 0; + + hidden_mask = win->hidden_mask; + l = cline; + i = 0; + while (i < n) + { + l = l->prev; + while (hidden_mask + && (l != NULL) && (l->flags & hidden_mask)) + l = l->prev; + + if (l == NULL) + break; + + i++; + cline = l; + } + + win->current_line = cline; + win->line_num -= i; + return i; +} + +int SLscroll_pageup (SLscroll_Window_Type *win) +{ + SLscroll_Type *l, *top; + unsigned int nrows, hidden_mask; + unsigned int n; + + if (win == NULL) + return -1; + + (void) SLscroll_find_top (win); + + nrows = win->nrows; + + if ((NULL != (top = win->top_window_line)) + && (nrows > 2)) + { + n = 0; + hidden_mask = win->hidden_mask; + l = win->current_line; + while ((l != NULL) && (l != top)) + { + l = l->prev; + if ((hidden_mask == 0) + || ((l != NULL) && (0 == (l->flags & hidden_mask)))) + n++; + } + + if (l != NULL) + { + unsigned int save_line_num; + int ret = 0; + + win->current_line = l; + win->line_num -= n; + + /* Compute a new top/bottom header */ + save_line_num = win->line_num; + + if ((0 == SLscroll_prev_n (win, nrows - 1)) + && (n == 0)) + ret = -1; + + win->top_window_line = win->current_line; + win->current_line = l; + win->line_num = save_line_num; + + find_window_bottom (win); + return ret; + } + } + + if (nrows < 2) nrows++; + if (0 == SLscroll_prev_n (win, nrows - 1)) + return -1; + return 0; +} + +int SLscroll_pagedown (SLscroll_Window_Type *win) +{ + SLscroll_Type *l, *bot; + unsigned int nrows, hidden_mask; + unsigned int n; + + if (win == NULL) + return -1; + + (void) SLscroll_find_top (win); + + nrows = win->nrows; + + if ((NULL != (bot = win->bot_window_line)) + && (nrows > 2)) + { + n = 0; + hidden_mask = win->hidden_mask; + l = win->current_line; + while ((l != NULL) && (l != bot)) + { + l = l->next; + if ((hidden_mask == 0) + || ((l != NULL) && (0 == (l->flags & hidden_mask)))) + n++; + } + + if (l != NULL) + { + win->current_line = l; + win->top_window_line = l; + win->line_num += n; + + find_window_bottom (win); + + if (n || (bot != win->bot_window_line)) + return 0; + + return -1; + } + } + + if (nrows < 2) nrows++; + if (0 == SLscroll_next_n (win, nrows - 1)) + return -1; + return 0; +} + diff --git a/libslang/src/slsearch.c b/libslang/src/slsearch.c new file mode 100644 index 0000000..ac6be1c --- /dev/null +++ b/libslang/src/slsearch.c @@ -0,0 +1,239 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#ifdef upcase +# undef upcase +#endif + +#define upcase(ch) (cs ? ch : UPPER_CASE(ch)) + +static unsigned char *search_forward (register unsigned char *beg, + unsigned char *end, + unsigned char *key, + register int key_len, int cs, int *ind) +{ + register unsigned char char1; + unsigned char *pos; + int j, str_len; + register unsigned char ch; + register int db; + + str_len = (int) (end - beg); + if (str_len < key_len) return (NULL); + + if (key_len == 0) + return NULL; + + char1 = key[key_len - 1]; + beg += (key_len - 1); + + while(1) + { + if (cs) while (beg < end) + { + ch = *beg; + db = ind[(unsigned char) ch]; + if ((db < key_len) && (ch == char1)) break; + beg += db; /* ind[(unsigned char) ch]; */ + } + else while (beg < end) + { + ch = *beg; + db = ind[(unsigned char) ch]; + if ((db < key_len) && + (UPPER_CASE(ch) == char1)) break; + beg += db; /* ind[(unsigned char) ch]; */ + } + + if (beg >= end) return(NULL); + + pos = beg - (key_len - 1); + for (j = 0; j < key_len; j++) + { + ch = upcase(pos[j]); + if (ch != (unsigned char) key[j]) break; + } + + if (j == key_len) return(pos); + beg += 1; + } +} + +static unsigned char *search_backward (unsigned char *beg,unsigned char *end, + unsigned char *key, int key_len, + int cs, int *ind) +{ + unsigned char ch, char1; + int j, str_len, ofs; + + str_len = (int) (end - beg); + if (str_len < key_len) return (NULL); + + if (key_len == 0) + return NULL; + + /* end -= (key_len - 1); */ + end -= key_len; + + char1 = key[0]; + + while(1) + { + while ((beg <= end) && (ch = *end, ch = upcase(ch), ch != char1)) + { + ofs = ind[(unsigned char) ch]; +#ifdef __MSDOS__ + /* This is needed for msdos segment wrapping problems */ + if (beg + ofs > end) return(NULL); +#endif + end -= ofs; + } + if (beg > end) return(NULL); + for (j = 1; j < key_len; j++) + { + ch = upcase(end[j]); + if (ch != key[j]) break; + } + if (j == key_len) return(end); + end--; + } +} + +unsigned char *SLsearch (unsigned char *pmin, unsigned char *pmax, + SLsearch_Type *st) +{ + if (st->dir > 0) return search_forward (pmin, pmax, st->key, + st->key_len, st->cs, st->ind); + else return search_backward (pmin, pmax, st->key, + st->key_len, st->cs, st->ind); +} + +static int Case_Tables_Ok; + +int SLsearch_init (char *str, int dir, int cs, SLsearch_Type *st) +{ + int i, maxi; + register int max = strlen(str); + unsigned char *w, *work = st->key; + register int *indp, *indpm; + int *ind = st->ind; + + if (max >= (int) sizeof (st->key)) + { + SLang_doerror ("Search string too long."); + return -1; + } + + st->dir = dir; st->cs = cs; + + if (!Case_Tables_Ok) SLang_init_case_tables (); + + if (dir > 0) + { + w = work; + } + else + { + maxi = max - 1; + str = str + maxi; + w = work + maxi; + } + + /* for (i = 0; i < 256; i++) ind[i] = max; */ + indp = ind; indpm = ind + 256; + while (indp < indpm) + { + *indp++ = max; + *indp++ = max; + *indp++ = max; + *indp++ = max; + } + + i = 0; + if (cs) while (i < max) + { + i++; + maxi = max - i; + *w = *str; + ind[(unsigned char) *str] = maxi; + str += dir; w += dir; + } + else while (i < max) + { + i++; + maxi = max - i; + *w = UPPER_CASE(*str); + ind[(unsigned char) *w] = maxi; + ind[(unsigned char) LOWER_CASE(*str)] = maxi; + str += dir; w += dir; + } + + work[max] = 0; + st->key_len = max; + return max; +} + +/* 8bit clean upper and lowercase macros */ +unsigned char _SLChg_LCase_Lut[256]; +unsigned char _SLChg_UCase_Lut[256]; + +void SLang_define_case (int *u, int *l) +{ + unsigned char up = (unsigned char) *u, dn = (unsigned char) *l; + + _SLChg_LCase_Lut[up] = dn; + _SLChg_LCase_Lut[dn] = dn; + _SLChg_UCase_Lut[dn] = up; + _SLChg_UCase_Lut[up] = up; +} + +void SLang_init_case_tables (void) +{ + int i, j; + if (Case_Tables_Ok) return; + + for (i = 0; i < 256; i++) + { + _SLChg_UCase_Lut[i] = i; + _SLChg_LCase_Lut[i] = i; + } + + for (i = 'A'; i <= 'Z'; i++) + { + j = i + 32; + _SLChg_UCase_Lut[j] = i; + _SLChg_LCase_Lut[i] = j; + } +#ifdef PC_SYSTEM + /* Initialize for DOS code page 437. */ + _SLChg_UCase_Lut[135] = 128; _SLChg_LCase_Lut[128] = 135; + _SLChg_UCase_Lut[132] = 142; _SLChg_LCase_Lut[142] = 132; + _SLChg_UCase_Lut[134] = 143; _SLChg_LCase_Lut[143] = 134; + _SLChg_UCase_Lut[130] = 144; _SLChg_LCase_Lut[144] = 130; + _SLChg_UCase_Lut[145] = 146; _SLChg_LCase_Lut[146] = 145; + _SLChg_UCase_Lut[148] = 153; _SLChg_LCase_Lut[153] = 148; + _SLChg_UCase_Lut[129] = 154; _SLChg_LCase_Lut[154] = 129; + _SLChg_UCase_Lut[164] = 165; _SLChg_LCase_Lut[165] = 164; +#else + /* ISO Latin */ + for (i = 192; i <= 221; i++) + { + j = i + 32; + _SLChg_UCase_Lut[j] = i; + _SLChg_LCase_Lut[i] = j; + } + _SLChg_UCase_Lut[215] = 215; _SLChg_LCase_Lut[215] = 215; + _SLChg_UCase_Lut[223] = 223; _SLChg_LCase_Lut[223] = 223; + _SLChg_UCase_Lut[247] = 247; _SLChg_LCase_Lut[247] = 247; + _SLChg_UCase_Lut[255] = 255; _SLChg_LCase_Lut[255] = 255; +#endif + Case_Tables_Ok = 1; +} diff --git a/libslang/src/slsignal.c b/libslang/src/slsignal.c new file mode 100644 index 0000000..e5a531a --- /dev/null +++ b/libslang/src/slsignal.c @@ -0,0 +1,336 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include + +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_WAIT_H +# include +#endif + +#include + +#include "slang.h" +#include "_slang.h" + +/* Do not trust these environments */ +#if defined(__MINGW32__) || defined(AMIGA) +# ifdef SLANG_POSIX_SIGNALS +# undef SLANG_POSIX_SIGNALS +# endif +#endif + +/* This function will cause system calls to be restarted after signal if possible */ +SLSig_Fun_Type *SLsignal (int sig, SLSig_Fun_Type *f) +{ +#if defined(SLANG_POSIX_SIGNALS) + struct sigaction old_sa, new_sa; + +# ifdef SIGALRM + /* We want system calls to be interrupted by SIGALRM. */ + if (sig == SIGALRM) return SLsignal_intr (sig, f); +# endif + + sigemptyset (&new_sa.sa_mask); + new_sa.sa_handler = f; + + new_sa.sa_flags = 0; +# ifdef SA_RESTART + new_sa.sa_flags |= SA_RESTART; +# endif + + if (-1 == sigaction (sig, &new_sa, &old_sa)) + return (SLSig_Fun_Type *) SIG_ERR; + + return old_sa.sa_handler; +#else + /* Not POSIX. */ + return signal (sig, f); +#endif +} + +/* This function will NOT cause system calls to be restarted after + * signal if possible + */ +SLSig_Fun_Type *SLsignal_intr (int sig, SLSig_Fun_Type *f) +{ +#ifdef SLANG_POSIX_SIGNALS + struct sigaction old_sa, new_sa; + + sigemptyset (&new_sa.sa_mask); + new_sa.sa_handler = f; + + new_sa.sa_flags = 0; +# ifdef SA_INTERRUPT + new_sa.sa_flags |= SA_INTERRUPT; +# endif + + if (-1 == sigaction (sig, &new_sa, &old_sa)) + return (SLSig_Fun_Type *) SIG_ERR; + + return old_sa.sa_handler; +#else + /* Not POSIX. */ + return signal (sig, f); +#endif +} + +/* We are primarily interested in blocking signals that would cause the + * application to reset the tty. These include suspend signals and + * possibly interrupt signals. + */ +#ifdef SLANG_POSIX_SIGNALS +static sigset_t Old_Signal_Mask; +#endif + +static volatile unsigned int Blocked_Depth; + +int SLsig_block_signals (void) +{ +#ifdef SLANG_POSIX_SIGNALS + sigset_t new_mask; +#endif + + Blocked_Depth++; + if (Blocked_Depth != 1) + { + return 0; + } + +#ifdef SLANG_POSIX_SIGNALS + sigemptyset (&new_mask); +# ifdef SIGQUIT + sigaddset (&new_mask, SIGQUIT); +# endif +# ifdef SIGTSTP + sigaddset (&new_mask, SIGTSTP); +# endif +# ifdef SIGINT + sigaddset (&new_mask, SIGINT); +# endif +# ifdef SIGTTIN + sigaddset (&new_mask, SIGTTIN); +# endif +# ifdef SIGTTOU + sigaddset (&new_mask, SIGTTOU); +# endif +# ifdef SIGWINCH + sigaddset (&new_mask, SIGWINCH); +# endif + + (void) sigprocmask (SIG_BLOCK, &new_mask, &Old_Signal_Mask); + return 0; +#else + /* Not implemented. */ + return -1; +#endif +} + +int SLsig_unblock_signals (void) +{ + if (Blocked_Depth == 0) + return -1; + + Blocked_Depth--; + + if (Blocked_Depth != 0) + return 0; + +#ifdef SLANG_POSIX_SIGNALS + (void) sigprocmask (SIG_SETMASK, &Old_Signal_Mask, NULL); + return 0; +#else + return -1; +#endif +} + +#ifdef MSWINDOWS +int SLsystem (char *cmd) +{ + SLang_verror (SL_NOT_IMPLEMENTED, "system not implemented"); + return -1; +} + +#else +int SLsystem (char *cmd) +{ +#ifdef SLANG_POSIX_SIGNALS + pid_t pid; + int status; + struct sigaction ignore; +# ifdef SIGINT + struct sigaction save_intr; +# endif +# ifdef SIGQUIT + struct sigaction save_quit; +# endif +# ifdef SIGCHLD + sigset_t child_mask, save_mask; +# endif + + if (cmd == NULL) return 1; + + ignore.sa_handler = SIG_IGN; + sigemptyset (&ignore.sa_mask); + ignore.sa_flags = 0; + +# ifdef SIGINT + if (-1 == sigaction (SIGINT, &ignore, &save_intr)) + return -1; +# endif + +# ifdef SIGQUIT + if (-1 == sigaction (SIGQUIT, &ignore, &save_quit)) + { + (void) sigaction (SIGINT, &save_intr, NULL); + return -1; + } +# endif + +# ifdef SIGCHLD + sigemptyset (&child_mask); + sigaddset (&child_mask, SIGCHLD); + if (-1 == sigprocmask (SIG_BLOCK, &child_mask, &save_mask)) + { +# ifdef SIGINT + (void) sigaction (SIGINT, &save_intr, NULL); +# endif +# ifdef SIGQUIT + (void) sigaction (SIGQUIT, &save_quit, NULL); +# endif + return -1; + } +# endif + + pid = fork(); + + if (pid == -1) + status = -1; + else if (pid == 0) + { + /* Child */ +# ifdef SIGINT + (void) sigaction (SIGINT, &save_intr, NULL); +# endif +# ifdef SIGQUIT + (void) sigaction (SIGQUIT, &save_quit, NULL); +# endif +# ifdef SIGCHLD + (void) sigprocmask (SIG_SETMASK, &save_mask, NULL); +# endif + + execl ("/bin/sh", "sh", "-c", cmd, NULL); + _exit (127); + } + else + { + /* parent */ + while (-1 == waitpid (pid, &status, 0)) + { +# ifdef EINTR + if (errno == EINTR) + continue; +# endif +# ifdef ERESTARTSYS + if (errno == ERESTARTSYS) + continue; +# endif + status = -1; + break; + } + } +# ifdef SIGINT + if (-1 == sigaction (SIGINT, &save_intr, NULL)) + status = -1; +# endif +# ifdef SIGQUIT + if (-1 == sigaction (SIGQUIT, &save_quit, NULL)) + status = -1; +# endif +# ifdef SIGCHLD + if (-1 == sigprocmask (SIG_SETMASK, &save_mask, NULL)) + status = -1; +# endif + + return status; + +#else /* No POSIX Signals */ +# ifdef SIGINT + void (*sint)(int); +# endif +# ifdef SIGQUIT + void (*squit)(int); +# endif + int status; + +# ifdef SIGQUIT + squit = SLsignal (SIGQUIT, SIG_IGN); +# endif +# ifdef SIGINT + sint = SLsignal (SIGINT, SIG_IGN); +# endif + status = system (cmd); +# ifdef SIGINT + SLsignal (SIGINT, sint); +# endif +# ifdef SIGQUIT + SLsignal (SIGQUIT, squit); +# endif + return status; +#endif /* POSIX_SIGNALS */ +} +#endif + +#if 0 +#include +static int msw_system (char *cmd) +{ + STARTUPINFO startup_info; + PROCESS_INFORMATION process_info; + int status; + + if (cmd == NULL) return -1; + + memset ((char *) &startup_info, 0, sizeof (STARTUPINFO)); + startup_info.cb = sizeof(STARTUPINFO); + startup_info.dwFlags = STARTF_USESHOWWINDOW; + startup_info.wShowWindow = SW_SHOWDEFAULT; + + if (FALSE == CreateProcess (NULL, + cmd, + NULL, + NULL, + FALSE, + NORMAL_PRIORITY_CLASS|CREATE_NEW_CONSOLE, + NULL, + NULL, + &startup_info, + &process_info)) + { + SLang_verror (0, "%s: CreateProcess failed.", cmd); + return -1; + } + + status = -1; + + if (0xFFFFFFFFUL != WaitForSingleObject (process_info.hProcess, INFINITE)) + { + DWORD exit_code; + + if (TRUE == GetExitCodeProcess (process_info.hProcess, &exit_code)) + status = (int) exit_code; + } + + CloseHandle (process_info.hThread); + CloseHandle (process_info.hProcess); + + return status; +} +#endif diff --git a/libslang/src/slsmg.c b/libslang/src/slsmg.c new file mode 100644 index 0000000..4695d3b --- /dev/null +++ b/libslang/src/slsmg.c @@ -0,0 +1,1579 @@ +/* SLang Screen management routines */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +typedef struct Screen_Type + { + int n; /* number of chars written last time */ + int flags; /* line untouched, etc... */ + SLsmg_Char_Type *old, *neew; +#ifndef IBMPC_SYSTEM + unsigned long old_hash, new_hash; +#endif + } +Screen_Type; + +#define TOUCHED 0x1 +#define TRASHED 0x2 +static int Screen_Trashed; + +Screen_Type SL_Screen[SLTT_MAX_SCREEN_ROWS]; +static int Start_Col, Start_Row; +static int Screen_Cols, Screen_Rows; +static int This_Row, This_Col; +static int This_Color; /* only the first 8 bits of this + * are used. The highest bit is used + * to indicate an alternate character + * set. This leaves 127 userdefineable + * color combination. + */ + +#ifndef IBMPC_SYSTEM +#define ALT_CHAR_FLAG 0x80 +#else +#define ALT_CHAR_FLAG 0x00 +#endif + +#if SLTT_HAS_NON_BCE_SUPPORT && !defined(IBMPC_SYSTEM) +#define REQUIRES_NON_BCE_SUPPORT 1 +static int Bce_Color_Offset; +#endif + +int SLsmg_Newline_Behavior = 0; +int SLsmg_Backspace_Moves = 0; +/* Backward compatibility. Not used. */ +/* int SLsmg_Newline_Moves; */ + +static void (*tt_normal_video)(void) = SLtt_normal_video; +static void (*tt_goto_rc)(int, int) = SLtt_goto_rc; +static void (*tt_cls) (void) = SLtt_cls; +static void (*tt_del_eol) (void) = SLtt_del_eol; +static void (*tt_smart_puts) (SLsmg_Char_Type *, SLsmg_Char_Type *, int, int) = SLtt_smart_puts; +static int (*tt_flush_output) (void) = SLtt_flush_output; +static int (*tt_reset_video) (void) = SLtt_reset_video; +static int (*tt_init_video) (void) = SLtt_init_video; +static int *tt_Screen_Rows = &SLtt_Screen_Rows; +static int *tt_Screen_Cols = &SLtt_Screen_Cols; + +#ifndef IBMPC_SYSTEM +static void (*tt_set_scroll_region)(int, int) = SLtt_set_scroll_region; +static void (*tt_reverse_index)(int) = SLtt_reverse_index; +static void (*tt_reset_scroll_region)(void) = SLtt_reset_scroll_region; +static void (*tt_delete_nlines)(int) = SLtt_delete_nlines; +#endif + +#ifndef IBMPC_SYSTEM +static int *tt_Term_Cannot_Scroll = &SLtt_Term_Cannot_Scroll; +static int *tt_Has_Alt_Charset = &SLtt_Has_Alt_Charset; +static char **tt_Graphics_Char_Pairs = &SLtt_Graphics_Char_Pairs; +static int *tt_Use_Blink_For_ACS = &SLtt_Use_Blink_For_ACS; +#endif + +static int Smg_Inited; + +static void blank_line (SLsmg_Char_Type *p, int n, unsigned char ch) +{ + register SLsmg_Char_Type *pmax = p + n; + register SLsmg_Char_Type color_ch; + + color_ch = SLSMG_BUILD_CHAR(ch,This_Color); + + while (p < pmax) + { + *p++ = color_ch; + } +} + +static void clear_region (int row, int n, unsigned char ch) +{ + int i; + int imax = row + n; + + if (imax > Screen_Rows) imax = Screen_Rows; + for (i = row; i < imax; i++) + { + if (i >= 0) + { + blank_line (SL_Screen[i].neew, Screen_Cols, ch); + SL_Screen[i].flags |= TOUCHED; + } + } +} + +void SLsmg_erase_eol (void) +{ + int r, c; + + if (Smg_Inited == 0) return; + + c = This_Col - Start_Col; + r = This_Row - Start_Row; + + if ((r < 0) || (r >= Screen_Rows)) return; + if (c < 0) c = 0; else if (c >= Screen_Cols) return; + blank_line (SL_Screen[This_Row].neew + c , Screen_Cols - c, ' '); + SL_Screen[This_Row].flags |= TOUCHED; +} + +static void scroll_up (void) +{ + unsigned int i, imax; + SLsmg_Char_Type *neew; + + neew = SL_Screen[0].neew; + imax = Screen_Rows - 1; + for (i = 0; i < imax; i++) + { + SL_Screen[i].neew = SL_Screen[i + 1].neew; + SL_Screen[i].flags |= TOUCHED; + } + SL_Screen[i].neew = neew; + SL_Screen[i].flags |= TOUCHED; + blank_line (neew, Screen_Cols, ' '); + This_Row--; +} + +void SLsmg_gotorc (int r, int c) +{ + This_Row = r; + This_Col = c; +} + +int SLsmg_get_row (void) +{ + return This_Row; +} + +int SLsmg_get_column (void) +{ + return This_Col; +} + +void SLsmg_erase_eos (void) +{ + if (Smg_Inited == 0) return; + + SLsmg_erase_eol (); + clear_region (This_Row + 1, Screen_Rows, ' '); +} + +static int This_Alt_Char; + +void SLsmg_set_char_set (int i) +{ +#ifdef IBMPC_SYSTEM + (void) i; +#else + if ((tt_Use_Blink_For_ACS != NULL) + && (*tt_Use_Blink_For_ACS != 0)) + return;/* alt chars not used and the alt bit + * is used to indicate a blink. + */ + + if (i) This_Alt_Char = ALT_CHAR_FLAG; + else This_Alt_Char = 0; + + This_Color &= 0x7F; + This_Color |= This_Alt_Char; +#endif +} + +void SLsmg_set_color (int color) +{ + if (color < 0) return; +#ifdef REQUIRES_NON_BCE_SUPPORT + color += Bce_Color_Offset; +#endif + This_Color = color | This_Alt_Char; +} + +void SLsmg_reverse_video (void) +{ + SLsmg_set_color (1); +} + +void SLsmg_normal_video (void) +{ + SLsmg_set_color (0); +} + +static int point_visible (int col_too) +{ + return ((This_Row >= Start_Row) && (This_Row < Start_Row + Screen_Rows) + && ((col_too == 0) + || ((This_Col >= Start_Col) + && (This_Col < Start_Col + Screen_Cols)))); +} + +void SLsmg_write_string (char *str) +{ + SLsmg_write_nchars (str, strlen (str)); +} + +void SLsmg_write_nstring (char *str, unsigned int n) +{ + unsigned int width; + char blank = ' '; + + /* Avoid a problem if a user accidently passes a negative value */ + if ((int) n < 0) + return; + + if (str == NULL) width = 0; + else + { + width = strlen (str); + if (width > n) width = n; + SLsmg_write_nchars (str, width); + } + while (width++ < n) SLsmg_write_nchars (&blank, 1); +} + +void SLsmg_write_wrapped_string (char *s, int r, int c, + unsigned int dr, unsigned int dc, + int fill) +{ + register char ch, *p; + int maxc = (int) dc; + + if ((dr == 0) || (dc == 0)) return; + p = s; + dc = 0; + while (1) + { + ch = *p++; + if ((ch == 0) || (ch == '\n')) + { + int diff; + + diff = maxc - (int) dc; + + SLsmg_gotorc (r, c); + SLsmg_write_nchars (s, dc); + if (fill && (diff > 0)) + { + while (diff--) SLsmg_write_char (' '); + } + if ((ch == 0) || (dr == 1)) break; + + r++; + dc = 0; + dr--; + s = p; + } + else if ((int) dc == maxc) + { + SLsmg_gotorc (r, c); + SLsmg_write_nchars (s, dc + 1); + if (dr == 1) break; + + r++; + dc = 0; + dr--; + s = p; + } + else dc++; + } +} + +int SLsmg_Tab_Width = 8; + +/* Minimum value for which eight bit char is displayed as is. */ + +#ifndef IBMPC_SYSTEM +int SLsmg_Display_Eight_Bit = 160; +static unsigned char Alt_Char_Set[129];/* 129th is used as a flag */ +#else +int SLsmg_Display_Eight_Bit = 128; +#endif + +void SLsmg_write_nchars (char *str, unsigned int n) +{ + register SLsmg_Char_Type *p, old, neew, color; + unsigned char ch; + unsigned int flags; + int len, start_len, max_len; + char *str_max; + int newline_flag; +#ifndef IBMPC_SYSTEM + int alt_char_set_flag; + + alt_char_set_flag = ((This_Color & ALT_CHAR_FLAG) + && ((tt_Use_Blink_For_ACS == NULL) + || (*tt_Use_Blink_For_ACS == 0))); +#endif + + if (Smg_Inited == 0) return; + + str_max = str + n; + color = This_Color; + + top: /* get here only on newline */ + + newline_flag = 0; + start_len = Start_Col; + + if (point_visible (0) == 0) return; + + len = This_Col; + max_len = start_len + Screen_Cols; + + p = SL_Screen[This_Row - Start_Row].neew; + if (len > start_len) p += (len - start_len); + + flags = SL_Screen[This_Row - Start_Row].flags; + while ((len < max_len) && (str < str_max)) + { + ch = (unsigned char) *str++; + +#ifndef IBMPC_SYSTEM + if (alt_char_set_flag) + ch = Alt_Char_Set [ch & 0x7F]; +#endif + if (((ch >= ' ') && (ch < 127)) + || (ch >= (unsigned char) SLsmg_Display_Eight_Bit) +#ifndef IBMPC_SYSTEM + || alt_char_set_flag +#endif + ) + { + len += 1; + if (len > start_len) + { + old = *p; + neew = SLSMG_BUILD_CHAR(ch,color); + if (old != neew) + { + flags |= TOUCHED; + *p = neew; + } + p++; + } + } + + else if ((ch == '\t') && (SLsmg_Tab_Width > 0)) + { + n = len; + n += SLsmg_Tab_Width; + n = SLsmg_Tab_Width - (n % SLsmg_Tab_Width); + if ((unsigned int) len + n > (unsigned int) max_len) + n = (unsigned int) (max_len - len); + neew = SLSMG_BUILD_CHAR(' ',color); + while (n--) + { + len += 1; + if (len > start_len) + { + if (*p != neew) + { + flags |= TOUCHED; + *p = neew; + } + p++; + } + } + } + else if ((ch == '\n') + && (SLsmg_Newline_Behavior != SLSMG_NEWLINE_PRINTABLE)) + { + newline_flag = 1; + break; + } + else if ((ch == 0x8) && SLsmg_Backspace_Moves) + { + if (len != 0) len--; + } + else + { + if (ch & 0x80) + { + neew = SLSMG_BUILD_CHAR('~',color); + len += 1; + if (len > start_len) + { + if (*p != neew) + { + *p = neew; + flags |= TOUCHED; + } + p++; + if (len == max_len) break; + ch &= 0x7F; + } + } + + len += 1; + if (len > start_len) + { + neew = SLSMG_BUILD_CHAR('^',color); + if (*p != neew) + { + *p = neew; + flags |= TOUCHED; + } + p++; + if (len == max_len) break; + } + + if (ch == 127) ch = '?'; else ch = ch + '@'; + len++; + if (len > start_len) + { + neew = SLSMG_BUILD_CHAR(ch,color); + if (*p != neew) + { + *p = neew; + flags |= TOUCHED; + } + p++; + } + } + } + + SL_Screen[This_Row - Start_Row].flags = flags; + This_Col = len; + + if (SLsmg_Newline_Behavior == 0) + return; + + if (newline_flag == 0) + { + while (str < str_max) + { + if (*str == '\n') break; + str++; + } + if (str == str_max) return; + str++; + } + + This_Row++; + This_Col = 0; + if (This_Row == Start_Row + Screen_Rows) + { + if (SLsmg_Newline_Behavior == SLSMG_NEWLINE_SCROLLS) scroll_up (); + } + goto top; +} + +void SLsmg_write_char (char ch) +{ + SLsmg_write_nchars (&ch, 1); +} + +static int Cls_Flag; + +void SLsmg_cls (void) +{ + int tac; + if (Smg_Inited == 0) return; + + tac = This_Alt_Char; This_Alt_Char = 0; + SLsmg_set_color (0); + clear_region (0, Screen_Rows, ' '); + This_Alt_Char = tac; + SLsmg_set_color (0); + Cls_Flag = 1; +} +#if 0 +static void do_copy (SLsmg_Char_Type *a, SLsmg_Char_Type *b) +{ + SLsmg_Char_Type *amax = a + Screen_Cols; + + while (a < amax) *a++ = *b++; +} +#endif + +#ifndef IBMPC_SYSTEM +int SLsmg_Scroll_Hash_Border = 0; +static unsigned long compute_hash (SLsmg_Char_Type *s, int n) +{ + register unsigned long h = 0, g; + register unsigned long sum = 0; + register SLsmg_Char_Type *smax, ch; + int is_blank = 2; + + s += SLsmg_Scroll_Hash_Border; + smax = s + (n - SLsmg_Scroll_Hash_Border); + while (s < smax) + { + ch = *s++; + if (is_blank && (SLSMG_EXTRACT_CHAR(ch) != 32)) is_blank--; + + sum += ch; + + h = sum + (h << 3); + if ((g = h & 0xE0000000UL) != 0) + { + h = h ^ (g >> 24); + h = h ^ g; + } + } + if (is_blank) return 0; + return h; +} + +static unsigned long Blank_Hash; + +static int try_scroll_down (int rmin, int rmax) +{ + int i, r1, r2, di, j; + unsigned long hash; + int did_scroll; + int color; + SLsmg_Char_Type *tmp; + int ignore; + + did_scroll = 0; + for (i = rmax; i > rmin; i--) + { + hash = SL_Screen[i].new_hash; + if (hash == Blank_Hash) continue; + + if ((hash == SL_Screen[i].old_hash) +#if 0 + || ((i + 1 < Screen_Rows) && (hash == SL_Screen[i + 1].old_hash)) + || ((i - 1 > rmin) && (SL_Screen[i].old_hash == SL_Screen[i - 1].new_hash)) +#endif + ) + continue; + + for (j = i - 1; j >= rmin; j--) + { + if (hash == SL_Screen[j].old_hash) break; + } + if (j < rmin) continue; + + r2 = i; /* end scroll region */ + + di = i - j; + j--; + ignore = 0; + while ((j >= rmin) && (SL_Screen[j].old_hash == SL_Screen[j + di].new_hash)) + { + if (SL_Screen[j].old_hash == Blank_Hash) ignore++; + j--; + } + r1 = j + 1; + + /* If this scroll only scrolls this line into place, don't do it. + */ + if ((di > 1) && (r1 + di + ignore == r2)) continue; + + /* If there is anything in the scrolling region that is ok, abort the + * scroll. + */ + + for (j = r1; j <= r2; j++) + { + if ((SL_Screen[j].old_hash != Blank_Hash) + && (SL_Screen[j].old_hash == SL_Screen[j].new_hash)) + { + /* See if the scroll is happens to scroll this one into place. */ + if ((j + di > r2) || (SL_Screen[j].old_hash != SL_Screen[j + di].new_hash)) + break; + } + } + if (j <= r2) continue; + + color = This_Color; This_Color = 0; + did_scroll = 1; + (*tt_normal_video) (); + (*tt_set_scroll_region) (r1, r2); + (*tt_goto_rc) (0, 0); + (*tt_reverse_index) (di); + (*tt_reset_scroll_region) (); + /* Now we have a hole in the screen. + * Make the virtual screen look like it. + * + * Note that if the terminal does not support BCE, then we have + * no idea what color the hole is. So, for this case, we do not + * want to add Bce_Color_Offset to This_Color since if Bce_Color_Offset + * is non-zero, then This_Color = 0 does not match any valid color + * obtained by adding Bce_Color_Offset. + */ + for (j = r1; j <= r2; j++) SL_Screen[j].flags = TOUCHED; + + while (di--) + { + tmp = SL_Screen[r2].old; + for (j = r2; j > r1; j--) + { + SL_Screen[j].old = SL_Screen[j - 1].old; + SL_Screen[j].old_hash = SL_Screen[j - 1].old_hash; + } + SL_Screen[r1].old = tmp; + blank_line (SL_Screen[r1].old, Screen_Cols, ' '); + SL_Screen[r1].old_hash = Blank_Hash; + r1++; + } + This_Color = color; + } + + return did_scroll; +} + +static int try_scroll_up (int rmin, int rmax) +{ + int i, r1, r2, di, j; + unsigned long hash; + int did_scroll; + int color; + SLsmg_Char_Type *tmp; + int ignore; + + did_scroll = 0; + for (i = rmin; i < rmax; i++) + { + hash = SL_Screen[i].new_hash; + if (hash == Blank_Hash) continue; + if (hash == SL_Screen[i].old_hash) + continue; + /* find a match further down screen */ + for (j = i + 1; j <= rmax; j++) + { + if (hash == SL_Screen[j].old_hash) break; + } + if (j > rmax) continue; + + r1 = i; /* beg scroll region */ + di = j - i; /* number of lines to scroll */ + j++; /* since we know this is a match */ + + /* find end of scroll region */ + ignore = 0; + while ((j <= rmax) && (SL_Screen[j].old_hash == SL_Screen[j - di].new_hash)) + { + if (SL_Screen[j].old_hash == Blank_Hash) ignore++; + j++; + } + r2 = j - 1; /* end of scroll region */ + + /* If this scroll only scrolls this line into place, don't do it. + */ + if ((di > 1) && (r1 + di + ignore == r2)) continue; + + /* If there is anything in the scrolling region that is ok, abort the + * scroll. + */ + + for (j = r1; j <= r2; j++) + { + if ((SL_Screen[j].old_hash != Blank_Hash) + && (SL_Screen[j].old_hash == SL_Screen[j].new_hash)) + { + if ((j - di < r1) || (SL_Screen[j].old_hash != SL_Screen[j - di].new_hash)) + break; + } + + } + if (j <= r2) continue; + + did_scroll = 1; + + /* See the above comments about BCE */ + color = This_Color; This_Color = 0; + (*tt_normal_video) (); + (*tt_set_scroll_region) (r1, r2); + (*tt_goto_rc) (0, 0); /* relative to scroll region */ + (*tt_delete_nlines) (di); + (*tt_reset_scroll_region) (); + /* Now we have a hole in the screen. Make the virtual screen look + * like it. + */ + for (j = r1; j <= r2; j++) SL_Screen[j].flags = TOUCHED; + + while (di--) + { + tmp = SL_Screen[r1].old; + for (j = r1; j < r2; j++) + { + SL_Screen[j].old = SL_Screen[j + 1].old; + SL_Screen[j].old_hash = SL_Screen[j + 1].old_hash; + } + SL_Screen[r2].old = tmp; + blank_line (SL_Screen[r2].old, Screen_Cols, ' '); + SL_Screen[r2].old_hash = Blank_Hash; + r2--; + } + This_Color = color; + } + return did_scroll; +} + +static void try_scroll (void) +{ + int r1, rmin, rmax; + int num_up, num_down; + /* find region limits. */ + + for (rmax = Screen_Rows - 1; rmax > 0; rmax--) + { + if (SL_Screen[rmax].new_hash != SL_Screen[rmax].old_hash) + { + r1 = rmax - 1; + if ((r1 == 0) + || (SL_Screen[r1].new_hash != SL_Screen[r1].old_hash)) + break; + + rmax = r1; + } + } + + for (rmin = 0; rmin < rmax; rmin++) + { + if (SL_Screen[rmin].new_hash != SL_Screen[rmin].old_hash) + { + r1 = rmin + 1; + if ((r1 == rmax) + || (SL_Screen[r1].new_hash != SL_Screen[r1].old_hash)) + break; + + rmin = r1; + } + } + + /* Below, we have two scrolling algorithms. The first has the effect of + * scrolling lines down. This is usually appropriate when one moves + * up the display, e.g., with the UP arrow. The second algorithm is + * appropriate for going the other way. It is important to choose the + * correct one. + */ + + num_up = 0; + for (r1 = rmin; r1 < rmax; r1++) + { + if (SL_Screen[r1].new_hash == SL_Screen[r1 + 1].old_hash) + num_up++; + } + + num_down = 0; + for (r1 = rmax; r1 > rmin; r1--) + { + if (SL_Screen[r1 - 1].old_hash == SL_Screen[r1].new_hash) + num_down++; + } + + if (num_up > num_down) + { + if (try_scroll_up (rmin, rmax)) + return; + + (void) try_scroll_down (rmin, rmax); + } + else + { + if (try_scroll_down (rmin, rmax)) + return; + + (void) try_scroll_up (rmin, rmax); + } +} +#endif /* NOT IBMPC_SYSTEM */ + + +#ifdef REQUIRES_NON_BCE_SUPPORT +static void adjust_colors (void) +{ + int bce; + int i; + + bce = Bce_Color_Offset; + Bce_Color_Offset = _SLtt_get_bce_color_offset (); + if (bce == Bce_Color_Offset) + return; + + if ((tt_Use_Blink_For_ACS != NULL) + && (*tt_Use_Blink_For_ACS != 0)) + return; /* this mode does not support non-BCE + * terminals. + */ + + for (i = 0; i < Screen_Rows; i++) + { + SLsmg_Char_Type *s, *smax; + + SL_Screen[i].flags |= TRASHED; + s = SL_Screen[i].neew; + smax = s + Screen_Cols; + + while (s < smax) + { + int color = (int) SLSMG_EXTRACT_COLOR(*s); + int acs; + + if (color < 0) + { + s++; + continue; + } + + acs = color & 0x80; + color = (color & 0x7F) - bce; + color += Bce_Color_Offset; + if (color >= 0) + { + unsigned char ch = SLSMG_EXTRACT_CHAR(*s); + *s = SLSMG_BUILD_CHAR(ch, ((color&0x7F)|acs)); + } + s++; + } + } +} +#endif + +void SLsmg_refresh (void) +{ + int i; +#ifndef IBMPC_SYSTEM + int trashed = 0; +#endif + + if (Smg_Inited == 0) return; + + if (Screen_Trashed) + { + Cls_Flag = 1; + for (i = 0; i < Screen_Rows; i++) + SL_Screen[i].flags |= TRASHED; +#ifdef REQUIRES_NON_BCE_SUPPORT + adjust_colors (); +#endif + } + +#ifndef IBMPC_SYSTEM + for (i = 0; i < Screen_Rows; i++) + { + if (SL_Screen[i].flags == 0) continue; + SL_Screen[i].new_hash = compute_hash (SL_Screen[i].neew, Screen_Cols); + trashed = 1; + } +#endif + + if (Cls_Flag) + { + (*tt_normal_video) (); (*tt_cls) (); + } +#ifndef IBMPC_SYSTEM + else if (trashed && (*tt_Term_Cannot_Scroll == 0)) try_scroll (); +#endif + + for (i = 0; i < Screen_Rows; i++) + { + if (SL_Screen[i].flags == 0) continue; + + if (Cls_Flag || SL_Screen[i].flags & TRASHED) + { + int color = This_Color; + + if (Cls_Flag == 0) + { + (*tt_goto_rc) (i, 0); + (*tt_del_eol) (); + } + This_Color = 0; + blank_line (SL_Screen[i].old, Screen_Cols, ' '); + This_Color = color; + } + + SL_Screen[i].old[Screen_Cols] = 0; + SL_Screen[i].neew[Screen_Cols] = 0; + + (*tt_smart_puts) (SL_Screen[i].neew, SL_Screen[i].old, Screen_Cols, i); + + SLMEMCPY ((char *) SL_Screen[i].old, (char *) SL_Screen[i].neew, + Screen_Cols * sizeof (SLsmg_Char_Type)); + + SL_Screen[i].flags = 0; +#ifndef IBMPC_SYSTEM + SL_Screen[i].old_hash = SL_Screen[i].new_hash; +#endif + } + + if (point_visible (1)) (*tt_goto_rc) (This_Row - Start_Row, This_Col - Start_Col); + (*tt_flush_output) (); + Cls_Flag = 0; + Screen_Trashed = 0; +} + +static int compute_clip (int row, int n, int box_start, int box_end, + int *rmin, int *rmax) +{ + int row_max; + + if (n < 0) return 0; + if (row >= box_end) return 0; + row_max = row + n; + if (row_max <= box_start) return 0; + + if (row < box_start) row = box_start; + if (row_max >= box_end) row_max = box_end; + *rmin = row; + *rmax = row_max; + return 1; +} + +void SLsmg_touch_lines (int row, unsigned int n) +{ + int i; + int r1, r2; + + /* Allow this function to be called even when we are not initialied. + * Calling this function is useful after calling SLtt_set_color + * to force the display to be redrawn + */ + + if (Smg_Inited == 0) + return; + + if (0 == compute_clip (row, (int) n, Start_Row, Start_Row + Screen_Rows, &r1, &r2)) + return; + + r1 -= Start_Row; + r2 -= Start_Row; + for (i = r1; i < r2; i++) + { + SL_Screen[i].flags |= TRASHED; + } +} + +void SLsmg_touch_screen (void) +{ + Screen_Trashed = 1; +} + + +#ifndef IBMPC_SYSTEM +static SLCONST char Fake_Alt_Char_Pairs [] = "a:j+k+l+m+q-t+u+v+w+x|n+`+f\\g#~o,<+>.v-^h#0#"; + +static void init_alt_char_set (void) +{ + int i; + unsigned SLCONST char *p, *pmax; + unsigned char ch; + + if (Alt_Char_Set[128] == 128) return; + + i = 32; + memset ((char *)Alt_Char_Set, ' ', i); + while (i <= 128) + { + Alt_Char_Set [i] = i; + i++; + } + + /* Map to VT100 */ + if (*tt_Has_Alt_Charset) + { + if (tt_Graphics_Char_Pairs == NULL) p = NULL; + else p = (unsigned char *) *tt_Graphics_Char_Pairs; + if (p == NULL) return; + } + else p = (unsigned SLCONST char *) Fake_Alt_Char_Pairs; + pmax = p + strlen ((SLCONST char *) p); + + /* Some systems have messed up entries for this */ + while (p < pmax) + { + ch = *p++; + ch &= 0x7F; /* should be unnecessary */ + Alt_Char_Set [ch] = *p; + p++; + } +} +#endif + +#ifndef IBMPC_SYSTEM +# define BLOCK_SIGNALS SLsig_block_signals () +# define UNBLOCK_SIGNALS SLsig_unblock_signals () +#else +# define BLOCK_SIGNALS (void)0 +# define UNBLOCK_SIGNALS (void)0 +#endif + +static int Smg_Suspended; +int SLsmg_suspend_smg (void) +{ + BLOCK_SIGNALS; + + if (Smg_Suspended == 0) + { + (*tt_reset_video) (); + Smg_Suspended = 1; + } + + UNBLOCK_SIGNALS; + return 0; +} + +int SLsmg_resume_smg (void) +{ + BLOCK_SIGNALS; + + if (Smg_Suspended == 0) + { + UNBLOCK_SIGNALS; + return 0; + } + + Smg_Suspended = 0; + + if (-1 == (*tt_init_video) ()) + { + UNBLOCK_SIGNALS; + return -1; + } + + Cls_Flag = 1; + SLsmg_touch_screen (); + SLsmg_refresh (); + + UNBLOCK_SIGNALS; + return 0; +} + + +static void reset_smg (void) +{ + int i; + if (Smg_Inited == 0) + return; + + for (i = 0; i < Screen_Rows; i++) + { + SLfree ((char *)SL_Screen[i].old); + SLfree ((char *)SL_Screen[i].neew); + SL_Screen[i].old = SL_Screen[i].neew = NULL; + } + This_Alt_Char = This_Color = 0; + Smg_Inited = 0; +} + + +static int init_smg (void) +{ + int i, len; + SLsmg_Char_Type *old, *neew; + + Smg_Inited = 0; + +#ifdef REQUIRES_NON_BCE_SUPPORT + Bce_Color_Offset = _SLtt_get_bce_color_offset (); +#endif + + Screen_Rows = *tt_Screen_Rows; + if (Screen_Rows > SLTT_MAX_SCREEN_ROWS) + Screen_Rows = SLTT_MAX_SCREEN_ROWS; + + Screen_Cols = *tt_Screen_Cols; + + This_Col = This_Row = Start_Col = Start_Row = 0; + + This_Alt_Char = 0; + SLsmg_set_color (0); + Cls_Flag = 1; +#ifndef IBMPC_SYSTEM + init_alt_char_set (); +#endif + len = Screen_Cols + 3; + for (i = 0; i < Screen_Rows; i++) + { + if ((NULL == (old = (SLsmg_Char_Type *) SLmalloc (sizeof(SLsmg_Char_Type) * len))) + || ((NULL == (neew = (SLsmg_Char_Type *) SLmalloc (sizeof(SLsmg_Char_Type) * len))))) + { + SLfree ((char *) old); + return -1; + } + blank_line (old, len, ' '); + blank_line (neew, len, ' '); + SL_Screen[i].old = old; + SL_Screen[i].neew = neew; + SL_Screen[i].flags = 0; +#ifndef IBMPC_SYSTEM + Blank_Hash = compute_hash (old, Screen_Cols); + SL_Screen[i].new_hash = SL_Screen[i].old_hash = Blank_Hash; +#endif + } + + _SLtt_color_changed_hook = SLsmg_touch_screen; + Screen_Trashed = 1; + Smg_Inited = 1; + return 0; +} + + +int SLsmg_init_smg (void) +{ + int ret; + + BLOCK_SIGNALS; + + if (Smg_Inited) + SLsmg_reset_smg (); + + if (-1 == (*tt_init_video) ()) + { + UNBLOCK_SIGNALS; + return -1; + } + + if (-1 == (ret = init_smg ())) + (void) (*tt_reset_video)(); + + UNBLOCK_SIGNALS; + return ret; +} + +int SLsmg_reinit_smg (void) +{ + int ret; + + if (Smg_Inited == 0) + return SLsmg_init_smg (); + + BLOCK_SIGNALS; + reset_smg (); + ret = init_smg (); + UNBLOCK_SIGNALS; + return ret; +} + +void SLsmg_reset_smg (void) +{ + if (Smg_Inited == 0) + return; + + BLOCK_SIGNALS; + + reset_smg (); + (*tt_reset_video)(); + + UNBLOCK_SIGNALS; +} + +SLsmg_Char_Type SLsmg_char_at (void) +{ + if (Smg_Inited == 0) return 0; + + if (point_visible (1)) + { + return SL_Screen[This_Row - Start_Row].neew[This_Col - Start_Col]; + } + return 0; +} + +void SLsmg_vprintf (char *fmt, va_list ap) +{ + char buf[1024]; + + if (Smg_Inited == 0) return; + + (void) _SLvsnprintf (buf, sizeof (buf), fmt, ap); + SLsmg_write_string (buf); +} + +void SLsmg_printf (char *fmt, ...) +{ + va_list ap; + unsigned int len; + char *f; + + if (Smg_Inited == 0) return; + + va_start(ap, fmt); + + f = fmt; + while (*f && (*f != '%')) + f++; + len = (unsigned int) (f - fmt); + if (len) SLsmg_write_nchars (fmt, len); + + if (*f != 0) + SLsmg_vprintf (f, ap); + + va_end (ap); +} + +void SLsmg_set_screen_start (int *r, int *c) +{ + int orow = Start_Row, oc = Start_Col; + + if (Smg_Inited == 0) return; + + if (c == NULL) Start_Col = 0; + else + { + Start_Col = *c; + *c = oc; + } + if (r == NULL) Start_Row = 0; + else + { + Start_Row = *r; + *r = orow; + } +} + +void SLsmg_draw_object (int r, int c, unsigned char object) +{ + This_Row = r; This_Col = c; + + if (Smg_Inited == 0) return; + + if (point_visible (1)) + { + int color = This_Color; + This_Color |= ALT_CHAR_FLAG; + SLsmg_write_char (object); + This_Color = color; + } + + This_Col = c + 1; +} + +void SLsmg_draw_hline (unsigned int n) +{ + static unsigned char hbuf[16]; + int count; + int cmin, cmax; + int final_col = This_Col + (int) n; + int save_color; + + if (Smg_Inited == 0) return; + + if ((This_Row < Start_Row) || (This_Row >= Start_Row + Screen_Rows) + || (0 == compute_clip (This_Col, n, Start_Col, Start_Col + Screen_Cols, + &cmin, &cmax))) + { + This_Col = final_col; + return; + } + + if (hbuf[0] == 0) + { + SLMEMSET ((char *) hbuf, SLSMG_HLINE_CHAR, 16); + } + + n = (unsigned int)(cmax - cmin); + count = n / 16; + + save_color = This_Color; + This_Color |= ALT_CHAR_FLAG; + This_Col = cmin; + + SLsmg_write_nchars ((char *) hbuf, n % 16); + while (count-- > 0) + { + SLsmg_write_nchars ((char *) hbuf, 16); + } + + This_Color = save_color; + This_Col = final_col; +} + +void SLsmg_draw_vline (int n) +{ + unsigned char ch = SLSMG_VLINE_CHAR; + int c = This_Col, rmin, rmax; + int final_row = This_Row + n; + int save_color; + + if (Smg_Inited == 0) return; + + if (((c < Start_Col) || (c >= Start_Col + Screen_Cols)) || + (0 == compute_clip (This_Row, n, Start_Row, Start_Row + Screen_Rows, + &rmin, &rmax))) + { + This_Row = final_row; + return; + } + + save_color = This_Color; + This_Color |= ALT_CHAR_FLAG; + + for (This_Row = rmin; This_Row < rmax; This_Row++) + { + This_Col = c; + SLsmg_write_nchars ((char *) &ch, 1); + } + + This_Col = c; This_Row = final_row; + This_Color = save_color; +} + +void SLsmg_draw_box (int r, int c, unsigned int dr, unsigned int dc) +{ + if (Smg_Inited == 0) return; + + if (!dr || !dc) return; + This_Row = r; This_Col = c; + dr--; dc--; + SLsmg_draw_hline (dc); + SLsmg_draw_vline (dr); + This_Row = r; This_Col = c; + SLsmg_draw_vline (dr); + SLsmg_draw_hline (dc); + SLsmg_draw_object (r, c, SLSMG_ULCORN_CHAR); + SLsmg_draw_object (r, c + (int) dc, SLSMG_URCORN_CHAR); + SLsmg_draw_object (r + (int) dr, c, SLSMG_LLCORN_CHAR); + SLsmg_draw_object (r + (int) dr, c + (int) dc, SLSMG_LRCORN_CHAR); + This_Row = r; This_Col = c; +} + +void SLsmg_fill_region (int r, int c, unsigned int dr, unsigned int dc, unsigned char ch) +{ + static unsigned char hbuf[16]; + int count; + int dcmax, rmax; + + if (Smg_Inited == 0) return; + + SLsmg_gotorc (r, c); + r = This_Row; c = This_Col; + + dcmax = Screen_Cols - This_Col; + if (dcmax < 0) + return; + + if (dc > (unsigned int) dcmax) dc = (unsigned int) dcmax; + + rmax = This_Row + dr; + if (rmax > Screen_Rows) rmax = Screen_Rows; + +#if 0 + ch = Alt_Char_Set[ch]; +#endif + if (ch != hbuf[0]) SLMEMSET ((char *) hbuf, (char) ch, 16); + + for (This_Row = r; This_Row < rmax; This_Row++) + { + This_Col = c; + count = dc / 16; + SLsmg_write_nchars ((char *) hbuf, dc % 16); + while (count-- > 0) + { + SLsmg_write_nchars ((char *) hbuf, 16); + } + } + + This_Row = r; +} + +void SLsmg_forward (int n) +{ + This_Col += n; +} + +void SLsmg_write_color_chars (SLsmg_Char_Type *s, unsigned int len) +{ + SLsmg_Char_Type *smax, sh; + char buf[32], *b, *bmax; + int color, save_color; + + if (Smg_Inited == 0) return; + + smax = s + len; + b = buf; + bmax = b + sizeof (buf); + + save_color = This_Color; + + while (s < smax) + { + sh = *s++; + + color = SLSMG_EXTRACT_COLOR(sh); + +#if REQUIRES_NON_BCE_SUPPORT + if (Bce_Color_Offset) + { + if (color & 0x80) + color = ((color & 0x7F) + Bce_Color_Offset) | 0x80; + else + color = ((color & 0x7F) + Bce_Color_Offset) & 0x7F; + } +#endif + + if ((color != This_Color) || (b == bmax)) + { + if (b != buf) + { + SLsmg_write_nchars (buf, (int) (b - buf)); + b = buf; + } + This_Color = color; + } + *b++ = (char) SLSMG_EXTRACT_CHAR(sh); + } + + if (b != buf) + SLsmg_write_nchars (buf, (unsigned int) (b - buf)); + + This_Color = save_color; +} + +unsigned int SLsmg_read_raw (SLsmg_Char_Type *buf, unsigned int len) +{ + unsigned int r, c; + + if (Smg_Inited == 0) return 0; + + if (0 == point_visible (1)) return 0; + + r = (unsigned int) (This_Row - Start_Row); + c = (unsigned int) (This_Col - Start_Col); + + if (c + len > (unsigned int) Screen_Cols) + len = (unsigned int) Screen_Cols - c; + + memcpy ((char *) buf, (char *) (SL_Screen[r].neew + c), len * sizeof (SLsmg_Char_Type)); + return len; +} + +unsigned int SLsmg_write_raw (SLsmg_Char_Type *buf, unsigned int len) +{ + unsigned int r, c; + SLsmg_Char_Type *dest; + + if (Smg_Inited == 0) return 0; + + if (0 == point_visible (1)) return 0; + + r = (unsigned int) (This_Row - Start_Row); + c = (unsigned int) (This_Col - Start_Col); + + if (c + len > (unsigned int) Screen_Cols) + len = (unsigned int) Screen_Cols - c; + + dest = SL_Screen[r].neew + c; + + if (0 != memcmp ((char *) dest, (char *) buf, len * sizeof (SLsmg_Char_Type))) + { + memcpy ((char *) dest, (char *) buf, len * sizeof (SLsmg_Char_Type)); + SL_Screen[r].flags |= TOUCHED; + } + return len; +} + +void +SLsmg_set_color_in_region (int color, int r, int c, unsigned int dr, unsigned int dc) +{ + int cmax, rmax; + SLsmg_Char_Type char_mask; + + if (Smg_Inited == 0) return; + + c -= Start_Col; + r -= Start_Row; + + cmax = c + (int) dc; + rmax = r + (int) dr; + + if (cmax > Screen_Cols) cmax = Screen_Cols; + if (rmax > Screen_Rows) rmax = Screen_Rows; + + if (c < 0) c = 0; + if (r < 0) r = 0; + +#if REQUIRES_NON_BCE_SUPPORT + if (Bce_Color_Offset) + { + if (color & 0x80) + color = ((color & 0x7F) + Bce_Color_Offset) | 0x80; + else + color = ((color & 0x7F) + Bce_Color_Offset) & 0x7F; + } +#endif + color = color << 8; + + char_mask = 0xFF; + +#ifndef IBMPC_SYSTEM + if ((tt_Use_Blink_For_ACS == NULL) + || (0 == *tt_Use_Blink_For_ACS)) + char_mask = 0x80FF; +#endif + + while (r < rmax) + { + SLsmg_Char_Type *s, *smax; + + SL_Screen[r].flags |= TOUCHED; + s = SL_Screen[r].neew; + smax = s + cmax; + s += c; + + while (s < smax) + { + *s = (*s & char_mask) | color; + s++; + } + r++; + } +} + +void SLsmg_set_terminal_info (SLsmg_Term_Type *tt) +{ + if (tt == NULL) /* use default */ + return; + + if ((tt->tt_normal_video == NULL) + || (tt->tt_goto_rc == NULL) + || (tt->tt_cls == NULL) + || (tt->tt_del_eol == NULL) + || (tt->tt_smart_puts == NULL) + || (tt->tt_flush_output == NULL) + || (tt->tt_reset_video == NULL) + || (tt->tt_init_video == NULL) +#ifndef IBMPC_SYSTEM + || (tt->tt_set_scroll_region == NULL) + || (tt->tt_reverse_index == NULL) + || (tt->tt_reset_scroll_region == NULL) + || (tt->tt_delete_nlines == NULL) + /* Variables */ + || (tt->tt_term_cannot_scroll == NULL) + || (tt->tt_has_alt_charset == NULL) +#if 0 /* These can be NULL */ + || (tt->tt_use_blink_for_acs == NULL) + || (tt->tt_graphic_char_pairs == NULL) +#endif + || (tt->tt_screen_cols == NULL) + || (tt->tt_screen_rows == NULL) +#endif + ) + SLang_exit_error ("Terminal not powerful enough for SLsmg"); + + tt_normal_video = tt->tt_normal_video; + tt_goto_rc = tt->tt_goto_rc; + tt_cls = tt->tt_cls; + tt_del_eol = tt->tt_del_eol; + tt_smart_puts = tt->tt_smart_puts; + tt_flush_output = tt->tt_flush_output; + tt_reset_video = tt->tt_reset_video; + tt_init_video = tt->tt_init_video; + +#ifndef IBMPC_SYSTEM + tt_set_scroll_region = tt->tt_set_scroll_region; + tt_reverse_index = tt->tt_reverse_index; + tt_reset_scroll_region = tt->tt_reset_scroll_region; + tt_delete_nlines = tt->tt_delete_nlines; + + tt_Term_Cannot_Scroll = tt->tt_term_cannot_scroll; + tt_Has_Alt_Charset = tt->tt_has_alt_charset; + tt_Use_Blink_For_ACS = tt->tt_use_blink_for_acs; + tt_Graphics_Char_Pairs = tt->tt_graphic_char_pairs; +#endif + + tt_Screen_Cols = tt->tt_screen_cols; + tt_Screen_Rows = tt->tt_screen_rows; +} + diff --git a/libslang/src/slstd.c b/libslang/src/slstd.c new file mode 100644 index 0000000..bf2c268 --- /dev/null +++ b/libslang/src/slstd.c @@ -0,0 +1,809 @@ +/* -*- mode: C; mode: fold; -*- */ +/* Standard intrinsic functions for S-Lang. Included here are string + and array operations */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" +/*{{{ Include Files */ + +#include + +#ifndef __QNX__ +# if defined(__GO32__) || defined(__WATCOMC__) +# include +# include +# endif +#endif + +#if SLANG_HAS_FLOAT +# include +#endif + +#include "slang.h" +#include "_slang.h" + +/*}}}*/ + +/* builtin stack manipulation functions */ +int SLdo_pop(void) /*{{{*/ +{ + return SLdo_pop_n (1); +} + +/*}}}*/ + +int SLdo_pop_n (unsigned int n) +{ + SLang_Object_Type x; + + while (n--) + { + if (SLang_pop(&x)) return -1; + SLang_free_object (&x); + } + + return 0; +} + +static void do_dup(void) /*{{{*/ +{ + (void) SLdup_n (1); +} + +/*}}}*/ + +static int length_cmd (void) +{ + SLang_Class_Type *cl; + SLang_Object_Type obj; + VOID_STAR p; + unsigned int length; + int len; + + if (-1 == SLang_pop (&obj)) + return -1; + + cl = _SLclass_get_class (obj.data_type); + p = _SLclass_get_ptr_to_value (cl, &obj); + + len = 1; + if (cl->cl_length != NULL) + { + if (0 == (*cl->cl_length)(obj.data_type, p, &length)) + len = (int) length; + else + len = -1; + } + + SLang_free_object (&obj); + return len; +} + +/* convert integer to a string of length 1 */ +static void char_cmd (int *x) /*{{{*/ +{ + char ch, buf[2]; + + ch = (char) *x; + buf[0] = ch; + buf[1] = 0; + SLang_push_string (buf); +} + +/*}}}*/ + +/* format object into a string and returns slstring */ +char *_SLstringize_object (SLang_Object_Type *obj) /*{{{*/ +{ + SLang_Class_Type *cl; + unsigned char stype; + VOID_STAR p; + char *s, *s1; + + stype = obj->data_type; + p = (VOID_STAR) &obj->v.ptr_val; + + cl = _SLclass_get_class (stype); + + s = (*cl->cl_string) (stype, p); + if (s != NULL) + { + s1 = SLang_create_slstring (s); + SLfree (s); + s = s1; + } + return s; +} +/*}}}*/ + +int SLang_run_hooks(char *hook, unsigned int num_args, ...) +{ + unsigned int i; + va_list ap; + + if (SLang_Error) return -1; + + if (0 == SLang_is_defined (hook)) + return 0; + + (void) SLang_start_arg_list (); + va_start (ap, num_args); + for (i = 0; i < num_args; i++) + { + char *arg; + + arg = va_arg (ap, char *); + if (-1 == SLang_push_string (arg)) + break; + } + va_end (ap); + (void) SLang_end_arg_list (); + + if (SLang_Error) return -1; + return SLang_execute_function (hook); +} + +static void intrin_getenv_cmd (char *s) +{ + SLang_push_string (getenv (s)); +} + +#ifdef HAVE_PUTENV +static void intrin_putenv (void) /*{{{*/ +{ + char *s; + + /* Some putenv implementations required malloced strings. */ + if (SLpop_string(&s)) return; + + if (putenv (s)) + { + SLang_Error = SL_INTRINSIC_ERROR; + SLfree (s); + } + + /* Note that s is NOT freed */ +} + +/*}}}*/ + +#endif + +static void byte_compile_file (char *f, int *m) +{ + SLang_byte_compile_file (f, *m); +} + +static void intrin_type_info1 (void) +{ + SLang_Object_Type obj; + unsigned int type; + + if (-1 == SLang_pop (&obj)) + return; + + type = obj.data_type; + if (type == SLANG_ARRAY_TYPE) + type = obj.v.array_val->data_type; + + SLang_free_object (&obj); + + SLang_push_datatype (type); +} + +static void intrin_type_info (void) +{ + SLang_Object_Type obj; + + if (-1 == SLang_pop (&obj)) + return; + + SLang_push_datatype (obj.data_type); + SLang_free_object (&obj); +} + +void _SLstring_intrinsic (void) /*{{{*/ +{ + SLang_Object_Type x; + char *s; + + if (SLang_pop (&x)) return; + if (NULL != (s = _SLstringize_object (&x))) + _SLang_push_slstring (s); + + SLang_free_object (&x); +} + +/*}}}*/ + +static void intrin_typecast (void) +{ + unsigned char to_type; + if (0 == SLang_pop_datatype (&to_type)) + (void) SLclass_typecast (to_type, 0, 1); +} + +#if SLANG_HAS_FLOAT +static void intrin_double (void) +{ + (void) SLclass_typecast (SLANG_DOUBLE_TYPE, 0, 1); +} + +#endif + +static void intrin_int (void) /*{{{*/ +{ + (void) SLclass_typecast (SLANG_INT_TYPE, 0, 1); +} + +/*}}}*/ + +static char * +intrin_function_name (void) +{ + char *name; + if (NULL == (name = _SLang_current_function_name ())) + return ""; + return name; +} + +static void intrin_message (char *s) +{ + SLang_vmessage ("%s", s); +} + +static void intrin_error (char *s) +{ + SLang_verror (SL_USER_ERROR, "%s", s); +} + +static void intrin_pop_n (int *n) +{ + SLdo_pop_n ((unsigned int) *n); +} + +static void intrin_reverse_stack (int *n) +{ + SLreverse_stack (*n); +} + +static void intrin_roll_stack (int *n) +{ + SLroll_stack (*n); +} + +static void usage (void) +{ + char *msg; + + _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 1); /* do not include format */ + + if (-1 == SLang_pop_slstring (&msg)) + return; + + SLang_verror (SL_USAGE_ERROR, "Usage: %s", msg); + SLang_free_slstring (msg); +} + +/* Convert string to integer */ +static int intrin_integer (char *s) +{ + int i; + + i = SLatoi ((unsigned char *) s); + + if (SLang_Error) + SLang_verror (SL_TYPE_MISMATCH, "Unable to convert string to integer"); + return i; +} +/*}}}*/ + +static void guess_type (char *s) +{ + SLang_push_datatype (SLang_guess_type(s)); +} + + +static int load_string_or_file (int (*f) (char *, char *)) +{ + char *file; + char *ns = NULL; + int status; + + if (SLang_Num_Function_Args == 2) + { + if (-1 == SLang_pop_slstring (&ns)) + return -1; + } + + if (-1 == SLang_pop_slstring (&file)) + { + SLang_free_slstring (ns); + return -1; + } + + status = (*f) (file, ns); + SLang_free_slstring (file); + SLang_free_slstring (ns); + return status; +} + +static int load_file (void) +{ + return (0 == load_string_or_file (SLns_load_file)); +} + +static void load_string (void) +{ + /* FIXME: This should use the namespace of the currently executing code */ + (void) load_string_or_file (SLns_load_string); +} + +static void get_doc_string (char *file, char *topic) +{ + FILE *fp; + char line[1024]; + unsigned int topic_len, str_len; + char *str; + char ch; + + if (NULL == (fp = fopen (file, "r"))) + { + SLang_push_null (); + return; + } + + topic_len = strlen (topic); + ch = *topic; + + while (1) + { + if (NULL == fgets (line, sizeof(line), fp)) + { + fclose (fp); + (void) SLang_push_null (); + return; + } + + if ((ch == *line) + && (0 == strncmp (line, topic, topic_len)) + && ((line[topic_len] == '\n') || (line [topic_len] == 0) + || (line[topic_len] == ' ') || (line[topic_len] == '\t'))) + break; + } + + if (NULL == (str = SLmake_string (line))) + { + fclose (fp); + (void) SLang_push_null (); + return; + } + str_len = strlen (str); + + while (NULL != fgets (line, sizeof (line), fp)) + { + unsigned int len; + char *new_str; + + ch = *line; + if (ch == '#') continue; + if (ch == '-') break; + + len = strlen (line); + if (NULL == (new_str = SLrealloc (str, str_len + len + 1))) + { + SLfree (str); + str = NULL; + break; + } + str = new_str; + strcpy (str + str_len, line); + str_len += len; + } + + fclose (fp); + + (void) SLang_push_malloced_string (str); +} + +static int push_string_array_elements (SLang_Array_Type *at) +{ + char **strs; + unsigned int num; + unsigned int i; + + if (at == NULL) + return -1; + + strs = (char **)at->data; + num = at->num_elements; + for (i = 0; i < num; i++) + { + if (-1 == SLang_push_string (strs[i])) + { + SLdo_pop_n (i); + return -1; + } + } + SLang_push_integer ((int) num); + return 0; +} + + +static void intrin_apropos (void) +{ + int num_args; + char *pat; + char *namespace_name; + unsigned int flags; + SLang_Array_Type *at; + + num_args = SLang_Num_Function_Args; + + if (-1 == SLang_pop_uinteger (&flags)) + return; + if (-1 == SLang_pop_slstring (&pat)) + return; + + namespace_name = NULL; + at = NULL; + if (num_args == 3) + { + if (-1 == SLang_pop_slstring (&namespace_name)) + goto free_and_return; + } + + at = _SLang_apropos (namespace_name, pat, flags); + if (num_args == 3) + { + (void) SLang_push_array (at, 0); + goto free_and_return; + } + + /* Maintain compatibility with old version of the function. That version + * did not take three arguments and returned everything to the stack. + * Yuk. + */ + (void) push_string_array_elements (at); + + free_and_return: + /* NULLs ok */ + SLang_free_slstring (namespace_name); + SLang_free_slstring (pat); + SLang_free_array (at); +} + +static int intrin_get_defines (void) +{ + int n = 0; + char **s = _SLdefines; + + while (*s != NULL) + { + if (-1 == SLang_push_string (*s)) + { + SLdo_pop_n ((unsigned int) n); + return -1; + } + s++; + n++; + } + return n; +} + +static void intrin_get_reference (char *name) +{ + _SLang_push_ref (1, (VOID_STAR) _SLlocate_name (name)); +} + +static void intrin_get_namespaces (void) +{ + SLang_push_array (_SLns_list_namespaces (), 1); +} + +#ifdef HAVE_SYS_UTSNAME_H +# include +#endif + +static void uname_cmd (void) +{ +#ifdef HAVE_UNAME + struct utsname u; + char *field_names [6]; + unsigned char field_types[6]; + VOID_STAR field_values [6]; + char *ptrs[6]; + int i; + + if (-1 == uname (&u)) + (void) SLang_push_null (); + + field_names[0] = "sysname"; ptrs[0] = u.sysname; + field_names[1] = "nodename"; ptrs[1] = u.nodename; + field_names[2] = "release"; ptrs[2] = u.release; + field_names[3] = "version"; ptrs[3] = u.version; + field_names[4] = "machine"; ptrs[4] = u.machine; + + for (i = 0; i < 5; i++) + { + field_types[i] = SLANG_STRING_TYPE; + field_values[i] = (VOID_STAR) &ptrs[i]; + } + + if (0 == SLstruct_create_struct (5, field_names, field_types, field_values)) + return; +#endif + + SLang_push_null (); +} + +static void uninitialize_ref_intrin (SLang_Ref_Type *ref) +{ + (void) _SLang_uninitialize_ref (ref); +} + +static int class_type_intrinsic (void) +{ + unsigned char type; + + if (-1 == SLang_pop_datatype (&type)) + return -1; + return _SLclass_get_class (type)->cl_class_type; +} + +static int class_id_intrinsic (void) +{ + unsigned char type; + + if (-1 == SLang_pop_datatype (&type)) + return -1; + return _SLclass_get_class (type)->cl_data_type; +} + +static int eqs_intrinsic (void) +{ + int eqs; + SLang_Object_Type a, b; + + if (-1 == SLang_pop (&b)) + return -1; + + if (-1 == SLang_pop (&a)) + { + SLang_free_object (&b); + return -1; + } + + eqs = (a.data_type == b.data_type); + if (eqs) + { + SLang_Class_Type *cl = _SLclass_get_class (a.data_type); + unsigned int sizeof_type = cl->cl_sizeof_type; + + switch (cl->cl_class_type) + { + case SLANG_CLASS_TYPE_MMT: + case SLANG_CLASS_TYPE_PTR: + eqs = (a.v.ptr_val == b.v.ptr_val); + break; + + case SLANG_CLASS_TYPE_SCALAR: + eqs = !memcmp (&a.v, &b.v, sizeof_type); + break; + + case SLANG_CLASS_TYPE_VECTOR: + eqs = !memcmp (a.v.ptr_val, b.v.ptr_val, sizeof_type); + break; + } + } + + SLang_free_object (&a); + SLang_free_object (&b); + return eqs; +} + +static void lang_print_stack (void) +{ + (void) _SLang_dump_stack (); +} + +static SLang_Intrin_Fun_Type SLang_Basic_Table [] = /*{{{*/ +{ + MAKE_INTRINSIC_1("__is_initialized", _SLang_is_ref_initialized, SLANG_INT_TYPE, SLANG_REF_TYPE), + MAKE_INTRINSIC_S("__get_reference", intrin_get_reference, SLANG_VOID_TYPE), + MAKE_INTRINSIC_1("__uninitialize", uninitialize_ref_intrin, SLANG_VOID_TYPE, SLANG_REF_TYPE), + MAKE_INTRINSIC_0("__eqs", eqs_intrinsic, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("__class_type", class_type_intrinsic, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("__class_id", class_id_intrinsic, SLANG_INT_TYPE), + MAKE_INTRINSIC_SS("get_doc_string_from_file", get_doc_string, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SS("autoload", SLang_autoload, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("is_defined", SLang_is_defined, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("string", _SLstring_intrinsic, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("uname", uname_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("getenv", intrin_getenv_cmd, SLANG_VOID_TYPE), +#ifdef HAVE_PUTENV + MAKE_INTRINSIC_0("putenv", intrin_putenv, SLANG_VOID_TYPE), +#endif + MAKE_INTRINSIC_0("evalfile", load_file, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("char", char_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("eval", load_string, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("dup", do_dup, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("integer", intrin_integer, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("system", SLsystem, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("_apropos", intrin_apropos, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_get_namespaces", intrin_get_namespaces, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("_trace_function", _SLang_trace_fun, SLANG_VOID_TYPE), +#if SLANG_HAS_FLOAT + MAKE_INTRINSIC_S("atof", _SLang_atof, SLANG_DOUBLE_TYPE), + MAKE_INTRINSIC_0("double", intrin_double, SLANG_VOID_TYPE), +#endif + MAKE_INTRINSIC_0("int", intrin_int, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("typecast", intrin_typecast, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_stkdepth", _SLstack_depth, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("_stk_reverse", intrin_reverse_stack, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("typeof", intrin_type_info, VOID_TYPE), + MAKE_INTRINSIC_0("_typeof", intrin_type_info1, VOID_TYPE), + MAKE_INTRINSIC_I("_pop_n", intrin_pop_n, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_print_stack", lang_print_stack, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("_stk_roll", intrin_roll_stack, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SI("byte_compile_file", byte_compile_file, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_clear_error", _SLang_clear_error, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_function_name", intrin_function_name, SLANG_STRING_TYPE), +#if SLANG_HAS_FLOAT + MAKE_INTRINSIC_S("set_float_format", _SLset_double_format, SLANG_VOID_TYPE), +#endif + MAKE_INTRINSIC_S("_slang_guess_type", guess_type, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("error", intrin_error, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("message", intrin_message, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("__get_defined_symbols", intrin_get_defines, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("__pop_args", _SLstruct_pop_args, SLANG_VOID_TYPE), + MAKE_INTRINSIC_1("__push_args", _SLstruct_push_args, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), + MAKE_INTRINSIC_0("usage", usage, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("implements", _SLang_implements_intrinsic, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("use_namespace", _SLang_use_namespace_intrinsic, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("current_namespace", _SLang_cur_namespace_intrinsic, SLANG_STRING_TYPE), + MAKE_INTRINSIC_0("length", length_cmd, SLANG_INT_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +/*}}}*/ + +#ifdef SLANG_DOC_DIR +char *SLang_Doc_Dir = SLANG_DOC_DIR; +#else +char *SLang_Doc_Dir = ""; +#endif + +static SLang_Intrin_Var_Type Intrin_Vars[] = +{ + MAKE_VARIABLE("_debug_info", &_SLang_Compile_Line_Num_Info, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("_auto_declare", &_SLang_Auto_Declare_Globals, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("_traceback", &SLang_Traceback, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("_slangtrace", &_SLang_Trace, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("_slang_version", &SLang_Version, SLANG_INT_TYPE, 1), + MAKE_VARIABLE("_slang_version_string", &SLang_Version_String, SLANG_STRING_TYPE, 1), + MAKE_VARIABLE("_NARGS", &SLang_Num_Function_Args, SLANG_INT_TYPE, 1), + MAKE_VARIABLE("_slang_doc_dir", &SLang_Doc_Dir, SLANG_STRING_TYPE, 1), + MAKE_VARIABLE("NULL", NULL, SLANG_NULL_TYPE, 1), + SLANG_END_INTRIN_VAR_TABLE +}; + +int SLang_init_slang (void) /*{{{*/ +{ + char name[3]; + unsigned int i; + char **s; + static char *sys_defines [] = + { +#if defined(__os2__) + "OS2", +#endif +#if defined(__MSDOS__) + "MSDOS", +#endif +#if defined(__WIN16__) + "WIN16", +#endif +#if defined (__WIN32__) + "WIN32", +#endif +#if defined(__NT__) + "NT", +#endif +#if defined (VMS) + "VMS", +#endif +#ifdef REAL_UNIX_SYSTEM + "UNIX", +#endif +#if SLANG_HAS_FLOAT + "SLANG_DOUBLE_TYPE", +#endif + NULL + }; + + if (-1 == _SLregister_types ()) return -1; + + if ((-1 == SLadd_intrin_fun_table(SLang_Basic_Table, NULL)) + || (-1 == SLadd_intrin_var_table (Intrin_Vars, NULL)) + || (-1 == _SLang_init_slstrops ()) + || (-1 == _SLang_init_sltime ()) + || (-1 == _SLstruct_init ()) +#if SLANG_HAS_ASSOC_ARRAYS + || (-1 == SLang_init_slassoc ()) +#endif + ) + return -1; + + SLadd_global_variable (SLANG_SYSTEM_NAME); + + s = sys_defines; + while (*s != NULL) + { + if (-1 == SLdefine_for_ifdef (*s)) return -1; + s++; + } + + /* give temp global variables $0 --> $9 */ + name[2] = 0; name[0] = '$'; + for (i = 0; i < 10; i++) + { + name[1] = (char) (i + '0'); + SLadd_global_variable (name); + } + + SLang_init_case_tables (); + + /* Now add a couple of macros */ + SLang_load_string (".(_NARGS 1 - Sprintf error)verror"); + SLang_load_string (".(_NARGS 1 - Sprintf message)vmessage"); + + if (SLang_Error) + return -1; + + return 0; +} + +/*}}}*/ + +int SLang_set_argc_argv (int argc, char **argv) +{ + static int this_argc; + static char **this_argv; + int i; + + if (argc < 0) argc = 0; + this_argc = argc; + + if (NULL == (this_argv = (char **) SLmalloc ((argc + 1) * sizeof (char *)))) + return -1; + memset ((char *) this_argv, 0, sizeof (char *) * (argc + 1)); + + for (i = 0; i < argc; i++) + { + if (NULL == (this_argv[i] = SLang_create_slstring (argv[i]))) + goto return_error; + } + + if (-1 == SLadd_intrinsic_variable ("__argc", (VOID_STAR)&this_argc, + SLANG_INT_TYPE, 1)) + goto return_error; + + if (-1 == SLang_add_intrinsic_array ("__argv", SLANG_STRING_TYPE, 1, + (VOID_STAR) this_argv, 1, argc)) + goto return_error; + + return 0; + + return_error: + for (i = 0; i < argc; i++) + SLang_free_slstring (this_argv[i]); /* NULL ok */ + SLfree ((char *) this_argv); + + return -1; +} diff --git a/libslang/src/slstdio.c b/libslang/src/slstdio.c new file mode 100644 index 0000000..b783f76 --- /dev/null +++ b/libslang/src/slstdio.c @@ -0,0 +1,1071 @@ +/* file stdio intrinsics for S-Lang */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if defined(__unix__) || (defined (__os2__) && defined (__EMX__)) +# include +#endif + +#ifdef HAVE_FCNTL_H +# include +#endif +#ifdef HAVE_SYS_FCNTL_H +# include +#endif + +#ifdef __unix__ +# include +#endif + +#if defined(__BORLANDC__) +# include +# include +#endif + +#if defined(__DECC) && defined(VMS) +# include +# include +#endif + +#ifdef VMS +# include +#else +# include +#endif + +#include + +#include + +/* #define SL_APP_WANTS_FOREACH */ +#include "slang.h" +#include "_slang.h" + +typedef struct +{ + FILE *fp; /* kind of obvious */ + char *file; /* file name associated with pointer */ + + unsigned int flags; /* modes, etc... */ +#define SL_READ 0x0001 +#define SL_WRITE 0x0002 +#define SL_BINARY 0x0004 +#define SL_FDOPEN 0x2000 +#define SL_PIPE 0x4000 +#define SL_INUSE 0x8000 +} +SL_File_Table_Type; + +static SL_File_Table_Type *SL_File_Table; + +static SL_File_Table_Type *get_free_file_table_entry (void) +{ + SL_File_Table_Type *t = SL_File_Table, *tmax; + + tmax = t + SL_MAX_FILES; + while (t < tmax) + { + if (t->flags == 0) + { + memset ((char *) t, 0, sizeof (SL_File_Table_Type)); + return t; + } + t++; + } + + return NULL; +} + +static unsigned int file_process_flags (char *mode) +{ + char ch; + unsigned int flags = 0; + + while (1) + { + ch = *mode++; + switch (ch) + { + case 'r': flags |= SL_READ; + break; + case 'w': + case 'a': + case 'A': + flags |= SL_WRITE; + break; + case '+': flags |= SL_WRITE | SL_READ; + break; + case 'b': flags |= SL_BINARY; + break; + case 0: + return flags; + + default: + SLang_verror (SL_INVALID_PARM, "File flag %c is not supported", ch); + return 0; + } + } +} + +static int open_file_type (char *file, int fd, char *mode, + FILE *(*open_fun)(char *, char *), + int (*close_fun)(FILE *), + unsigned int xflags) +{ + FILE *fp; + SL_File_Table_Type *t; + unsigned int flags; + SLang_MMT_Type *mmt; + + fp = NULL; + /* t = NULL; */ + mmt = NULL; + + if ((NULL == (t = get_free_file_table_entry ())) + || (0 == (flags = file_process_flags(mode)))) + goto return_error; + + if (fd != -1) + fp = fdopen (fd, mode); + else + fp = open_fun (file, mode); + + if (fp == NULL) + { + _SLerrno_errno = errno; + goto return_error; + } + + if (NULL == (mmt = SLang_create_mmt (SLANG_FILE_PTR_TYPE, (VOID_STAR) t))) + goto return_error; + + t->fp = fp; + t->flags = flags | xflags; + fp = NULL; /* allow free_mmt to close fp */ + + if ((NULL != (t->file = SLang_create_slstring (file))) + && (0 == SLang_push_mmt (mmt))) + return 0; + + /* drop */ + + return_error: + if (fp != NULL) (*close_fun) (fp); + if (mmt != NULL) SLang_free_mmt (mmt); + (void) SLang_push_null (); + return -1; +} + +/* Since some compilers do not have popen/pclose prototyped and in scope, + * and pc compilers sometimes have silly prototypes involving PASCAL, etc. + * use wrappers around the function to avoid compilation errors. + */ + +static FILE *fopen_fun (char *f, char *m) +{ + return fopen (f, m); +} +static int fclose_fun (FILE *fp) +{ + return fclose (fp); +} + +static void stdio_fopen (char *file, char *mode) +{ + (void) open_file_type (file, -1, mode, fopen_fun, fclose_fun, 0); +} + +int _SLstdio_fdopen (char *file, int fd, char *mode) +{ + if (fd == -1) + { + _SLerrno_errno = EBADF; + (void) SLang_push_null (); + return -1; + } + + return open_file_type (file, fd, mode, NULL, fclose_fun, SL_FDOPEN); +} + +#ifdef HAVE_POPEN +static int pclose_fun (FILE *fp) +{ + return pclose (fp); +} + +static FILE *popen_fun (char *file, char *mode) +{ + return popen (file, mode); +} + +static void stdio_popen (char *file, char *mode) +{ + (void) open_file_type (file, -1, mode, popen_fun, pclose_fun, SL_PIPE); +} +#endif + +/* returns pointer to file entry if it is open and consistent with + flags. Returns NULL otherwise */ +static SLang_MMT_Type *pop_fp (unsigned int flags, FILE **fp_ptr) +{ + SL_File_Table_Type *t; + SLang_MMT_Type *mmt; + + *fp_ptr = NULL; + + if (NULL == (mmt = SLang_pop_mmt (SLANG_FILE_PTR_TYPE))) + return NULL; + + t = (SL_File_Table_Type *) SLang_object_from_mmt (mmt); + if ((t->flags & flags) + && (NULL != (*fp_ptr = t->fp))) + return mmt; + + SLang_free_mmt (mmt); + return NULL; +} + +static FILE *check_fp (SL_File_Table_Type *t, unsigned flags) +{ + if ((t != NULL) && (t->flags & flags)) + return t->fp; + + return NULL; +} + +char *SLang_get_name_from_fileptr (SLang_MMT_Type *mmt) +{ + SL_File_Table_Type *ft; + + ft = (SL_File_Table_Type *) SLang_object_from_mmt (mmt); + if (ft == NULL) + return NULL; + return ft->file; +} + +int SLang_pop_fileptr (SLang_MMT_Type **mmt, FILE **fp) +{ + if (NULL == (*mmt = pop_fp (0xFFFF, fp))) + { +#ifdef EBADF + _SLerrno_errno = EBADF; +#endif + return -1; + } + + return 0; +} + +static int close_file_type (SL_File_Table_Type *t) +{ + int ret = 0; + FILE *fp; + + if (t == NULL) + return -1; + + fp = t->fp; + + if (NULL == fp) ret = -1; + else + { + if (0 == (t->flags & SL_PIPE)) + { + if (EOF == (ret = fclose (fp))) + _SLerrno_errno = errno; + } +#ifdef HAVE_POPEN + else + { + if (-1 == (ret = pclose (fp))) + _SLerrno_errno = errno; + } +#endif + } + + if (t->file != NULL) SLang_free_slstring (t->file); + memset ((char *) t, 0, sizeof (SL_File_Table_Type)); + return ret; +} + +static int stdio_fclose (SL_File_Table_Type *t) +{ + int ret; + + if (NULL == check_fp (t, 0xFFFF)) + return -1; + + ret = close_file_type (t); + + t->flags = SL_INUSE; + return ret; +} + +static int read_one_line (FILE *fp, char **strp, unsigned int *lenp, int trim_trailing) +{ + char buf[512]; + char *str; + unsigned int len; + + *strp = NULL; + len = 0; + str = NULL; + + while (NULL != fgets (buf, sizeof (buf), fp)) + { + unsigned int dlen; + char *new_str; + int done_flag; + + dlen = strlen (buf); + /* Note: If the file contains embedded \0 characters, then this + * fails to work properly since dlen will not be correct. + */ + done_flag = ((dlen + 1 < sizeof (buf)) + || (buf[dlen - 1] == '\n')); + + if (done_flag && (str == NULL)) + { + /* Avoid the malloc */ + str = buf; + len = dlen; + break; + } + + if (NULL == (new_str = SLrealloc (str, len + dlen + 1))) + { + SLfree (str); + return -1; + } + + str = new_str; + strcpy (str + len, buf); + len += dlen; + + if (done_flag) break; + } + + if (str == NULL) + return 0; + + if (trim_trailing) + { + unsigned int len1 = len; + while (len1) + { + len1--; + if (0 == isspace(str[len1])) + { + len1++; + break; + } + } + len = len1; + } + + *strp = SLang_create_nslstring (str, len); + if (str != buf) SLfree (str); + + if (*strp == NULL) return -1; + + *lenp = len; + return 1; +} + +/* returns number of characters read and pushes the string to the stack. + If it fails, it returns -1 */ +static int stdio_fgets (SLang_Ref_Type *ref, SL_File_Table_Type *t) +{ + char *s; + unsigned int len; + FILE *fp; + int status; + + if (NULL == (fp = check_fp (t, SL_READ))) + return -1; + + status = read_one_line (fp, &s, &len, 0); + if (status <= 0) + return -1; + + status = SLang_assign_to_ref (ref, SLANG_STRING_TYPE, (VOID_STAR)&s); + SLang_free_slstring (s); + + if (status == -1) + return -1; + + return (int) len; +} + +static void stdio_fgetslines_internal (FILE *fp, unsigned int n) +{ + unsigned int num_lines, max_num_lines; + char **list; + SLang_Array_Type *at; + int inum_lines; + + if (n > 1024) + max_num_lines = 1024; + else + { + max_num_lines = n; + if (max_num_lines == 0) + max_num_lines++; + } + + list = (char **) SLmalloc (sizeof (char *) * max_num_lines); + if (list == NULL) + return; + + num_lines = 0; + while (num_lines < n) + { + int status; + char *line; + unsigned int len; + + status = read_one_line (fp, &line, &len, 0); + if (status == -1) + goto return_error; + + if (status == 0) + break; + + if (max_num_lines == num_lines) + { + char **new_list; + + if (max_num_lines + 4096 > n) + max_num_lines = n; + else + max_num_lines += 4096; + + new_list = (char **) SLrealloc ((char *)list, sizeof (char *) * max_num_lines); + if (new_list == NULL) + { + SLang_free_slstring (line); + goto return_error; + } + list = new_list; + } + + list[num_lines] = line; + num_lines++; + } + + if (num_lines != max_num_lines) + { + char **new_list; + + new_list = (char **)SLrealloc ((char *)list, sizeof (char *) * (num_lines + 1)); + if (new_list == NULL) + goto return_error; + + list = new_list; + } + + inum_lines = (int) num_lines; + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) list, &inum_lines, 1))) + goto return_error; + + if (-1 == SLang_push_array (at, 1)) + SLang_push_null (); + return; + + return_error: + while (num_lines > 0) + { + num_lines--; + SLfree (list[num_lines]); + } + SLfree ((char *)list); + SLang_push_null (); +} + +static void stdio_fgetslines (void) +{ + unsigned int n; + FILE *fp; + SLang_MMT_Type *mmt; + + n = (unsigned int)-1; + + if (SLang_Num_Function_Args == 2) + { + if (-1 == SLang_pop_uinteger (&n)) + return; + } + + if (NULL == (mmt = pop_fp (SL_READ, &fp))) + { + SLang_push_null (); + return; + } + + stdio_fgetslines_internal (fp, n); + SLang_free_mmt (mmt); +} + + +static int stdio_fputs (char *s, SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, SL_WRITE))) + return -1; + + if (EOF == fputs(s, fp)) return -1; + return (int) strlen (s); +} + +static int stdio_fflush (SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, SL_WRITE))) + return -1; + + if (EOF == fflush (fp)) + { + _SLerrno_errno = errno; + return -1; + } + + return 0; +} + +/* Usage: n = fread (&str, data-type, nelems, fp); */ +static void stdio_fread (SLang_Ref_Type *ref, int *data_typep, unsigned int *num_elemns, SL_File_Table_Type *t) +{ + char *s; + FILE *fp; + int ret; + unsigned int num_read, num_to_read; + unsigned int nbytes; + SLang_Class_Type *cl; + unsigned int sizeof_type; + int data_type; + + ret = -1; + s = NULL; + /* cl = NULL; */ + + if (NULL == (fp = check_fp (t, SL_READ))) + goto the_return; + + /* FIXME: priority = low : I should add some mechanism to support + * other types. + */ + data_type = *data_typep; + + cl = _SLclass_get_class ((unsigned char) data_type); + + if (cl->cl_fread == NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "fread does not support %s objects", + cl->cl_name); + goto the_return; + } + + sizeof_type = cl->cl_sizeof_type; + + num_to_read = *num_elemns; + nbytes = (unsigned int) num_to_read * sizeof_type; + + s = SLmalloc (nbytes + 1); + if (s == NULL) + goto the_return; + + ret = cl->cl_fread (data_type, fp, (VOID_STAR)s, num_to_read, &num_read); + + if ((num_read == 0) + && (num_read != num_to_read)) + ret = -1; + + if ((ret == -1) && ferror (fp)) + _SLerrno_errno = errno; + + if ((ret == 0) + && (num_read != num_to_read)) + { + char *new_s; + + nbytes = num_read * sizeof_type; + new_s = SLrealloc (s, nbytes + 1); + if (new_s == NULL) + ret = -1; + else + s = new_s; + } + + if (ret == 0) + { + if (num_read == 1) + { + ret = SLang_assign_to_ref (ref, data_type, (VOID_STAR)s); + SLfree (s); + } + else if ((data_type == SLANG_CHAR_TYPE) + || (data_type == SLANG_UCHAR_TYPE)) + { + SLang_BString_Type *bs; + + bs = SLbstring_create_malloced ((unsigned char *)s, num_read, 1); + ret = SLang_assign_to_ref (ref, SLANG_BSTRING_TYPE, (VOID_STAR)&bs); + SLbstring_free (bs); + } + else + { + SLang_Array_Type *at; + int inum_read = (int) num_read; + at = SLang_create_array (data_type, 0, (VOID_STAR)s, &inum_read, 1); + ret = SLang_assign_to_ref (ref, SLANG_ARRAY_TYPE, (VOID_STAR)&at); + SLang_free_array (at); + } + s = NULL; + } + + the_return: + + if (s != NULL) + SLfree (s); + + if (ret == -1) + SLang_push_integer (ret); + else + SLang_push_uinteger (num_read); +} + +/* Usage: n = fwrite (str, fp); */ +static void stdio_fwrite (SL_File_Table_Type *t) +{ + FILE *fp; + unsigned char *s; + unsigned int num_to_write, num_write; + int ret; + SLang_BString_Type *b; + SLang_Array_Type *at; + SLang_Class_Type *cl; + + ret = -1; + b = NULL; + at = NULL; + + switch (SLang_peek_at_stack ()) + { + case SLANG_BSTRING_TYPE: + case SLANG_STRING_TYPE: + if (-1 == SLang_pop_bstring (&b)) + goto the_return; + + if (NULL == (s = SLbstring_get_pointer (b, &num_to_write))) + goto the_return; + + cl = _SLclass_get_class (SLANG_UCHAR_TYPE); + break; + + default: + if (-1 == SLang_pop_array (&at, 1)) + goto the_return; + + cl = at->cl; + num_to_write = at->num_elements; + s = (unsigned char *) at->data; + } + + if (NULL == (fp = check_fp (t, SL_WRITE))) + goto the_return; + + if (cl->cl_fwrite == NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "fwrite does not support %s objects", cl->cl_name); + goto the_return; + } + + ret = cl->cl_fwrite (cl->cl_data_type, fp, s, num_to_write, &num_write); + + if ((ret == -1) && ferror (fp)) + _SLerrno_errno = errno; + + /* drop */ + the_return: + if (b != NULL) + SLbstring_free (b); + if (at != NULL) + SLang_free_array (at); + + if (ret == -1) + SLang_push_integer (ret); + else + SLang_push_uinteger (num_write); +} + +static int stdio_fseek (SL_File_Table_Type *t, int *ofs, int *whence) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, 0xFFFF))) + return -1; + + if (-1 == fseek (fp, (long) *ofs, *whence)) + { + _SLerrno_errno = errno; + return -1; + } + + return 0; +} + +static int stdio_ftell (SL_File_Table_Type *t) +{ + FILE *fp; + long ofs; + + if (NULL == (fp = check_fp (t, 0xFFFF))) + return -1; + + if (-1L == (ofs = ftell (fp))) + { + _SLerrno_errno = errno; + return -1; + } + + return (int) ofs; +} + +static int stdio_feof (SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, 0xFFFF))) + return -1; + + return feof (fp); +} + +static int stdio_ferror (SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, 0xFFFF))) + return -1; + + return ferror (fp); +} + +static void stdio_clearerr (SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL != (fp = check_fp (t, 0xFFFF))) + clearerr (fp); +} + +/* () = fprintf (fp, "FORMAT", arg...); */ +static int stdio_fprintf (void) +{ + char *s; + FILE *fp; + SLang_MMT_Type *mmt; + int status; + + if (-1 == _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 2)) + return -1; + + if (-1 == SLang_pop_slstring (&s)) + return -1; + + if (NULL == (mmt = pop_fp (SL_WRITE, &fp))) + { + SLang_free_slstring (s); + return -1; + } + + if (EOF == fputs(s, fp)) + status = -1; + else + status = (int) strlen (s); + + SLang_free_mmt (mmt); + SLang_free_slstring (s); + return status; +} + +static int stdio_printf (void) +{ + char *s; + int status; + + if (-1 == _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 1)) + return -1; + + if (-1 == SLang_pop_slstring (&s)) + return -1; + + if (EOF == fputs(s, stdout)) + status = -1; + else + status = (int) strlen (s); + + SLang_free_slstring (s); + return status; +} + + +#define F SLANG_FILE_PTR_TYPE +#define R SLANG_REF_TYPE +#define I SLANG_INT_TYPE +#define V SLANG_VOID_TYPE +#define S SLANG_STRING_TYPE +#define B SLANG_BSTRING_TYPE +#define U SLANG_UINT_TYPE +#define D SLANG_DATATYPE_TYPE +static SLang_Intrin_Fun_Type Stdio_Name_Table[] = +{ + MAKE_INTRINSIC_0("fgetslines", stdio_fgetslines, V), + MAKE_INTRINSIC_SS("fopen", stdio_fopen, V), + MAKE_INTRINSIC_1("feof", stdio_feof, I, F), + MAKE_INTRINSIC_1("ferror", stdio_ferror, I, F), + MAKE_INTRINSIC_1("fclose", stdio_fclose, I, F), + MAKE_INTRINSIC_2("fgets", stdio_fgets, I, R, F), + MAKE_INTRINSIC_1("fflush", stdio_fflush, I, F), + MAKE_INTRINSIC_2("fputs", stdio_fputs, I, S, F), + MAKE_INTRINSIC_0("fprintf", stdio_fprintf, I), + MAKE_INTRINSIC_0("printf", stdio_printf, I), + MAKE_INTRINSIC_3("fseek", stdio_fseek, I, F, I, I), + MAKE_INTRINSIC_1("ftell", stdio_ftell, I, F), + MAKE_INTRINSIC_1("clearerr", stdio_clearerr, V, F), + MAKE_INTRINSIC_4("fread", stdio_fread, V, R, D, U, F), + MAKE_INTRINSIC_1("fwrite", stdio_fwrite, V, F), +#ifdef HAVE_POPEN + MAKE_INTRINSIC_SS("popen", stdio_popen, V), + MAKE_INTRINSIC_1("pclose", stdio_fclose, I, F), +#endif + SLANG_END_INTRIN_FUN_TABLE +}; +#undef F +#undef I +#undef R +#undef V +#undef S +#undef B +#undef U +#undef D + +#ifndef SEEK_SET +# define SEEK_SET 0 +#endif +#ifndef SEEK_CUR +# define SEEK_CUR 1 +#endif +#ifndef SEEK_END +# define SEEK_END 2 +#endif + +static SLang_IConstant_Type Stdio_Consts [] = +{ + MAKE_ICONSTANT("SEEK_SET", SEEK_SET), + MAKE_ICONSTANT("SEEK_END", SEEK_END), + MAKE_ICONSTANT("SEEK_CUR", SEEK_CUR), + SLANG_END_ICONST_TABLE +}; + +static void destroy_file_type (unsigned char type, VOID_STAR ptr) +{ + (void) type; + (void) close_file_type ((SL_File_Table_Type *) ptr); +} + + +struct _SLang_Foreach_Context_Type +{ + SLang_MMT_Type *mmt; + FILE *fp; +#define CTX_USE_LINE 1 +#define CTX_USE_CHAR 2 +#define CTX_USE_LINE_WS 3 + unsigned char type; +}; + + +static SLang_Foreach_Context_Type * +cl_foreach_open (unsigned char type, unsigned int num) +{ + SLang_Foreach_Context_Type *c; + SLang_MMT_Type *mmt; + FILE *fp; + + if (NULL == (mmt = pop_fp (SL_READ, &fp))) + return NULL; + + /* type = CTX_USE_LINE; */ + + switch (num) + { + char *s; + + case 0: + type = CTX_USE_LINE; + break; + + case 1: + if (-1 == SLang_pop_slstring (&s)) + { + SLang_free_mmt (mmt); + return NULL; + } + if (0 == strcmp (s, "char")) + type = CTX_USE_CHAR; + else if (0 == strcmp (s, "line")) + type = CTX_USE_LINE; + else if (0 == strcmp (s, "wsline")) + type = CTX_USE_LINE_WS; + else + { + SLang_verror (SL_NOT_IMPLEMENTED, + "using '%s' not supported by File_Type", + s); + SLang_free_slstring (s); + SLang_free_mmt (mmt); + return NULL; + } + SLang_free_slstring (s); + break; + + default: + SLdo_pop_n (num); + SLang_verror (SL_NOT_IMPLEMENTED, + "Usage: foreach (File_Type) using ([line|char])"); + SLang_free_mmt (mmt); + return NULL; + } + + if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type)))) + { + SLang_free_mmt (mmt); + return NULL; + } + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + + c->type = type; + c->mmt = mmt; + c->fp = fp; + + return c; +} + +static void cl_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + SLang_free_mmt (c->mmt); + SLfree ((char *) c); +} + +static int cl_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + int status; + int ch; + unsigned int len; + char *s; + + (void) type; + + if (c == NULL) + return -1; + + switch (c->type) + { + case CTX_USE_CHAR: + if (EOF == (ch = getc (c->fp))) + return 0; + if (-1 == SLang_push_uchar ((unsigned char) ch)) + return -1; + return 1; + + case CTX_USE_LINE: + case CTX_USE_LINE_WS: + status = read_one_line (c->fp, &s, &len, (c->type==CTX_USE_LINE_WS)); + if (status <= 0) + return status; + if (0 == _SLang_push_slstring (s)) + return 1; + return -1; + } + + return -1; +} + +static int Stdio_Initialized; +static SLang_MMT_Type *Stdio_Mmts[3]; + +int SLang_init_stdio (void) +{ + unsigned int i; + SL_File_Table_Type *s; + SLang_Class_Type *cl; + char *names[3]; + + if (Stdio_Initialized) + return 0; + + SL_File_Table = (SL_File_Table_Type *)SLcalloc(sizeof (SL_File_Table_Type), SL_MAX_FILES); + if (SL_File_Table == NULL) + return -1; + + if (NULL == (cl = SLclass_allocate_class ("File_Type"))) + return -1; + cl->cl_destroy = destroy_file_type; + cl->cl_foreach_open = cl_foreach_open; + cl->cl_foreach_close = cl_foreach_close; + cl->cl_foreach = cl_foreach; + + + if (-1 == SLclass_register_class (cl, SLANG_FILE_PTR_TYPE, sizeof (SL_File_Table_Type), SLANG_CLASS_TYPE_MMT)) + return -1; + + if ((-1 == SLadd_intrin_fun_table(Stdio_Name_Table, "__STDIO__")) + || (-1 == SLadd_iconstant_table (Stdio_Consts, NULL)) + || (-1 == _SLerrno_init ())) + return -1; + + names[0] = "stdin"; + names[1] = "stdout"; + names[2] = "stderr"; + + s = SL_File_Table; + s->fp = stdin; s->flags = SL_READ; + + s++; + s->fp = stdout; s->flags = SL_WRITE; + + s++; + s->fp = stderr; s->flags = SL_WRITE|SL_READ; + + s = SL_File_Table; + for (i = 0; i < 3; i++) + { + if (NULL == (s->file = SLang_create_slstring (names[i]))) + return -1; + + if (NULL == (Stdio_Mmts[i] = SLang_create_mmt (SLANG_FILE_PTR_TYPE, (VOID_STAR) s))) + return -1; + SLang_inc_mmt (Stdio_Mmts[i]); + + if (-1 == SLadd_intrinsic_variable (s->file, (VOID_STAR)&Stdio_Mmts[i], SLANG_FILE_PTR_TYPE, 1)) + return -1; + s++; + } + + Stdio_Initialized = 1; + return 0; +} + diff --git a/libslang/src/slstring.c b/libslang/src/slstring.c new file mode 100644 index 0000000..69e3633 --- /dev/null +++ b/libslang/src/slstring.c @@ -0,0 +1,548 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +typedef struct _SLstring_Type +{ + struct _SLstring_Type *next; + unsigned int ref_count; + char bytes [1]; +} +SLstring_Type; + +static SLstring_Type *String_Hash_Table [SLSTRING_HASH_TABLE_SIZE]; +static char Single_Char_Strings [256 * 2]; + +#if _SLANG_OPTIMIZE_FOR_SPEED +#define MAX_FREE_STORE_LEN 32 +static SLstring_Type *SLS_Free_Store [MAX_FREE_STORE_LEN]; + +# define NUM_CACHED_STRINGS 601 +typedef struct +{ + unsigned long hash; + SLstring_Type *sls; + unsigned int len; +} +Cached_String_Type; +static Cached_String_Type Cached_Strings [NUM_CACHED_STRINGS]; + +#define GET_CACHED_STRING(s) \ + (Cached_Strings + (unsigned int)(((unsigned long) (s)) % NUM_CACHED_STRINGS)) + +_INLINE_ +static void cache_string (SLstring_Type *sls, unsigned int len, unsigned long hash) +{ + Cached_String_Type *cs; + + cs = GET_CACHED_STRING(sls->bytes); + cs->sls = sls; + cs->hash = hash; + cs->len = len; +} + +_INLINE_ +static void uncache_string (char *s) +{ + Cached_String_Type *cs; + + cs = GET_CACHED_STRING(s); + if ((cs->sls != NULL) + && (cs->sls->bytes == s)) + cs->sls = NULL; +} +#endif + + + +_INLINE_ +unsigned long _SLstring_hash (unsigned char *s, unsigned char *smax) +{ + register unsigned long h = 0; + register unsigned long sum = 0; + unsigned char *smax4; + + smax4 = smax - 4; + + while (s < smax4) + { + sum += s[0]; + h = sum + (h << 1); + sum += s[1]; + h = sum + (h << 1); + sum += s[2]; + h = sum + (h << 1); + sum += s[3]; + h = sum + (h << 1); + + s += 4; + } + + while (s < smax) + { + sum += *s++; + h ^= sum + (h << 3); /* slightly different */ + } + + return h; +} + +unsigned long _SLcompute_string_hash (char *s) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + SLstring_Type *sls; + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + return cs->hash; +#endif + return _SLstring_hash ((unsigned char *) s, (unsigned char *) s + strlen (s)); +} + +_INLINE_ +/* This routine works with any (long) string */ +static SLstring_Type *find_string (char *s, unsigned int len, unsigned long hash) +{ + SLstring_Type *sls; + char ch; + + sls = String_Hash_Table [(unsigned int)(hash % SLSTRING_HASH_TABLE_SIZE)]; + + if (sls == NULL) + return NULL; + + ch = s[0]; + do + { + char *bytes = sls->bytes; + + /* Note that we need to actually make sure that bytes[len] == 0. + * In this case, it is not enough to just compare pointers. In fact, + * this is called from create_nstring, etc... It is unlikely that the + * pointer is a slstring + */ + if ((/* (s == bytes) || */ ((ch == bytes[0]) + && (0 == strncmp (s, bytes, len)))) + && (bytes [len] == 0)) + break; + + sls = sls->next; + } + while (sls != NULL); + + return sls; +} + +_INLINE_ +static SLstring_Type *find_slstring (char *s, unsigned long hash) +{ + SLstring_Type *sls; + + sls = String_Hash_Table [(unsigned int)(hash % SLSTRING_HASH_TABLE_SIZE)]; + while (sls != NULL) + { + if (s == sls->bytes) + return sls; + + sls = sls->next; + } + return sls; +} + +_INLINE_ +static SLstring_Type *allocate_sls (unsigned int len) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + SLstring_Type *sls; + + if ((len < MAX_FREE_STORE_LEN) + && (NULL != (sls = SLS_Free_Store [len]))) + { + SLS_Free_Store[len] = NULL; + return sls; + } +#endif + /* FIXME: use structure padding */ + return (SLstring_Type *) SLmalloc (len + sizeof (SLstring_Type)); +} + +_INLINE_ +static void free_sls (SLstring_Type *sls, unsigned int len) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + if ((len < MAX_FREE_STORE_LEN) + && (SLS_Free_Store[len] == NULL)) + { + SLS_Free_Store [len] = sls; + return; + } +#else + (void) len; +#endif + SLfree ((char *)sls); +} + +_INLINE_ +static char *create_long_string (char *s, unsigned int len, unsigned long hash) +{ + SLstring_Type *sls; + + sls = find_string (s, len, hash); + + if (sls != NULL) + { + sls->ref_count++; + s = sls->bytes; + +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + return s; + } + + sls = allocate_sls (len); + if (sls == NULL) + return NULL; + + strncpy (sls->bytes, s, len); + sls->bytes[len] = 0; + sls->ref_count = 1; + +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + + hash = hash % SLSTRING_HASH_TABLE_SIZE; + sls->next = String_Hash_Table [(unsigned int)hash]; + String_Hash_Table [(unsigned int)hash] = sls; + + return sls->bytes; +} + +_INLINE_ +static char *create_short_string (char *s, unsigned int len) +{ + char ch; + + /* Note: if len is 0, then it does not matter what *s is. This is + * important for SLang_create_nslstring. + */ + if (len) ch = *s; else ch = 0; + + len = 2 * (unsigned int) ((unsigned char) ch); + Single_Char_Strings [len] = ch; + Single_Char_Strings [len + 1] = 0; + return Single_Char_Strings + len; +} + +/* s cannot be NULL */ +_INLINE_ +static char *create_nstring (char *s, unsigned int len, unsigned long *hash_ptr) +{ + unsigned long hash; + + if (len < 2) + return create_short_string (s, len); + + hash = _SLstring_hash ((unsigned char *) s, (unsigned char *) (s + len)); + *hash_ptr = hash; + + return create_long_string (s, len, hash); +} + +char *SLang_create_nslstring (char *s, unsigned int len) +{ + unsigned long hash; + return create_nstring (s, len, &hash); +} + +char *_SLstring_make_hashed_string (char *s, unsigned int len, unsigned long *hashptr) +{ + unsigned long hash; + + if (s == NULL) return NULL; + + hash = _SLstring_hash ((unsigned char *) s, (unsigned char *) s + len); + *hashptr = hash; + + if (len < 2) + return create_short_string (s, len); + + return create_long_string (s, len, hash); +} + +char *_SLstring_dup_hashed_string (char *s, unsigned long hash) +{ + unsigned int len; +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + SLstring_Type *sls; + + if (s == NULL) return NULL; + if (s[0] == 0) + return create_short_string (s, 0); + if (s[1] == 0) + return create_short_string (s, 1); + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + { + sls->ref_count += 1; + return s; + } +#else + if (s == NULL) return NULL; +#endif + + len = strlen (s); +#if !_SLANG_OPTIMIZE_FOR_SPEED + if (len < 2) return create_short_string (s, len); +#endif + + return create_long_string (s, len, hash); +} + +char *_SLstring_dup_slstring (char *s) +{ + SLstring_Type *sls; + unsigned int len; + unsigned long hash; +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + { + sls->ref_count += 1; + return s; + } +#endif + + if ((s == NULL) || ((len = strlen (s)) < 2)) + return s; + + hash = _SLstring_hash ((unsigned char *)s, (unsigned char *)(s + len)); + + sls = find_slstring (s, hash); + if (sls == NULL) + { + SLang_Error = SL_INTERNAL_ERROR; + return NULL; + } + + sls->ref_count++; +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + return s; +} + +static void free_sls_string (SLstring_Type *sls, char *s, unsigned int len, + unsigned long hash) +{ + SLstring_Type *sls1, *prev; + +#if _SLANG_OPTIMIZE_FOR_SPEED + uncache_string (s); +#else + (void) s; +#endif + + hash = hash % SLSTRING_HASH_TABLE_SIZE; + + sls1 = String_Hash_Table [(unsigned int) hash]; + + prev = NULL; + + /* This should not fail. */ + while (sls1 != sls) + { + prev = sls1; + sls1 = sls1->next; + } + + if (prev != NULL) + prev->next = sls->next; + else + String_Hash_Table [(unsigned int) hash] = sls->next; + + free_sls (sls, len); +} + +_INLINE_ +static void free_long_string (char *s, unsigned int len, unsigned long hash) +{ + SLstring_Type *sls; + + if (NULL == (sls = find_slstring (s, hash))) + { + SLang_doerror ("Application internal error: invalid attempt to free string"); + return; + } + + sls->ref_count--; + if (sls->ref_count != 0) + { +#if _SLANG_OPTIMIZE_FOR_SPEED + /* cache_string (sls, len, hash); */ +#endif + return; + } + + + free_sls_string (sls, s, len, hash); +} + +/* This routine may be passed NULL-- it is not an error. */ +void SLang_free_slstring (char *s) +{ + unsigned long hash; + unsigned int len; +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + SLstring_Type *sls; + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + { + if (sls->ref_count <= 1) + free_sls_string (sls, s, cs->len, cs->hash); + else + sls->ref_count -= 1; + return; + } +#endif + + if (s == NULL) return; + + if ((len = strlen (s)) < 2) + return; + + hash = _SLstring_hash ((unsigned char *)s, (unsigned char *) s + len); + free_long_string (s, len, hash); +} + +char *SLang_create_slstring (char *s) +{ + unsigned long hash; +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + SLstring_Type *sls; + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + { + sls->ref_count += 1; + return s; + } +#endif + + if (s == NULL) return NULL; + return create_nstring (s, strlen (s), &hash); +} + +void _SLfree_hashed_string (char *s, unsigned int len, unsigned long hash) +{ + if ((s == NULL) || (len < 2)) return; + free_long_string (s, len, hash); +} + + +char *_SLallocate_slstring (unsigned int len) +{ + SLstring_Type *sls = allocate_sls (len); + if (sls == NULL) + return NULL; + + return sls->bytes; +} + +void _SLunallocate_slstring (char *s, unsigned int len) +{ + SLstring_Type *sls; + + if (s == NULL) + return; + + sls = (SLstring_Type *) (s - offsetof(SLstring_Type,bytes[0])); + free_sls (sls, len); +} + +char *_SLcreate_via_alloced_slstring (char *s, unsigned int len) +{ + unsigned long hash; + SLstring_Type *sls; + + if (s == NULL) + return NULL; + + if (len < 2) + { + char *s1 = create_short_string (s, len); + _SLunallocate_slstring (s, len); + return s1; + } + + /* s is not going to be in the cache because when it was malloced, its + * value was unknown. This simplifies the coding. + */ + hash = _SLstring_hash ((unsigned char *)s, (unsigned char *)s + len); + sls = find_string (s, len, hash); + if (sls != NULL) + { + sls->ref_count++; + _SLunallocate_slstring (s, len); + s = sls->bytes; + +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + return s; + } + + sls = (SLstring_Type *) (s - offsetof(SLstring_Type,bytes[0])); + sls->ref_count = 1; + +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + + hash = hash % SLSTRING_HASH_TABLE_SIZE; + sls->next = String_Hash_Table [(unsigned int)hash]; + String_Hash_Table [(unsigned int)hash] = sls; + + return s; +} + +/* Note, a and b may be ordinary strings. The result is an slstring */ +char *SLang_concat_slstrings (char *a, char *b) +{ + unsigned int lena, len; + char *c; + + lena = strlen (a); + len = lena + strlen (b); + + c = _SLallocate_slstring (len); + if (c == NULL) + return NULL; + + strcpy (c, a); + strcpy (c + lena, b); + + return _SLcreate_via_alloced_slstring (c, len); +} + diff --git a/libslang/src/slstrops.c b/libslang/src/slstrops.c new file mode 100644 index 0000000..eca73e4 --- /dev/null +++ b/libslang/src/slstrops.c @@ -0,0 +1,1690 @@ +/* -*- mode: C; mode: fold; -*- */ +/* string manipulation functions for S-Lang. */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" +/*{{{ Include Files */ + +#include + +#ifndef __QNX__ +# if defined(__GO32__) || defined(__WATCOMC__) +# include +# include +# endif +#endif + +#if SLANG_HAS_FLOAT +#include +#endif + +#include +#include +#include + +#ifndef isdigit +# define isdigit(x) (((x) >= '0') && ((x) <= '9')) +#endif + +#include "slang.h" +#include "_slang.h" + +/*}}}*/ + +#define USE_ALLOC_STSTRING 1 + +/*{{{ Utility Functions */ + +static unsigned char Utility_Char_Table [256]; +static unsigned char WhiteSpace_Lut[256]; + +static void set_utility_char_table (char *pos) /*{{{*/ +{ + register unsigned char *t = Utility_Char_Table; + register unsigned char ch; + + memset ((char *) t, 0, sizeof (Utility_Char_Table)); + while ((ch = (unsigned char) *pos++) != 0) t[ch] = 1; +} + +/*}}}*/ + +_INLINE_ +static unsigned char *make_whitespace_lut (void) +{ + if (WhiteSpace_Lut[' '] != 1) + { + WhiteSpace_Lut[' '] = WhiteSpace_Lut['\r'] + = WhiteSpace_Lut ['\n'] = WhiteSpace_Lut['\t'] + = WhiteSpace_Lut ['\f'] = 1; + } + return WhiteSpace_Lut; +} + +static unsigned char *make_lut (unsigned char *s, unsigned char *lut) +{ + int reverse = 0; + + if (*s == '^') + { + reverse = 1; + s++; + } + SLmake_lut (lut, s, reverse); + return lut; +} + +static unsigned int do_trim (char **beg, int do_beg, + char **end, int do_end, + char *white) /*{{{*/ +{ + unsigned int len; + char *a, *b; + unsigned char *lut; + + if (white == NULL) + lut = make_whitespace_lut (); + else + { + set_utility_char_table (white); + lut = Utility_Char_Table; + } + + a = *beg; + len = strlen (a); + b = a + len; + + if (do_beg) + while (lut[(unsigned char) *a]) a++; + + if (do_end) + { + b--; + while ((b >= a) && (lut[(unsigned char) *b])) b--; + b++; + } + + len = (unsigned int) (b - a); + *beg = a; + *end = b; + return len; +} + +/*}}}*/ + +/*}}}*/ + +static int pop_3_strings (char **a, char **b, char **c) +{ + *a = *b = *c = NULL; + if (-1 == SLpop_string (c)) + return -1; + + if (-1 == SLpop_string (b)) + { + SLfree (*c); + *c = NULL; + return -1; + } + + if (-1 == SLpop_string (a)) + { + SLfree (*b); + SLfree (*c); + *b = *c = NULL; + return -1; + } + + return 0; +} + +static void free_3_strings (char *a, char *b, char *c) +{ + SLfree (a); + SLfree (b); + SLfree (c); +} + +static void strcat_cmd (void) /*{{{*/ +{ + char *c, *c1; + int nargs; + int i; + char **ptrs; + unsigned int len; +#if !USE_ALLOC_STSTRING + char buf[256]; +#endif + nargs = SLang_Num_Function_Args; + if (nargs <= 0) nargs = 2; + + if (NULL == (ptrs = (char **)SLmalloc (nargs * sizeof (char *)))) + return; + + memset ((char *) ptrs, 0, sizeof (char *) * nargs); + + c = NULL; + i = nargs; + len = 0; + while (i != 0) + { + char *s; + + i--; + if (-1 == SLang_pop_slstring (&s)) + goto free_and_return; + ptrs[i] = s; + len += strlen (s); + } +#if USE_ALLOC_STSTRING + if (NULL == (c = _SLallocate_slstring (len))) + goto free_and_return; +#else + len++; /* \0 char */ + if (len <= sizeof (buf)) + c = buf; + else if (NULL == (c = SLmalloc (len))) + goto free_and_return; +#endif + + c1 = c; + for (i = 0; i < nargs; i++) + { + strcpy (c1, ptrs[i]); + c1 += strlen (c1); + } + + free_and_return: + for (i = 0; i < nargs; i++) + SLang_free_slstring (ptrs[i]); + SLfree ((char *) ptrs); + +#if USE_ALLOC_STSTRING + (void) _SLpush_alloced_slstring (c, len); +#else + if (c != buf) + (void) SLang_push_malloced_string (c); /* NULL ok */ + else + (void) SLang_push_string (c); +#endif +} + +/*}}}*/ + +static int _SLang_push_nstring (char *a, unsigned int len) +{ + a = SLang_create_nslstring (a, len); + if (a == NULL) + return -1; + + return _SLang_push_slstring (a); +} + + +static void strtrim_cmd_internal (char *str, int do_beg, int do_end) +{ + char *beg, *end, *white; + int free_str; + unsigned int len; + + /* Go through SLpop_string to get a private copy since it will be + * modified. + */ + + free_str = 0; + if (SLang_Num_Function_Args == 2) + { + white = str; + if (-1 == SLang_pop_slstring (&str)) + return; + free_str = 1; + } + else white = NULL; + + beg = str; + len = do_trim (&beg, do_beg, &end, do_end, white); + + (void) _SLang_push_nstring (beg, len); + if (free_str) + SLang_free_slstring (str); +} + + +static void strtrim_cmd (char *str) +{ + strtrim_cmd_internal (str, 1, 1); +} + +static void strtrim_beg_cmd (char *str) +{ + strtrim_cmd_internal (str, 1, 0); +} + +static void strtrim_end_cmd (char *str) +{ + strtrim_cmd_internal (str, 0, 1); +} + + +static void strcompress_cmd (void) /*{{{*/ +{ + char *str, *white, *c; + unsigned char *s, *beg, *end; + unsigned int len; + char pref_char; + + if (SLpop_string (&white)) return; + if (SLpop_string (&str)) + { + SLfree (white); + return; + } + + /* The first character of white is the preferred whitespace character */ + pref_char = *white; + + beg = (unsigned char *) str; + (void) do_trim ((char **) &beg, 1, (char **) &end, 1, white); + SLfree (white); + + /* Determine the effective length */ + len = 0; + s = (unsigned char *) beg; + while (s < end) + { + len++; + if (Utility_Char_Table[*s++]) + { + while ((s < end) && Utility_Char_Table[*s]) s++; + } + } + +#if USE_ALLOC_STSTRING + c = _SLallocate_slstring (len); +#else + c = SLmalloc (len + 1); +#endif + if (c == NULL) + { + SLfree (str); + return; + } + + s = (unsigned char *) c; + + while (beg < end) + { + unsigned char ch = *beg++; + + if (0 == Utility_Char_Table[ch]) + { + *s++ = ch; + continue; + } + + *s++ = (unsigned char) pref_char; + + while ((beg < end) && Utility_Char_Table[*beg]) + beg++; + } + + *s = 0; + +#if USE_ALLOC_STSTRING + (void) _SLpush_alloced_slstring (c, len); +#else + SLang_push_malloced_string(c); +#endif + + SLfree(str); +} + +/*}}}*/ + +static int str_replace_cmd_1 (char *orig, char *match, char *rep, unsigned int max_num_replaces, + char **new_strp) /*{{{*/ +{ + char *s, *t, *new_str; + unsigned int rep_len, match_len, new_len; + unsigned int num_replaces; + + *new_strp = NULL; + + match_len = strlen (match); + + if (match_len == 0) + return 0; + + num_replaces = 0; + s = orig; + while (num_replaces < max_num_replaces) + { + s = strstr (s, match); + if (s == NULL) + break; + s += match_len; + num_replaces++; + } + + if (num_replaces == 0) + return 0; + + max_num_replaces = num_replaces; + + rep_len = strlen (rep); + + new_len = (strlen (orig) - num_replaces * match_len) + num_replaces * rep_len; + new_str = SLmalloc (new_len + 1); + if (new_str == NULL) + return -1; + + s = orig; + t = new_str; + + for (num_replaces = 0; num_replaces < max_num_replaces; num_replaces++) + { + char *next_s; + unsigned int len; + + next_s = strstr (s, match); /* cannot be NULL */ + len = (unsigned int) (next_s - s); + strncpy (t, s, len); + t += len; + strcpy (t, rep); + t += rep_len; + + s = next_s + match_len; + } + strcpy (t, s); + *new_strp = new_str; + + return (int) num_replaces; +} + +/*}}}*/ + +static void reverse_string (char *a) +{ + char *b; + + b = a + strlen (a); + while (b > a) + { + char ch; + + b--; + ch = *a; + *a++ = *b; + *b = ch; + } +} + +static int strreplace_cmd (int *np) +{ + char *orig, *match, *rep; + char *new_str; + int max_num_replaces; + int ret; + + max_num_replaces = *np; + + if (-1 == pop_3_strings (&orig, &match, &rep)) + return -1; + + if (max_num_replaces < 0) + { + reverse_string (orig); + reverse_string (match); + reverse_string (rep); + ret = str_replace_cmd_1 (orig, match, rep, -max_num_replaces, &new_str); + if (ret > 0) reverse_string (new_str); + else if (ret == 0) + reverse_string (orig); + } + else ret = str_replace_cmd_1 (orig, match, rep, max_num_replaces, &new_str); + + if (ret == 0) + { + if (-1 == SLang_push_malloced_string (orig)) + ret = -1; + orig = NULL; + } + else if (ret > 0) + { + if (-1 == SLang_push_malloced_string (new_str)) + ret = -1; + } + + free_3_strings (orig, match, rep); + return ret; +} + +static int str_replace_cmd (char *orig, char *match, char *rep) +{ + char *s; + int ret; + + ret = str_replace_cmd_1 (orig, match, rep, 1, &s); + if (ret == 1) + (void) SLang_push_malloced_string (s); + return ret; +} + + + +static void strtok_cmd (char *str) +{ + _SLString_List_Type sl; + unsigned char white_buf[256]; + char *s; + unsigned char *white; + + if (SLang_Num_Function_Args == 1) + white = make_whitespace_lut (); + else + { + white = white_buf; + make_lut ((unsigned char *)str, white); + if (-1 == SLang_pop_slstring (&str)) + return; + } + + if (-1 == _SLstring_list_init (&sl, 256, 1024)) + goto the_return; + + s = str; + while (*s != 0) + { + char *s0; + + s0 = s; + /* Skip whitespace */ + while ((*s0 != 0) && (0 != white[(unsigned char)*s0])) + s0++; + + if (*s0 == 0) + break; + + s = s0; + while ((*s != 0) && (0 == white[(unsigned char) *s])) + s++; + + /* sl deleted upon failure */ + if (-1 == _SLstring_list_append (&sl, SLang_create_nslstring (s0, (unsigned int) (s - s0)))) + goto the_return; + } + + /* Deletes sl */ + (void) _SLstring_list_push (&sl); + + the_return: + if (white == white_buf) + SLang_free_slstring (str); +} + +/* This routine returns the string with text removed between single character + comment delimiters from the set b and e. */ + +static void str_uncomment_string_cmd (char *str, char *b, char *e) /*{{{*/ +{ + unsigned char chb, che; + unsigned char *s, *cbeg, *mark; + + if (strlen(b) != strlen(e)) + { + SLang_doerror ("Comment delimiter length mismatch."); + return; + } + + set_utility_char_table (b); + + if (NULL == (str = (char *) SLmake_string(str))) return; + + s = (unsigned char *) str; + + while ((chb = *s++) != 0) + { + if (Utility_Char_Table [chb] == 0) continue; + + mark = s - 1; + + cbeg = (unsigned char *) b; + while (*cbeg != chb) cbeg++; + + che = (unsigned char) *(e + (int) (cbeg - (unsigned char *) b)); + + while (((chb = *s++) != 0) && (chb != che)); + + if (chb == 0) + { + /* end of string and end not found. Just truncate it a return; */ + *mark = 0; + break; + } + + strcpy ((char *) mark, (char *)s); + s = mark; + } + SLang_push_malloced_string (str); +} + +/*}}}*/ + +static void str_quote_string_cmd (char *str, char *quotes, int *slash_ptr) /*{{{*/ +{ + char *q; + int slash; + unsigned int len; + char *s, *q1; + unsigned char ch; + unsigned char *t; + + slash = *slash_ptr; + + if ((slash > 255) || (slash < 0)) + { + SLang_Error = SL_INVALID_PARM; + return; + } + + /* setup the utility table to have 1s at quote char postitions. */ + set_utility_char_table (quotes); + + t = Utility_Char_Table; + t[(unsigned int) slash] = 1; + + /* calculate length */ + s = str; + len = 0; + while ((ch = (unsigned char) *s++) != 0) if (t[ch]) len++; + len += (unsigned int) (s - str); + + if (NULL != (q = SLmalloc(len))) + { + s = str; q1 = q; + while ((ch = (unsigned char) *s++) != 0) + { + if (t[ch]) *q1++ = slash; + *q1++ = (char) ch; + } + *q1 = 0; + SLang_push_malloced_string(q); + } +} + +/*}}}*/ + +/* returns the position of substrin in a string or null */ +static int issubstr_cmd (char *a, char *b) /*{{{*/ +{ + char *c; + + if (NULL == (c = (char *) strstr(a, b))) + return 0; + + return 1 + (int) (c - a); +} + +/*}}}*/ + +/* returns to stack string at pos n to n + m of a */ +static void substr_cmd (char *a, int *n_ptr, int *m_ptr) /*{{{*/ +{ + int n, m; + int lena; + + n = *n_ptr; + m = *m_ptr; + + lena = strlen (a); + if (n > lena) n = lena + 1; + if (n < 1) + { + SLang_Error = SL_INVALID_PARM; + return; + } + + n--; + if (m < 0) m = lena; + if (n + m > lena) m = lena - n; + + (void) _SLang_push_nstring (a + n, (unsigned int) m); +} + +/*}}}*/ + +/* substitute char m at positin string n in string*/ +static void strsub_cmd (int *nptr, int *mptr) /*{{{*/ +{ + char *a; + int n, m; + unsigned int lena; + + if (-1 == SLpop_string (&a)) + return; + + n = *nptr; + m = *mptr; + + lena = strlen (a); + + if ((n <= 0) || (lena < (unsigned int) n)) + { + SLang_Error = SL_INVALID_PARM; + SLfree(a); + return; + } + + a[n - 1] = (char) m; + + SLang_push_malloced_string (a); +} + +/*}}}*/ + +static void strup_cmd(void) /*{{{*/ +{ + unsigned char c, *a; + char *str; + + if (SLpop_string (&str)) + return; + + a = (unsigned char *) str; + while ((c = *a) != 0) + { + /* if ((*a >= 'a') && (*a <= 'z')) *a -= 32; */ + *a = UPPER_CASE(c); + a++; + } + + SLang_push_malloced_string (str); +} + +/*}}}*/ + +static int isdigit_cmd (char *what) /*{{{*/ +{ + return isdigit((unsigned char)*what); +} + +/*}}}*/ +static int toupper_cmd (int *ch) /*{{{*/ +{ + return UPPER_CASE(*ch); +} + +/*}}}*/ + +static int tolower_cmd (int *ch) /*{{{*/ +{ + return LOWER_CASE(*ch); +} + +/*}}}*/ + +static void strlow_cmd (void) /*{{{*/ +{ + unsigned char c, *a; + char *str; + + if (SLpop_string(&str)) return; + a = (unsigned char *) str; + while ((c = *a) != 0) + { + /* if ((*a >= 'a') && (*a <= 'z')) *a -= 32; */ + *a = LOWER_CASE(c); + a++; + } + + SLang_push_malloced_string ((char *) str); +} + +/*}}}*/ + +static SLang_Array_Type *do_strchop (char *str, int delim, int quote) +{ + int count; + char *s0, *elm; + register char *s1; + register unsigned char ch; + int quoted; + SLang_Array_Type *at; + char **data; + + if ((quote < 0) || (quote > 255) + || (delim <= 0) || (delim > 255)) + { + SLang_Error = SL_INVALID_PARM; + return NULL; + } + + s1 = s0 = str; + + quoted = 0; + count = 1; /* at least 1 */ + while (1) + { + ch = (unsigned char) *s1++; + if ((ch == quote) && quote) + { + if (*s1 == 0) + break; + + s1++; + continue; + } + + if (ch == delim) + { + count++; + continue; + } + + if (ch == 0) + break; + } + + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &count, 1))) + return NULL; + + data = (char **)at->data; + + count = 0; + s1 = s0; + + while (1) + { + ch = (unsigned char) *s1; + + if ((ch == quote) && quote) + { + s1++; + if (*s1 != 0) s1++; + quoted = 1; + continue; + } + + if ((ch == delim) || (ch == 0)) + { + if (quoted == 0) + elm = SLang_create_nslstring (s0, (unsigned int) (s1 - s0)); + else + { + register char ch1, *p, *p1; + char *tmp; + + tmp = SLmake_nstring (s0, (unsigned int)(s1 - s0)); + if (tmp == NULL) + break; + + /* Now unquote it */ + p = p1 = tmp; + do + { + ch1 = *p1++; + if (ch1 == '\\') ch1 = *p1++; + *p++ = ch1; + } + while (ch1 != 0); + quoted = 0; + + elm = SLang_create_slstring (tmp); + SLfree (tmp); + } + + if (elm == NULL) + break; + + data[count] = elm; + count++; + + if (ch == 0) + return at; + + s1++; /* skip past delim */ + s0 = s1; /* and reset */ + } + else s1++; + } + + SLang_free_array (at); + return NULL; +} + +static void strchop_cmd (char *str, int *q, int *d) +{ + (void) SLang_push_array (do_strchop (str, *q, *d), 1); +} + +static void strchopr_cmd (char *str, int *q, int *d) +{ + SLang_Array_Type *at; + + if (NULL != (at = do_strchop (str, *q, *d))) + { + char **d0, **d1; + + d0 = (char **) at->data; + d1 = d0 + (at->num_elements - 1); + + while (d0 < d1) + { + char *tmp; + + tmp = *d0; + *d0 = *d1; + *d1 = tmp; + d0++; + d1--; + } + } + SLang_push_array (at, 1); +} + +static int strcmp_cmd (char *a, char *b) /*{{{*/ +{ + return strcmp(a, b); +} + +/*}}}*/ + +static int strncmp_cmd (char *a, char *b, int *n) /*{{{*/ +{ + return strncmp(a, b, (unsigned int) *n); +} + +/*}}}*/ + +static int strlen_cmd (char *s) /*{{{*/ +{ + return (int) strlen (s); +} +/*}}}*/ + +static void extract_element_cmd (char *list, int *nth_ptr, int *delim_ptr) +{ + char buf[1024], *b; + + b = buf; + if (-1 == SLextract_list_element (list, *nth_ptr, *delim_ptr, buf, sizeof(buf))) + b = NULL; + + SLang_push_string (b); +} + +/* sprintf functionality for S-Lang */ + +static char *SLdo_sprintf (char *fmt) /*{{{*/ +{ + register char *p = fmt, ch; + char *out = NULL, *outp = NULL; + char dfmt[1024]; /* used to hold part of format */ + char *f; + VOID_STAR varp; + int want_width, width, precis, use_varp, int_var; + long long_var; + unsigned int len = 0, malloc_len = 0, dlen; + int do_free, guess_size; +#if SLANG_HAS_FLOAT + int tmp1, tmp2, use_double; + double x; +#endif + int use_long = 0; + + while (1) + { + while ((ch = *p) != 0) + { + if (ch == '%') + break; + p++; + } + + /* p points at '%' or 0 */ + + dlen = (unsigned int) (p - fmt); + + if (len + dlen >= malloc_len) + { + malloc_len = len + dlen; + if (out == NULL) outp = SLmalloc(malloc_len + 1); + else outp = SLrealloc(out, malloc_len + 1); + if (NULL == outp) + return out; + out = outp; + outp = out + len; + } + + strncpy(outp, fmt, dlen); + len += dlen; + outp = out + len; + *outp = 0; + if (ch == 0) break; + + /* bump it beyond '%' */ + ++p; + fmt = p; + + f = dfmt; + *f++ = ch; + /* handle flag char */ + ch = *p++; + + /* Make sure cases such as "% #g" can be handled. */ + if ((ch == '-') || (ch == '+') || (ch == ' ') || (ch == '#')) + { + *f++ = ch; + ch = *p++; + if ((ch == '-') || (ch == '+') || (ch == ' ') || (ch == '#')) + { + *f++ = ch; + ch = *p++; + } + } + + + /* width */ + /* I have got to parse it myself so that I can see how big it needs + * to be. + */ + want_width = width = 0; + if (ch == '*') + { + if (SLang_pop_integer(&width)) return (out); + want_width = 1; + ch = *p++; + } + else + { + if (ch == '0') + { + *f++ = '0'; + ch = *p++; + } + + while ((ch <= '9') && (ch >= '0')) + { + width = width * 10 + (ch - '0'); + ch = *p++; + want_width = 1; + } + } + + if (want_width) + { + sprintf(f, "%d", width); + f += strlen (f); + } + precis = 0; + /* precision -- also indicates max number of chars from string */ + if (ch == '.') + { + *f++ = ch; + ch = *p++; + want_width = 0; + if (ch == '*') + { + if (SLang_pop_integer(&precis)) return (out); + ch = *p++; + want_width = 1; + } + else while ((ch <= '9') && (ch >= '0')) + { + precis = precis * 10 + (ch - '0'); + ch = *p++; + want_width = 1; + } + if (want_width) + { + sprintf(f, "%d", precis); + f += strlen (f); + } + else precis = 0; + } + + long_var = 0; + int_var = 0; + varp = NULL; + guess_size = 32; +#if SLANG_HAS_FLOAT + use_double = 0; +#endif + use_long = 0; + use_varp = 0; + do_free = 0; + + if (ch == 'l') + { + use_long = 1; + ch = *p++; + } + else if (ch == 'h') ch = *p++; /* not supported */ + + /* Now the actual format specifier */ + switch (ch) + { + case 'S': + _SLstring_intrinsic (); + ch = 's'; + /* drop */ + case 's': + if (SLang_pop_slstring((char **) &varp)) return (out); + do_free = 1; + guess_size = strlen((char *) varp); + use_varp = 1; + break; + + case '%': + guess_size = 1; + do_free = 0; + use_varp = 1; + varp = (VOID_STAR) "%"; + break; + + case 'c': guess_size = 1; + use_long = 0; + /* drop */ + case 'd': + case 'i': + case 'o': + case 'u': + case 'X': + case 'x': + if (SLang_pop_long (&long_var)) return(out); + if (use_long == 0) + int_var = (int) long_var; + else + *f++ = 'l'; + break; + + case 'f': + case 'e': + case 'g': + case 'E': + case 'G': +#if SLANG_HAS_FLOAT + if (SLang_pop_double(&x, &tmp1, &tmp2)) return (out); + use_double = 1; + guess_size = 256; + (void) tmp1; (void) tmp2; + use_long = 0; + break; +#endif + case 'p': + guess_size = 32; + /* Pointer type?? Why?? */ + if (-1 == SLdo_pop ()) + return out; + varp = (VOID_STAR) _SLang_get_run_stack_pointer (); + use_varp = 1; + use_long = 0; + break; + + default: + SLang_doerror("Invalid Format."); + return(out); + } + *f++ = ch; *f = 0; + + width = width + precis; + if (width > guess_size) guess_size = width; + + if (len + guess_size > malloc_len) + { + outp = (char *) SLrealloc(out, len + guess_size + 1); + if (outp == NULL) + { + SLang_Error = SL_MALLOC_ERROR; + return (out); + } + out = outp; + outp = out + len; + malloc_len = len + guess_size; + } + + if (use_varp) + { + sprintf(outp, dfmt, varp); + if (do_free) SLang_free_slstring ((char *)varp); + } +#if SLANG_HAS_FLOAT + else if (use_double) sprintf(outp, dfmt, x); +#endif + else if (use_long) sprintf (outp, dfmt, long_var); + else sprintf(outp, dfmt, int_var); + + len += strlen(outp); + outp = out + len; + fmt = p; + } + + if (out != NULL) + { + outp = SLrealloc (out, (unsigned int) (outp - out) + 1); + if (outp != NULL) out = outp; + } + + return (out); +} + +/*}}}*/ + +int _SLstrops_do_sprintf_n (int n) /*{{{*/ +{ + char *p; + char *fmt; + SLang_Object_Type *ptr; + int ofs; + + if (-1 == (ofs = SLreverse_stack (n + 1))) + return -1; + + ptr = _SLang_get_run_stack_base () + ofs; + + if (SLang_pop_slstring(&fmt)) + return -1; + + p = SLdo_sprintf (fmt); + SLang_free_slstring (fmt); + + SLdo_pop_n (_SLang_get_run_stack_pointer () - ptr); + + if (SLang_Error) + { + SLfree (p); + return -1; + } + + return SLang_push_malloced_string (p); +} + +/*}}}*/ + +static void sprintf_n_cmd (int *n) +{ + _SLstrops_do_sprintf_n (*n); +} + +static void sprintf_cmd (void) +{ + _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 1); /* do not include format */ +} + +/* converts string s to a form that can be used in an eval */ +static void make_printable_string(char *s) /*{{{*/ +{ + unsigned int len; + register char *s1 = s, ch, *ss1; + char *ss; + + /* compute length */ + len = 3; + while ((ch = *s1++) != 0) + { + if ((ch == '\n') || (ch == '\\') || (ch == '"')) len++; + len++; + } + + if (NULL == (ss = SLmalloc(len))) + return; + + s1 = s; + ss1 = ss; + *ss1++ = '"'; + while ((ch = *s1++) != 0) + { + if (ch == '\n') + { + ch = 'n'; + *ss1++ = '\\'; + } + else if ((ch == '\\') || (ch == '"')) + { + *ss1++ = '\\'; + } + *ss1++ = ch; + } + *ss1++ = '"'; + *ss1 = 0; + if (-1 == SLang_push_string (ss)) + SLfree (ss); +} + +/*}}}*/ + +static int is_list_element_cmd (char *list, char *elem, int *d_ptr) +{ + char ch; + int d, n; + unsigned int len; + char *lbeg, *lend; + + d = *d_ptr; + + len = strlen (elem); + + n = 1; + lend = list; + + while (1) + { + lbeg = lend; + while ((0 != (ch = *lend)) && (ch != (char) d)) lend++; + + if ((lbeg + len == lend) + && (0 == strncmp (elem, lbeg, len))) + break; + + if (ch == 0) + { + n = 0; + break; + } + lend++; /* skip delim */ + n++; + } + + return n; +} + +/*}}}*/ + +/* Regular expression routines for strings */ +static SLRegexp_Type regexp_reg; + +static int string_match_cmd (char *str, char *pat, int *nptr) /*{{{*/ +{ + int n; + unsigned int len; + unsigned char rbuf[512], *match; + + n = *nptr; + + regexp_reg.case_sensitive = 1; + regexp_reg.buf = rbuf; + regexp_reg.pat = (unsigned char *) pat; + regexp_reg.buf_len = sizeof (rbuf); + + if (SLang_regexp_compile (®exp_reg)) + { + SLang_verror (SL_INVALID_PARM, "Unable to compile pattern"); + return -1; + } + + n--; + len = strlen(str); + if ((n < 0) || ((unsigned int) n > len)) + { + /* SLang_Error = SL_INVALID_PARM; */ + return 0; + } + + str += n; + len -= n; + + if (NULL == (match = SLang_regexp_match((unsigned char *) str, len, ®exp_reg))) + return 0; + + /* adjust offsets */ + regexp_reg.offset = n; + + return (1 + (int) ((char *) match - str)); +} + +/*}}}*/ + +static int string_match_nth_cmd (int *nptr) /*{{{*/ +{ + int n, beg; + + n = *nptr; + + if ((n < 0) || (n > 9) || (regexp_reg.pat == NULL) + || ((beg = regexp_reg.beg_matches[n]) == -1)) + { + SLang_Error = SL_INVALID_PARM; + return -1; + } + SLang_push_integer(beg + regexp_reg.offset); + return regexp_reg.end_matches[n]; +} + +/*}}}*/ + +static char *create_delimited_string (char **list, unsigned int n, + char *delim) +{ + unsigned int len, dlen; + unsigned int i; + unsigned int num; + char *str, *s; + + len = 1; /* allow room for \0 char */ + num = 0; + for (i = 0; i < n; i++) + { + if (list[i] == NULL) continue; + len += strlen (list[i]); + num++; + } + + dlen = strlen (delim); + if (num > 1) + len += (num - 1) * dlen; + + if (NULL == (str = SLmalloc (len))) + return NULL; + + *str = 0; + s = str; + i = 0; + + while (num > 1) + { + while (list[i] == NULL) + i++; + + strcpy (s, list[i]); + s += strlen (list[i]); + strcpy (s, delim); + s += dlen; + i++; + num--; + } + + if (num) + { + while (list[i] == NULL) + i++; + + strcpy (s, list[i]); + } + + return str; +} + +static void create_delimited_string_cmd (int *nptr) +{ + unsigned int n, i; + char **strings; + char *str; + + str = NULL; + + n = 1 + (unsigned int) *nptr; /* n includes delimiter */ + + if (NULL == (strings = (char **)SLmalloc (n * sizeof (char *)))) + { + SLdo_pop_n (n); + return; + } + memset((char *)strings, 0, n * sizeof (char *)); + + i = n; + while (i != 0) + { + i--; + if (-1 == SLang_pop_slstring (strings + i)) + goto return_error; + } + + str = create_delimited_string (strings + 1, (n - 1), strings[0]); + /* drop */ + return_error: + for (i = 0; i < n; i++) SLang_free_slstring (strings[i]); + SLfree ((char *)strings); + + (void) SLang_push_malloced_string (str); /* NULL Ok */ +} + +static void strjoin_cmd (char *delim) +{ + SLang_Array_Type *at; + char *str; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE)) + return; + + str = create_delimited_string ((char **)at->data, at->num_elements, delim); + SLang_free_array (at); + (void) SLang_push_malloced_string (str); /* NULL Ok */ +} + +static void str_delete_chars_cmd (char *s, char *d) +{ + unsigned char lut[256]; + unsigned char *s1, *s2; + unsigned char ch; + + make_lut ((unsigned char *)d, lut); + if (NULL == (s = SLmake_string (s))) + return; + + s1 = s2 = (unsigned char *) s; + while ((ch = *s2++) != 0) + { + if (0 == lut[ch]) + *s1++ = ch; + } + *s1 = 0; + + (void) SLang_push_malloced_string (s); +} + +static unsigned char *make_lut_string (unsigned char *s) +{ + unsigned char lut[256]; + unsigned char *l; + unsigned int i; + + /* Complement-- a natural order is imposed */ + make_lut (s, lut); + l = lut; + for (i = 1; i < 256; i++) + { + if (lut[i]) + *l++ = (unsigned char) i; + } + *l = 0; + return (unsigned char *) SLmake_string ((char *)lut); +} + +static unsigned char *make_str_range (unsigned char *s) +{ + unsigned char *s1, *range; + unsigned int num; + unsigned char ch; + int len; + + if (*s == '^') + return make_lut_string (s); + + num = 0; + s1 = s; + while ((ch = *s1++) != 0) + { + unsigned char ch1; + + ch1 = *s1; + if (ch1 == '-') + { + s1++; + ch1 = *s1; + len = (int)ch1 - (int)ch; + if (len < 0) + len = -len; + + num += (unsigned int) len; + if (ch1 != 0) + s1++; + } + + num++; + } + + range = (unsigned char *)SLmalloc (num + 1); + if (range == NULL) + return NULL; + + s1 = s; + s = range; + while ((ch = *s1++) != 0) + { + unsigned char ch1; + unsigned int i; + + ch1 = *s1; + if (ch1 != '-') + { + *s++ = ch; + continue; + } + + s1++; + ch1 = *s1; + + if (ch > ch1) + { + if (ch1 == 0) + ch1 = 1; + + for (i = (unsigned int) ch; i >= (unsigned int) ch1; i--) + *s++ = (unsigned char) i; + + if (*s1 == 0) + break; + } + else + { + for (i = (unsigned int) ch; i <= (unsigned int) ch1; i++) + *s++ = (unsigned char) i; + } + s1++; + } + +#if 0 + if (range + num != s) + SLang_verror (SL_INTERNAL_ERROR, "make_str_range: num wrong"); +#endif + *s = 0; + + return range; +} + +static void strtrans_cmd (char *s, unsigned char *from, unsigned char *to) +{ + unsigned char map[256]; + char *s1; + unsigned int i; + unsigned char ch; + unsigned char last_to; + unsigned char *from_range, *to_range; + + for (i = 0; i < 256; i++) map[i] = (unsigned char) i; + + if (*to == 0) + { + str_delete_chars_cmd (s, (char *)from); + return; + } + + from_range = make_str_range (from); + if (from_range == NULL) + return; + to_range = make_str_range (to); + if (to_range == NULL) + { + SLfree ((char *)from_range); + return; + } + + from = from_range; + to = to_range; + + last_to = 0; + while ((ch = *from++) != 0) + { + unsigned char to_ch; + + if (0 == (to_ch = *to++)) + { + do + { + map[ch] = last_to; + } + while (0 != (ch = *from++)); + break; + } + + last_to = map[ch] = to_ch; + } + + SLfree ((char *)from_range); + SLfree ((char *)to_range); + + s = SLmake_string (s); + if (s == NULL) + return; + + s1 = s; + while ((ch = (unsigned char) *s1) != 0) + *s1++ = (char) map[ch]; + + (void) SLang_push_malloced_string (s); +} + + +static SLang_Intrin_Fun_Type Strops_Table [] = /*{{{*/ +{ + MAKE_INTRINSIC_I("create_delimited_string", create_delimited_string_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SS("strcmp", strcmp_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SSI("strncmp", strncmp_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("strcat", strcat_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strlen", strlen_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SII("strchop", strchop_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SII("strchopr", strchopr_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("strreplace", strreplace_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SSS("str_replace", str_replace_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SII("substr", substr_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SS("is_substr", issubstr_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_II("strsub", strsub_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SII("extract_element", extract_element_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SSI("is_list_element", is_list_element_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SSI("string_match", string_match_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("string_match_nth", string_match_nth_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("strlow", strlow_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("tolower", tolower_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("toupper", toupper_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("strup", strup_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("isdigit", isdigit_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("strtrim", strtrim_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strtrim_end", strtrim_end_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strtrim_beg", strtrim_beg_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("strcompress", strcompress_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("Sprintf", sprintf_n_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("sprintf", sprintf_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("sscanf", _SLang_sscanf, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("make_printable_string", make_printable_string, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SSI("str_quote_string", str_quote_string_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SSS("str_uncomment_string", str_uncomment_string_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_II("define_case", SLang_define_case, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strtok", strtok_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strjoin", strjoin_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SSS("strtrans", strtrans_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SS("str_delete_chars", str_delete_chars_cmd, SLANG_VOID_TYPE), + + SLANG_END_INTRIN_FUN_TABLE +}; + +/*}}}*/ + +int _SLang_init_slstrops (void) +{ + return SLadd_intrin_fun_table (Strops_Table, NULL); +} diff --git a/libslang/src/slstruct.c b/libslang/src/slstruct.c new file mode 100644 index 0000000..c81d5bc --- /dev/null +++ b/libslang/src/slstruct.c @@ -0,0 +1,1112 @@ +/* Structure type implementation */ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +/* #define SL_APP_WANTS_FOREACH */ +#include "slang.h" +#include "_slang.h" + +void _SLstruct_delete_struct (_SLang_Struct_Type *s) +{ + _SLstruct_Field_Type *field, *field_max; + + if (s == NULL) return; + + if (s->num_refs > 1) + { + s->num_refs -= 1; + return; + } + + field = s->fields; + if (field != NULL) + { + field_max = field + s->nfields; + + while (field < field_max) + { + SLang_free_object (&field->obj); + SLang_free_slstring (field->name); /* could be NULL */ + field++; + } + SLfree ((char *) s->fields); + } + SLfree ((char *) s); +} + +static _SLang_Struct_Type *allocate_struct (unsigned int nfields) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + unsigned int i, size; + + s = (_SLang_Struct_Type *) SLmalloc (sizeof (_SLang_Struct_Type)); + if (s == NULL) return NULL; + + SLMEMSET((char *) s, 0, sizeof (_SLang_Struct_Type)); + + size = nfields * sizeof(_SLstruct_Field_Type); + if (NULL == (f = (_SLstruct_Field_Type *) SLmalloc (size))) + { + SLfree ((char *) s); + return NULL; + } + SLMEMSET ((char *) f, 0, size); + s->nfields = nfields; + s->fields = f; + + /* By default, all structs will be created with elements set to NULL. I + * do not know whether or not it is better to use SLANG_UNDEFINED_TYPE. + */ + for (i = 0; i < nfields; i++) + f[i].obj.data_type = SLANG_NULL_TYPE; + + return s; +} + +static int push_struct_of_type (unsigned char type, _SLang_Struct_Type *s) +{ + SLang_Object_Type obj; + + obj.data_type = type; + obj.v.struct_val = s; + s->num_refs += 1; + + if (0 == SLang_push (&obj)) + return 0; + + s->num_refs -= 1; + return -1; +} + +int _SLang_push_struct (_SLang_Struct_Type *s) +{ + return push_struct_of_type (SLANG_STRUCT_TYPE, s); +} + +int _SLang_pop_struct (_SLang_Struct_Type **sp) +{ + SLang_Object_Type obj; + SLang_Class_Type *cl; + unsigned char type; + + if (0 != SLang_pop (&obj)) + return -1; + + type = obj.data_type; + if (type != SLANG_STRUCT_TYPE) + { + cl = _SLclass_get_class (type); + if (cl->cl_struct_def == NULL) + { + *sp = NULL; + SLang_free_object (&obj); + SLang_verror (SL_TYPE_MISMATCH, + "Expecting struct type object. Found %s", + cl->cl_name); + return -1; + } + } + + *sp = obj.v.struct_val; + return 0; +} + +static void struct_destroy (unsigned char type, VOID_STAR vs) +{ + (void) type; + _SLstruct_delete_struct (*(_SLang_Struct_Type **) vs); +} + +static int struct_push (unsigned char type, VOID_STAR ptr) +{ + return push_struct_of_type (type, *(_SLang_Struct_Type **) ptr); +} + +static _SLstruct_Field_Type *find_field (_SLang_Struct_Type *s, char *name) +{ + _SLstruct_Field_Type *f, *fmax; + + f = s->fields; + fmax = f + s->nfields; + + while (f < fmax) + { + /* Since both these are slstrings, only compare pointer */ + if (name == f->name) + return f; + + f++; + } + + return NULL; +} + +static _SLstruct_Field_Type *pop_field (_SLang_Struct_Type *s, char *name, + _SLstruct_Field_Type *(*find)(_SLang_Struct_Type *, char *)) +{ + _SLstruct_Field_Type *f; + + f = (*find) (s, name); + if (f == NULL) + SLang_verror (SL_INVALID_PARM, "struct has no field named %s", name); + return f; +} + +static _SLang_Struct_Type * + create_struct (unsigned int nfields, + char **field_names, + unsigned char *field_types, + VOID_STAR *field_values) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + unsigned int i; + + if (NULL == (s = allocate_struct (nfields))) + return NULL; + + f = s->fields; + for (i = 0; i < nfields; i++) + { + unsigned char type; + SLang_Class_Type *cl; + VOID_STAR value; + char *name = field_names [i]; + + if (name == NULL) + { + SLang_verror (SL_APPLICATION_ERROR, "A struct field name cannot be NULL"); + goto return_error; + } + + if (-1 == _SLcheck_identifier_syntax (name)) + goto return_error; + + if (NULL == (f->name = SLang_create_slstring (name))) + goto return_error; + + if ((field_values == NULL) + || (NULL == (value = field_values [i]))) + { + f++; + continue; + } + + type = field_types[i]; + cl = _SLclass_get_class (type); + + if ((-1 == (cl->cl_apush (type, value))) + || (-1 == SLang_pop (&f->obj))) + goto return_error; + + f++; + } + + return s; + + return_error: + _SLstruct_delete_struct (s); + return NULL; +} + +int SLstruct_create_struct (unsigned int nfields, + char **field_names, + unsigned char *field_types, + VOID_STAR *field_values) +{ + _SLang_Struct_Type *s; + + if (NULL == (s = create_struct (nfields, field_names, field_types, field_values))) + return -1; + + if (0 == _SLang_push_struct (s)) + return 0; + + _SLstruct_delete_struct (s); + return -1; +} + +/* Interpreter interface */ + +int _SLstruct_define_struct (void) +{ + int nfields; + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + + if (-1 == SLang_pop_integer (&nfields)) + return -1; + + if (nfields <= 0) + { + SLang_verror (SL_INVALID_PARM, "Number of struct fields must be > 0"); + return -1; + } + + if (NULL == (s = allocate_struct (nfields))) + return -1; + + f = s->fields; + while (nfields) + { + char *name; + + nfields--; + if (-1 == SLang_pop_slstring (&name)) + { + _SLstruct_delete_struct (s); + return -1; + } + f[nfields].name = name; + } + + if (-1 == _SLang_push_struct (s)) + { + _SLstruct_delete_struct (s); + return -1; + } + return 0; +} + +/* Simply make a struct that contains the same fields as struct s. Do not + * duplicate the field values. + */ +static _SLang_Struct_Type *make_struct_shell (_SLang_Struct_Type *s) +{ + _SLang_Struct_Type *new_s; + _SLstruct_Field_Type *new_f, *old_f; + unsigned int i, nfields; + + nfields = s->nfields; + if (NULL == (new_s = allocate_struct (nfields))) + return NULL; + + new_f = new_s->fields; + old_f = s->fields; + + for (i = 0; i < nfields; i++) + { + if (NULL == (new_f[i].name = SLang_create_slstring (old_f[i].name))) + { + _SLstruct_delete_struct (new_s); + return NULL; + } + } + return new_s; +} + +static int struct_init_array_object (unsigned char type, VOID_STAR addr) +{ + SLang_Class_Type *cl; + _SLang_Struct_Type *s; + + cl = _SLclass_get_class (type); + if (NULL == (s = make_struct_shell (cl->cl_struct_def))) + return -1; + + s->num_refs = 1; + *(_SLang_Struct_Type **) addr = s; + return 0; +} + +static int +typedefed_struct_datatype_deref (unsigned char type) +{ + SLang_Class_Type *cl; + _SLang_Struct_Type *s; + + cl = _SLclass_get_class (type); + if (NULL == (s = make_struct_shell (cl->cl_struct_def))) + return -1; + + if (-1 == push_struct_of_type (type, s)) + { + _SLstruct_delete_struct (s); + return -1; + } + + return 0; +} + +static _SLang_Struct_Type *duplicate_struct (_SLang_Struct_Type *s) +{ + _SLang_Struct_Type *new_s; + _SLstruct_Field_Type *new_f, *f, *fmax; + + new_s = make_struct_shell (s); + + if (new_s == NULL) + return NULL; + + f = s->fields; + fmax = f + s->nfields; + new_f = new_s->fields; + + while (f < fmax) + { + SLang_Object_Type *obj; + + obj = &f->obj; + if (obj->data_type != SLANG_UNDEFINED_TYPE) + { + if ((-1 == _SLpush_slang_obj (obj)) + || (-1 == SLang_pop (&new_f->obj))) + { + _SLstruct_delete_struct (new_s); + return NULL; + } + } + new_f++; + f++; + } + + return new_s; +} + +static int struct_dereference (unsigned char type, VOID_STAR addr) +{ + _SLang_Struct_Type *s; + + if (NULL == (s = duplicate_struct (*(_SLang_Struct_Type **) addr))) + return -1; + + if (-1 == push_struct_of_type (type, s)) + { + _SLstruct_delete_struct (s); + return -1; + } + + return 0; +} + +/*{{{ foreach */ + +struct _SLang_Foreach_Context_Type +{ + _SLang_Struct_Type *s; + char *next_field_name; +}; + +static SLang_Foreach_Context_Type * +struct_foreach_open (unsigned char type, unsigned int num) +{ + SLang_Foreach_Context_Type *c; + _SLang_Struct_Type *s; + char *next_name; + + (void) type; + + if (-1 == _SLang_pop_struct (&s)) + return NULL; + + switch (num) + { + case 0: + next_name = SLang_create_slstring ("next"); + break; + + case 1: + if (-1 == SLang_pop_slstring (&next_name)) + next_name = NULL; + break; + + default: + next_name = NULL; + SLang_verror (SL_NOT_IMPLEMENTED, + "'foreach (Struct_Type) using' requires single control value"); + SLdo_pop_n (num); + break; + } + + if (next_name == NULL) + { + _SLstruct_delete_struct (s); + return NULL; + } + + c = (SLang_Foreach_Context_Type *)SLmalloc (sizeof (SLang_Foreach_Context_Type)); + if (c == NULL) + { + _SLstruct_delete_struct (s); + SLang_free_slstring (next_name); + return NULL; + } + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + + c->next_field_name = next_name; + c->s = s; + + return c; +} + +static void struct_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + + SLang_free_slstring (c->next_field_name); + if (c->s != NULL) _SLstruct_delete_struct (c->s); + SLfree ((char *) c); +} + +static int struct_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + _SLstruct_Field_Type *f; + _SLang_Struct_Type *next_s; + + (void) type; + + if (c == NULL) + return -1; + + if (c->s == NULL) + return 0; /* done */ + + if (-1 == _SLang_push_struct (c->s)) + return -1; + + /* Now get the next one ready for the next foreach loop */ + + next_s = NULL; + if (NULL != (f = find_field (c->s, c->next_field_name))) + { + SLang_Class_Type *cl; + + cl = _SLclass_get_class (f->obj.data_type); + /* Note that I cannot simply look for SLANG_STRUCT_TYPE since the + * user may have typedefed another struct type. So, look at the + * class methods. + */ + if (cl->cl_foreach_open == struct_foreach_open) + { + next_s = f->obj.v.struct_val; + next_s->num_refs += 1; + } + } + + _SLstruct_delete_struct (c->s); + c->s = next_s; + + /* keep going */ + return 1; +} + +/*}}}*/ + +static int struct_sput (unsigned char type, char *name) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + SLang_Object_Type obj; + + (void) type; + + if (-1 == _SLang_pop_struct (&s)) + return -1; + + if ((NULL == (f = pop_field (s, name, find_field))) + || (-1 == SLang_pop (&obj))) + { + _SLstruct_delete_struct (s); + return -1; + } + + SLang_free_object (&f->obj); + f->obj = obj; + _SLstruct_delete_struct (s); + return 0; +} + +static int struct_sget (unsigned char type, char *name) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + int ret; + + (void) type; + + if (-1 == _SLang_pop_struct (&s)) + return -1; + + if (NULL == (f = pop_field (s, name, find_field))) + { + _SLstruct_delete_struct (s); + return -1; + } + + ret = _SLpush_slang_obj (&f->obj); + _SLstruct_delete_struct (s); + return ret; +} + +static int struct_typecast + (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + _SLang_Struct_Type **a, **b; + unsigned int i; + + (void) a_type; + (void) b_type; + + a = (_SLang_Struct_Type **) ap; + b = (_SLang_Struct_Type **) bp; + for (i = 0; i < na; i++) + { + b[i] = a[i]; + if (a[i] != NULL) + a[i]->num_refs += 1; + } + + return 1; +} + +int _SLstruct_define_typedef (void) +{ + char *type_name; + _SLang_Struct_Type *s, *s1; + SLang_Class_Type *cl; + + if (-1 == SLang_pop_slstring (&type_name)) + return -1; + + if (-1 == _SLang_pop_struct (&s)) + { + SLang_free_slstring (type_name); + return -1; + } + + if (NULL == (s1 = make_struct_shell (s))) + { + SLang_free_slstring (type_name); + _SLstruct_delete_struct (s); + return -1; + } + + _SLstruct_delete_struct (s); + + if (NULL == (cl = SLclass_allocate_class (type_name))) + { + SLang_free_slstring (type_name); + _SLstruct_delete_struct (s1); + return -1; + } + SLang_free_slstring (type_name); + + cl->cl_struct_def = s1; + cl->cl_init_array_object = struct_init_array_object; + cl->cl_datatype_deref = typedefed_struct_datatype_deref; + cl->cl_destroy = struct_destroy; + cl->cl_push = struct_push; + cl->cl_dereference = struct_dereference; + cl->cl_foreach_open = struct_foreach_open; + cl->cl_foreach_close = struct_foreach_close; + cl->cl_foreach = struct_foreach; + + cl->cl_sget = struct_sget; + cl->cl_sput = struct_sput; + + if (-1 == SLclass_register_class (cl, + SLANG_VOID_TYPE, /* any open slot */ + sizeof (_SLang_Struct_Type), + SLANG_CLASS_TYPE_PTR)) + { + /* FIXME: Priority=low */ + /* There is a memory leak here if this fails... */ + return -1; + } + /* Note: typecast from a user type to a struct type allowed but not the other + * way. + */ + if (-1 == SLclass_add_typecast (cl->cl_data_type, SLANG_STRUCT_TYPE, struct_typecast, 1)) + return -1; + + return 0; +} + +static int +struct_datatype_deref (unsigned char stype) +{ + (void) stype; + + if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE) + { + SLang_Array_Type *at; + int status; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE)) + return -1; + + status = SLstruct_create_struct (at->num_elements, + (char **) at->data, NULL, NULL); + + SLang_free_array (at); + return status; + } + + SLang_push_integer (SLang_Num_Function_Args); + return _SLstruct_define_struct (); +} + +static int register_struct (void) +{ + SLang_Class_Type *cl; + + if (NULL == (cl = SLclass_allocate_class ("Struct_Type"))) + return -1; + + (void) SLclass_set_destroy_function (cl, struct_destroy); + (void) SLclass_set_push_function (cl, struct_push); + cl->cl_dereference = struct_dereference; + cl->cl_datatype_deref = struct_datatype_deref; + + cl->cl_foreach_open = struct_foreach_open; + cl->cl_foreach_close = struct_foreach_close; + cl->cl_foreach = struct_foreach; + + cl->cl_sget = struct_sget; + cl->cl_sput = struct_sput; + + if (-1 == SLclass_register_class (cl, SLANG_STRUCT_TYPE, sizeof (_SLang_Struct_Type), + SLANG_CLASS_TYPE_PTR)) + return -1; + + return 0; +} + +static void get_struct_field_names (_SLang_Struct_Type *s) +{ + SLang_Array_Type *a; + char **data; + int i, nfields; + _SLstruct_Field_Type *f; + + nfields = (int) s->nfields; + + if (NULL == (a = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &nfields, 1))) + return; + + f = s->fields; + data = (char **) a->data; + for (i = 0; i < nfields; i++) + { + /* Since we are dealing with hashed strings, the next call should not + * fail. If it does, the interpreter will handle it at some other + * level. + */ + data [i] = SLang_create_slstring (f[i].name); + } + + SLang_push_array (a, 1); +} + +static int push_struct_fields (_SLang_Struct_Type *s) +{ + _SLstruct_Field_Type *f, *fmax; + int num; + + f = s->fields; + fmax = f + s->nfields; + + num = 0; + while (fmax > f) + { + fmax--; + if (-1 == _SLpush_slang_obj (&fmax->obj)) + break; + + num++; + } + + return num; +} + +/* Syntax: set_struct_field (s, name, value); */ +static void struct_set_field (void) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + SLang_Object_Type obj; + char *name; + + if (-1 == SLang_pop (&obj)) + return; + + if (-1 == SLang_pop_slstring (&name)) + { + SLang_free_object (&obj); + return; + } + + if (-1 == _SLang_pop_struct (&s)) + { + SLang_free_slstring (name); + SLang_free_object (&obj); + return; + } + + if (NULL == (f = pop_field (s, name, find_field))) + { + _SLstruct_delete_struct (s); + SLang_free_slstring (name); + SLang_free_object (&obj); + return; + } + + SLang_free_object (&f->obj); + f->obj = obj; + + _SLstruct_delete_struct (s); + SLang_free_slstring (name); +} + +/* Syntax: set_struct_fields (s, values....); */ +static void set_struct_fields (void) +{ + unsigned int n; + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + + n = (unsigned int) SLang_Num_Function_Args; + + if (-1 == SLreverse_stack (n)) + return; + + n--; + if (-1 == _SLang_pop_struct (&s)) + { + SLdo_pop_n (n); + return; + } + + if (n > s->nfields) + { + SLdo_pop_n (n); + SLang_verror (SL_INVALID_PARM, "Too many values for structure"); + _SLstruct_delete_struct (s); + return; + } + + f = s->fields; + while (n > 0) + { + SLang_Object_Type obj; + + if (-1 == SLang_pop (&obj)) + break; + + SLang_free_object (&f->obj); + f->obj = obj; + + f++; + n--; + } + + _SLstruct_delete_struct (s); +} + +static void get_struct_field (char *name) +{ + (void) struct_sget (0, name); +} + +static int is_struct_type (void) +{ + SLang_Object_Type obj; + unsigned char type; + int status; + + if (-1 == SLang_pop (&obj)) + return -1; + + type = obj.data_type; + if (type == SLANG_STRUCT_TYPE) + status = 1; + else + status = (NULL != _SLclass_get_class (type)->cl_struct_def); + SLang_free_object (&obj); + return status; +} + +static SLang_Intrin_Fun_Type Struct_Table [] = +{ + MAKE_INTRINSIC_1("get_struct_field_names", get_struct_field_names, SLANG_VOID_TYPE, SLANG_STRUCT_TYPE), + MAKE_INTRINSIC_1("get_struct_field", get_struct_field, SLANG_VOID_TYPE, SLANG_STRING_TYPE), + MAKE_INTRINSIC_1("_push_struct_field_values", push_struct_fields, SLANG_INT_TYPE, SLANG_STRUCT_TYPE), + MAKE_INTRINSIC_0("set_struct_field", struct_set_field, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("set_struct_fields", set_struct_fields, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("is_struct_type", is_struct_type, SLANG_INT_TYPE), + /* MAKE_INTRINSIC_I("_create_struct", create_struct, SLANG_VOID_TYPE), */ + SLANG_END_INTRIN_FUN_TABLE +}; + +int _SLstruct_init (void) +{ + if ((-1 == SLadd_intrin_fun_table (Struct_Table, NULL)) + || (-1 == register_struct ())) + return -1; + + return 0; +} + +void _SLstruct_pop_args (int *np) +{ + SLang_Array_Type *at; + int i, n; + _SLang_Struct_Type **data; + + n = *np; + + if (n < 0) + { + SLang_Error = SL_INVALID_PARM; + return; + } + + data = (_SLang_Struct_Type **) SLmalloc ((n + 1) * sizeof (_SLang_Struct_Type *)); + if (data == NULL) + { + SLdo_pop_n (n); + return; + } + + memset ((char *)data, 0, n * sizeof (_SLang_Struct_Type *)); + + i = n; + while (i > 0) + { + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + + i--; + + if (NULL == (s = allocate_struct (1))) + goto return_error; + + data[i] = s; + s->num_refs += 1; /* keeping a copy */ + + f = s->fields; + if (NULL == (f->name = SLang_create_slstring ("value"))) + goto return_error; + + if (-1 == SLang_pop (&f->obj)) + goto return_error; + } + + if (NULL == (at = SLang_create_array (SLANG_STRUCT_TYPE, 0, + (VOID_STAR) data, &n, 1))) + goto return_error; + + (void) SLang_push_array (at, 1); + return; + + return_error: + for (i = 0; i < n; i++) + { + _SLang_Struct_Type *s; + + s = data[i]; + if (s != NULL) + _SLstruct_delete_struct (s); + } + + SLfree ((char *) data); +} + +void _SLstruct_push_args (SLang_Array_Type *at) +{ + _SLang_Struct_Type **sp; + unsigned int num; + + if (at->data_type != SLANG_STRUCT_TYPE) + { + SLang_Error = SL_TYPE_MISMATCH; + return; + } + + sp = (_SLang_Struct_Type **) at->data; + num = at->num_elements; + + while ((SLang_Error == 0) && (num > 0)) + { + _SLang_Struct_Type *s; + + num--; + if (NULL == (s = *sp++)) + { + SLang_push_null (); + continue; + } + + /* I should check to see if the value field is present, but... */ + (void) _SLpush_slang_obj (&s->fields->obj); + } +} + +/* C structures */ +static _SLstruct_Field_Type *find_field_via_strcmp (_SLang_Struct_Type *s, char *name) +{ + _SLstruct_Field_Type *f, *fmax; + + f = s->fields; + fmax = f + s->nfields; + + while (f < fmax) + { + if (0 == strcmp (name, f->name)) + return f; + + f++; + } + return NULL; +} + +static void free_cstruct_field (SLang_CStruct_Field_Type *cfield, VOID_STAR cs) +{ + SLang_Class_Type *cl; + + if ((cfield->read_only == 0) + && (NULL != (cl = _SLclass_get_class (cfield->type)))) + _SLarray_free_array_elements (cl, (VOID_STAR)((char*)cs + cfield->offset), 1); +} + +void SLang_free_cstruct (VOID_STAR cs, SLang_CStruct_Field_Type *cfields) +{ + if ((cs == NULL) || (cfields == NULL)) + return; + + while (cfields->field_name != NULL) + { + free_cstruct_field (cfields, cs); + cfields++; + } +} + +int SLang_pop_cstruct (VOID_STAR cs, SLang_CStruct_Field_Type *cfields) +{ + _SLang_Struct_Type *s; + SLang_CStruct_Field_Type *cfield; + char *field_name; + char *cs_addr; + + if ((cfields == NULL) || (cs == NULL)) + return -1; + + if (-1 == _SLang_pop_struct (&s)) + return -1; + + cfield = cfields; + cs_addr = (char *) cs; + + while (NULL != (field_name = cfield->field_name)) + { + _SLstruct_Field_Type *f; + SLang_Class_Type *cl; + + if ((cfield->read_only == 0) + && ((NULL == (f = pop_field (s, field_name, find_field_via_strcmp))) + || (-1 == _SLpush_slang_obj (&f->obj)) + || (NULL == (cl = _SLclass_get_class (cfield->type))) + || (-1 == (*cl->cl_apop)(cfield->type, (VOID_STAR) (cs_addr + cfield->offset))))) + goto return_error; + + cfield++; + } + + _SLstruct_delete_struct (s); + return 0; + + return_error: + while (cfield != cfields) + { + free_cstruct_field (cfield, cs); + cfield--; + } + _SLstruct_delete_struct (s); + return -1; +} + +static _SLang_Struct_Type *create_cstruct (VOID_STAR cs, SLang_CStruct_Field_Type *cfields) +{ + unsigned int i, n; + _SLang_Struct_Type *s; + SLang_CStruct_Field_Type *cfield; + char **field_names; + VOID_STAR *field_values; + SLtype *field_types; + + if ((cs == NULL) || (cfields == NULL)) + return NULL; + + cfield = cfields; + while (cfield->field_name != NULL) + cfield++; + n = cfield - cfields; + if (n == 0) + { + SLang_verror (SL_APPLICATION_ERROR, "C structure has no fields"); + return NULL; + } + + s = NULL; + field_types = NULL; + field_values = NULL; + if ((NULL == (field_names = (char **) SLmalloc (n*sizeof (char *)))) + || (NULL == (field_types = (SLtype *)SLmalloc (n*sizeof(SLtype)))) + || (NULL == (field_values = (VOID_STAR *)SLmalloc (n*sizeof(VOID_STAR))))) + goto return_error; + + for (i = 0; i < n; i++) + { + cfield = cfields + i; + field_names[i] = cfield->field_name; + field_types[i] = cfield->type; + field_values[i] = (VOID_STAR)((char *)cs + cfield->offset); + } + + s = create_struct (n, field_names, field_types, field_values); + /* drop */ + + return_error: + SLfree ((char *) field_values); + SLfree ((char *) field_types); + SLfree ((char *) field_names); + + return s; +} + +int SLang_push_cstruct (VOID_STAR cs, SLang_CStruct_Field_Type *cfields) +{ + _SLang_Struct_Type *s; + + if (NULL == (s = create_cstruct (cs, cfields))) + return -1; + + if (0 == _SLang_push_struct (s)) + return 0; + + _SLstruct_delete_struct (s); + return -1; +} + +int SLang_assign_cstruct_to_ref (SLang_Ref_Type *ref, VOID_STAR cs, SLang_CStruct_Field_Type *cfields) +{ + _SLang_Struct_Type *s; + + if (NULL == (s = create_cstruct (cs, cfields))) + return -1; + + if (0 == SLang_assign_to_ref (ref, SLANG_STRUCT_TYPE, (VOID_STAR) &s)) + return 0; + + _SLstruct_delete_struct (s); + return -1; +} + diff --git a/libslang/src/sltermin.c b/libslang/src/sltermin.c new file mode 100644 index 0000000..b2bd9ef --- /dev/null +++ b/libslang/src/sltermin.c @@ -0,0 +1,1178 @@ +/* This file contains enough terminfo reading capabilities sufficient for + * the slang SLtt interface. + */ + +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* + * The majority of the comments found in the file were taken from the + * term(4) man page on an SGI. + */ + +/* Short integers are stored in two 8-bit bytes. The first byte contains + * the least significant 8 bits of the value, and the second byte contains + * the most significant 8 bits. (Thus, the value represented is + * 256*second+first.) The value -1 is represented by 0377,0377, and the + * value -2 is represented by 0376,0377; other negative values are illegal. + * The -1 generally means that a capability is missing from this terminal. + * The -2 means that the capability has been cancelled in the terminfo + * source and also is to be considered missing. + */ + +static int make_integer (unsigned char *buf) +{ + register int lo, hi; + lo = (int) *buf++; hi = (int) *buf; + if (hi == 0377) + { + if (lo == 0377) return -1; + if (lo == 0376) return -2; + } + return lo + 256 * hi; +} + +/* + * The compiled file is created from the source file descriptions of the + * terminals (see the -I option of infocmp) by using the terminfo compiler, + * tic, and read by the routine setupterm [see curses(3X).] The file is + * divided into six parts in the following order: the header, terminal + * names, boolean flags, numbers, strings, and string table. + * + * The header section begins the file. This section contains six short + * integers in the format described below. These integers are (1) the magic + * number (octal 0432); (2) the size, in bytes, of the names section; (3) + * the number of bytes in the boolean section; (4) the number of short + * integers in the numbers section; (5) the number of offsets (short + * integers) in the strings section; (6) the size, in bytes, of the string + * table. + */ + +#define MAGIC 0432 + +/* In this structure, all char * fields are malloced EXCEPT if the + * structure is SLTERMCAP. In that case, only terminal_names is malloced + * and the other fields are pointers into it. + */ +struct _SLterminfo_Type +{ +#define SLTERMINFO 1 +#define SLTERMCAP 2 + unsigned int flags; + + unsigned int name_section_size; + char *terminal_names; + + unsigned int boolean_section_size; + unsigned char *boolean_flags; + + unsigned int num_numbers; + unsigned char *numbers; + + unsigned int num_string_offsets; + unsigned char *string_offsets; + + unsigned int string_table_size; + char *string_table; + +}; + +static char *tcap_getstr (char *, SLterminfo_Type *); +static int tcap_getnum (char *, SLterminfo_Type *); +static int tcap_getflag (char *, SLterminfo_Type *); +static int tcap_getent (char *, SLterminfo_Type *); + +static FILE *open_terminfo (char *file, SLterminfo_Type *h) +{ + FILE *fp; + unsigned char buf[12]; + + /* Alan Cox reported a security problem here if the application using the + * library is setuid. So, I need to make sure open the file as a normal + * user. Unfortunately, there does not appear to be a portable way of + * doing this, so I am going to use 'setfsgid' and 'setfsuid', which + * are not portable. + * + * I will also look into the use of setreuid, seteuid and setregid, setegid. + * FIXME: Priority=medium + */ + fp = fopen (file, "rb"); + if (fp == NULL) return NULL; + + if ((12 == fread ((char *) buf, 1, 12, fp) && (MAGIC == make_integer (buf)))) + { + h->name_section_size = make_integer (buf + 2); + h->boolean_section_size = make_integer (buf + 4); + h->num_numbers = make_integer (buf + 6); + h->num_string_offsets = make_integer (buf + 8); + h->string_table_size = make_integer (buf + 10); + } + else + { + fclose (fp); + fp = NULL; + } + return fp; +} + +/* + * The terminal names section comes next. It contains the first line of the + * terminfo description, listing the various names for the terminal, + * separated by the bar ( | ) character (see term(5)). The section is + * terminated with an ASCII NUL character. + */ + +/* returns pointer to malloced space */ +static unsigned char *read_terminfo_section (FILE *fp, unsigned int size) +{ + char *s; + + if (NULL == (s = (char *) SLmalloc (size))) return NULL; + if (size != fread (s, 1, size, fp)) + { + SLfree (s); + return NULL; + } + return (unsigned char *) s; +} + +static char *read_terminal_names (FILE *fp, SLterminfo_Type *t) +{ + return t->terminal_names = (char *) read_terminfo_section (fp, t->name_section_size); +} + +/* + * The boolean flags have one byte for each flag. This byte is either 0 or + * 1 as the flag is present or absent. The value of 2 means that the flag + * has been cancelled. The capabilities are in the same order as the file + * . + */ + +static unsigned char *read_boolean_flags (FILE *fp, SLterminfo_Type *t) +{ + /* Between the boolean section and the number section, a null byte is + * inserted, if necessary, to ensure that the number section begins on an + * even byte offset. All short integers are aligned on a short word + * boundary. + */ + + unsigned int size = (t->name_section_size + t->boolean_section_size) % 2; + size += t->boolean_section_size; + + return t->boolean_flags = read_terminfo_section (fp, size); +} + +/* + * The numbers section is similar to the boolean flags section. Each + * capability takes up two bytes, and is stored as a short integer. If the + * value represented is -1 or -2, the capability is taken to be missing. + */ + +static unsigned char *read_numbers (FILE *fp, SLterminfo_Type *t) +{ + return t->numbers = read_terminfo_section (fp, 2 * t->num_numbers); +} + +/* The strings section is also similar. Each capability is stored as a + * short integer, in the format above. A value of -1 or -2 means the + * capability is missing. Otherwise, the value is taken as an offset from + * the beginning of the string table. Special characters in ^X or \c + * notation are stored in their interpreted form, not the printing + * representation. Padding information ($) and parameter information + * (%x) are stored intact in uninterpreted form. + */ + +static unsigned char *read_string_offsets (FILE *fp, SLterminfo_Type *t) +{ + return t->string_offsets = (unsigned char *) read_terminfo_section (fp, 2 * t->num_string_offsets); +} + +/* The final section is the string table. It contains all the values of + * string capabilities referenced in the string section. Each string is + * null terminated. + */ + +static char *read_string_table (FILE *fp, SLterminfo_Type *t) +{ + return t->string_table = (char *) read_terminfo_section (fp, t->string_table_size); +} + +/* + * Compiled terminfo(4) descriptions are placed under the directory + * /usr/share/lib/terminfo. In order to avoid a linear search of a huge + * UNIX system directory, a two-level scheme is used: + * /usr/share/lib/terminfo/c/name where name is the name of the terminal, + * and c is the first character of name. Thus, att4425 can be found in the + * file /usr/share/lib/terminfo/a/att4425. Synonyms for the same terminal + * are implemented by multiple links to the same compiled file. + */ + +static char *Terminfo_Dirs [] = +{ + NULL, /* $HOME/.terminfo */ + NULL, /* $TERMINFO */ + "/usr/share/terminfo", + "/usr/lib/terminfo", + "/usr/share/lib/terminfo", + "/etc/terminfo", + "/usr/local/lib/terminfo", +#ifdef MISC_TERMINFO_DIRS + MISC_TERMINFO_DIRS, +#endif + "" +}; + +SLterminfo_Type *_SLtt_tigetent (char *term) +{ + char *tidir; + int i; + FILE *fp = NULL; + char file[1024]; + static char home_ti [1024]; + char *home; + SLterminfo_Type *ti; + + if ( + (term == NULL) +#ifdef SLANG_UNTIC + && (SLang_Untic_Terminfo_File == NULL) +#endif + ) + return NULL; + + if (_SLsecure_issetugid () + && ((term[0] == '.') || (NULL != strchr (term, '/')))) + return NULL; + + if (NULL == (ti = (SLterminfo_Type *) SLmalloc (sizeof (SLterminfo_Type)))) + { + return NULL; + } + +#ifdef SLANG_UNTIC + if (SLang_Untic_Terminfo_File != NULL) + { + fp = open_terminfo (SLang_Untic_Terminfo_File, ti); + goto fp_open_label; + } + else +#endif + /* If we are on a termcap based system, use termcap */ + if (0 == tcap_getent (term, ti)) return ti; + + if (NULL != (home = _SLsecure_getenv ("HOME"))) + { + strncpy (home_ti, home, sizeof (home_ti) - 11); + home_ti [sizeof(home_ti) - 11] = 0; + strcat (home_ti, "/.terminfo"); + Terminfo_Dirs [0] = home_ti; + } + + Terminfo_Dirs[1] = _SLsecure_getenv ("TERMINFO"); + i = 0; + while (1) + { + tidir = Terminfo_Dirs[i]; + if (tidir != NULL) + { + if (*tidir == 0) + break; /* last one */ + + if (sizeof (file) > strlen (tidir) + 2 + strlen (term)) + { + sprintf (file, "%s/%c/%s", tidir, *term, term); + if (NULL != (fp = open_terminfo (file, ti))) + break; + } + } + i++; + } + +#ifdef SLANG_UNTIC + fp_open_label: +#endif + + if (fp != NULL) + { + if (NULL != read_terminal_names (fp, ti)) + { + if (NULL != read_boolean_flags (fp, ti)) + { + if (NULL != read_numbers (fp, ti)) + { + if (NULL != read_string_offsets (fp, ti)) + { + if (NULL != read_string_table (fp, ti)) + { + /* success */ + fclose (fp); + ti->flags = SLTERMINFO; + return ti; + } + SLfree ((char *)ti->string_offsets); + } + SLfree ((char *)ti->numbers); + } + SLfree ((char *)ti->boolean_flags); + } + SLfree ((char *)ti->terminal_names); + } + fclose (fp); + } + + SLfree ((char *)ti); + return NULL; +} + +#ifdef SLANG_UNTIC +# define UNTIC_COMMENT(x) ,x +#else +# define UNTIC_COMMENT(x) +#endif + +typedef SLCONST struct +{ + char name[3]; + int offset; +#ifdef SLANG_UNTIC + char *comment; +#endif +} +Tgetstr_Map_Type; + +/* I need to add: K1-5, %0-5(not important), @8, &8... */ +static Tgetstr_Map_Type Tgetstr_Map [] = +{ + {"!1", 212 UNTIC_COMMENT("shifted key")}, + {"!2", 213 UNTIC_COMMENT("shifted key")}, + {"!3", 214 UNTIC_COMMENT("shifted key")}, + {"#1", 198 UNTIC_COMMENT("shifted key")}, + {"#2", 199 UNTIC_COMMENT("Key S-Home")}, + {"#3", 200 UNTIC_COMMENT("Key S-Insert")}, + {"#4", 201 UNTIC_COMMENT("Key S-Left")}, + {"%0", 177 UNTIC_COMMENT("redo key")}, + {"%1", 168 UNTIC_COMMENT("help key")}, + {"%2", 169 UNTIC_COMMENT("mark key")}, + {"%3", 170 UNTIC_COMMENT("message key")}, + {"%4", 171 UNTIC_COMMENT("move key")}, + {"%5", 172 UNTIC_COMMENT("next key")}, + {"%6", 173 UNTIC_COMMENT("open key")}, + {"%7", 174 UNTIC_COMMENT("options key")}, + {"%8", 175 UNTIC_COMMENT("previous key")}, + {"%9", 176 UNTIC_COMMENT("print key")}, + {"%a", 202 UNTIC_COMMENT("shifted key")}, + {"%b", 203 UNTIC_COMMENT("shifted key")}, + {"%c", 204 UNTIC_COMMENT("Key S-Next")}, + {"%d", 205 UNTIC_COMMENT("shifted key")}, + {"%e", 206 UNTIC_COMMENT("Key S-Previous")}, + {"%f", 207 UNTIC_COMMENT("shifted key")}, + {"%g", 208 UNTIC_COMMENT("shifted key")}, + {"%h", 209 UNTIC_COMMENT("shifted key")}, + {"%i", 210 UNTIC_COMMENT("Key S-Right")}, + {"%j", 211 UNTIC_COMMENT("shifted key")}, + {"&0", 187 UNTIC_COMMENT("shifted key")}, + {"&1", 178 UNTIC_COMMENT("reference key")}, + {"&2", 179 UNTIC_COMMENT("refresh key")}, + {"&3", 180 UNTIC_COMMENT("replace key")}, + {"&4", 181 UNTIC_COMMENT("restart key")}, + {"&5", 182 UNTIC_COMMENT("resume key")}, + {"&6", 183 UNTIC_COMMENT("save key")}, + {"&7", 184 UNTIC_COMMENT("suspend key")}, + {"&8", 185 UNTIC_COMMENT("undo key")}, + {"&9", 186 UNTIC_COMMENT("shifted key")}, + {"*0", 197 UNTIC_COMMENT("shifted key")}, + {"*1", 188 UNTIC_COMMENT("shifted key")}, + {"*2", 189 UNTIC_COMMENT("shifted key")}, + {"*3", 190 UNTIC_COMMENT("shifted key")}, + {"*4", 191 UNTIC_COMMENT("Key S-Delete")}, + {"*5", 192 UNTIC_COMMENT("shifted key")}, + {"*6", 193 UNTIC_COMMENT("select key")}, + {"*7", 194 UNTIC_COMMENT("Key S-End")}, + {"*8", 195 UNTIC_COMMENT("shifted key")}, + {"*9", 196 UNTIC_COMMENT("shifted key")}, + {"@0", 167 UNTIC_COMMENT("find key")}, + {"@1", 158 UNTIC_COMMENT("begin key")}, + {"@2", 159 UNTIC_COMMENT("cancel key")}, + {"@3", 160 UNTIC_COMMENT("close key")}, + {"@4", 161 UNTIC_COMMENT("command key")}, + {"@5", 162 UNTIC_COMMENT("copy key")}, + {"@6", 163 UNTIC_COMMENT("create key")}, + {"@7", 164 UNTIC_COMMENT("Key End")}, + {"@8", 165 UNTIC_COMMENT("enter/send key")}, + {"@9", 166 UNTIC_COMMENT("exit key")}, + {"AB", 360 UNTIC_COMMENT("set ANSI color background")}, + {"AF", 359 UNTIC_COMMENT("set ANSI color foreground")}, + {"AL", 110 UNTIC_COMMENT("parm_insert_line")}, + {"CC", 9 UNTIC_COMMENT("terminal settable cmd character in prototype !?")}, + {"CM", 15 UNTIC_COMMENT("memory relative cursor addressing")}, + {"CW", 277 UNTIC_COMMENT("define a window #1 from #2, #3 to #4, #5")}, + {"DC", 105 UNTIC_COMMENT("delete #1 chars")}, + {"DI", 280 UNTIC_COMMENT("dial number #1")}, + {"DK", 275 UNTIC_COMMENT("display clock at (#1,#2)")}, + {"DL", 106 UNTIC_COMMENT("parm_delete_line")}, + {"DO", 107 UNTIC_COMMENT("down #1 lines")}, + {"F1", 216 UNTIC_COMMENT("key_f11")}, + {"F2", 217 UNTIC_COMMENT("key_f12")}, + {"F3", 218 UNTIC_COMMENT("key_f13")}, + {"F4", 219 UNTIC_COMMENT("key_f14")}, + {"F5", 220 UNTIC_COMMENT("key_f15")}, + {"F6", 221 UNTIC_COMMENT("key_f16")}, + {"F7", 222 UNTIC_COMMENT("key_f17")}, + {"F8", 223 UNTIC_COMMENT("key_f18")}, + {"F9", 224 UNTIC_COMMENT("key_f19")}, + {"FA", 225 UNTIC_COMMENT("key_f20")}, + {"FB", 226 UNTIC_COMMENT("F21 function key")}, + {"FC", 227 UNTIC_COMMENT("F22 function key")}, + {"FD", 228 UNTIC_COMMENT("F23 function key")}, + {"FE", 229 UNTIC_COMMENT("F24 function key")}, + {"FF", 230 UNTIC_COMMENT("F25 function key")}, + {"FG", 231 UNTIC_COMMENT("F26 function key")}, + {"FH", 232 UNTIC_COMMENT("F27 function key")}, + {"FI", 233 UNTIC_COMMENT("F28 function key")}, + {"FJ", 234 UNTIC_COMMENT("F29 function key")}, + {"FK", 235 UNTIC_COMMENT("F30 function key")}, + {"FL", 236 UNTIC_COMMENT("F31 function key")}, + {"FM", 237 UNTIC_COMMENT("F32 function key")}, + {"FN", 238 UNTIC_COMMENT("F33 function key")}, + {"FO", 239 UNTIC_COMMENT("F34 function key")}, + {"FP", 240 UNTIC_COMMENT("F35 function key")}, + {"FQ", 241 UNTIC_COMMENT("F36 function key")}, + {"FR", 242 UNTIC_COMMENT("F37 function key")}, + {"FS", 243 UNTIC_COMMENT("F38 function key")}, + {"FT", 244 UNTIC_COMMENT("F39 function key")}, + {"FU", 245 UNTIC_COMMENT("F40 function key")}, + {"FV", 246 UNTIC_COMMENT("F41 function key")}, + {"FW", 247 UNTIC_COMMENT("F42 function key")}, + {"FX", 248 UNTIC_COMMENT("F43 function key")}, + {"FY", 249 UNTIC_COMMENT("F44 function key")}, + {"FZ", 250 UNTIC_COMMENT("F45 function key")}, + {"Fa", 251 UNTIC_COMMENT("F46 function key")}, + {"Fb", 252 UNTIC_COMMENT("F47 function key")}, + {"Fc", 253 UNTIC_COMMENT("F48 function key")}, + {"Fd", 254 UNTIC_COMMENT("F49 function key")}, + {"Fe", 255 UNTIC_COMMENT("F50 function key")}, + {"Ff", 256 UNTIC_COMMENT("F51 function key")}, + {"Fg", 257 UNTIC_COMMENT("F52 function key")}, + {"Fh", 258 UNTIC_COMMENT("F53 function key")}, + {"Fi", 259 UNTIC_COMMENT("F54 function key")}, + {"Fj", 260 UNTIC_COMMENT("F55 function key")}, + {"Fk", 261 UNTIC_COMMENT("F56 function key")}, + {"Fl", 262 UNTIC_COMMENT("F57 function key")}, + {"Fm", 263 UNTIC_COMMENT("F58 function key")}, + {"Fn", 264 UNTIC_COMMENT("F59 function key")}, + {"Fo", 265 UNTIC_COMMENT("F60 function key")}, + {"Fp", 266 UNTIC_COMMENT("F61 function key")}, + {"Fq", 267 UNTIC_COMMENT("F62 function key")}, + {"Fr", 268 UNTIC_COMMENT("F63 function key")}, + {"G1", 400 UNTIC_COMMENT("single upper right")}, + {"G2", 398 UNTIC_COMMENT("single upper left")}, + {"G3", 399 UNTIC_COMMENT("single lower left")}, + {"G4", 401 UNTIC_COMMENT("single lower right")}, + {"GC", 408 UNTIC_COMMENT("single intersection")}, + {"GD", 405 UNTIC_COMMENT("tee pointing down")}, + {"GH", 406 UNTIC_COMMENT("single horizontal line")}, + {"GL", 403 UNTIC_COMMENT("tee pointing left")}, + {"GR", 402 UNTIC_COMMENT("tee pointing right")}, + {"GU", 404 UNTIC_COMMENT("tee pointing up")}, + {"GV", 407 UNTIC_COMMENT("single vertical line")}, + {"Gm", 358 UNTIC_COMMENT("Curses should get button events")}, + {"HU", 279 UNTIC_COMMENT("hang-up phone")}, + {"IC", 108 UNTIC_COMMENT("insert #1 chars")}, + {"Ic", 299 UNTIC_COMMENT("initialize color #1 to (#2,#3,#4)")}, + {"Ip", 300 UNTIC_COMMENT("Initialize color pair #1 to fg=(#2,#3,#4), bg=(#5,#6,#7)")}, + {"K1", 139 UNTIC_COMMENT("upper left of keypad")}, + {"K2", 141 UNTIC_COMMENT("center of keypad")}, + {"K3", 140 UNTIC_COMMENT("upper right of keypad")}, + {"K4", 142 UNTIC_COMMENT("lower left of keypad")}, + {"K5", 143 UNTIC_COMMENT("lower right of keypad")}, + {"Km", 355 UNTIC_COMMENT("Mouse event has occurred")}, + {"LE", 111 UNTIC_COMMENT("move #1 chars to the left")}, + {"LF", 157 UNTIC_COMMENT("turn off soft labels")}, + {"LO", 156 UNTIC_COMMENT("turn on soft labels")}, + {"Lf", 273 UNTIC_COMMENT("label format")}, + {"MC", 270 UNTIC_COMMENT("clear right and left soft margins")}, + {"ML", 271 UNTIC_COMMENT("set left soft margin")}, + {"ML", 368 UNTIC_COMMENT("Set both left and right margins to #1, #2")}, + {"MR", 272 UNTIC_COMMENT("set right soft margin")}, + {"MT", 369 UNTIC_COMMENT("Sets both top and bottom margins to #1, #2")}, + {"Mi", 356 UNTIC_COMMENT("Mouse status information")}, + {"PA", 285 UNTIC_COMMENT("pause for 2-3 seconds")}, + {"PU", 283 UNTIC_COMMENT("select pulse dialling")}, + {"QD", 281 UNTIC_COMMENT("dial number #1 without checking")}, + {"RA", 152 UNTIC_COMMENT("turn off automatic margins")}, + {"RC", 276 UNTIC_COMMENT("remove clock")}, + {"RF", 215 UNTIC_COMMENT("send next input char (for ptys)")}, + {"RI", 112 UNTIC_COMMENT("parm_right_cursor")}, + {"RQ", 357 UNTIC_COMMENT("Request mouse position")}, + {"RX", 150 UNTIC_COMMENT("turn off xon/xoff handshaking")}, + {"S1", 378 UNTIC_COMMENT("Display PC character")}, + {"S2", 379 UNTIC_COMMENT("Enter PC character display mode")}, + {"S3", 380 UNTIC_COMMENT("Exit PC character display mode")}, + {"S4", 381 UNTIC_COMMENT("Enter PC scancode mode")}, + {"S5", 382 UNTIC_COMMENT("Exit PC scancode mode")}, + {"S6", 383 UNTIC_COMMENT("PC terminal options")}, + {"S7", 384 UNTIC_COMMENT("Escape for scancode emulation")}, + {"S8", 385 UNTIC_COMMENT("Alternate escape for scancode emulation")}, + {"SA", 151 UNTIC_COMMENT("turn on automatic margins")}, + {"SC", 274 UNTIC_COMMENT("set clock, #1 hrs #2 mins #3 secs")}, + {"SF", 109 UNTIC_COMMENT("scroll forward #1 lines")}, + {"SR", 113 UNTIC_COMMENT("scroll back #1 lines")}, + {"SX", 149 UNTIC_COMMENT("turn on xon/xoff handshaking")}, + {"Sb", 303 UNTIC_COMMENT("set background (color)")}, + {"Sf", 302 UNTIC_COMMENT("set foreground (color)")}, + {"TO", 282 UNTIC_COMMENT("select touch tone dialing")}, + {"UP", 114 UNTIC_COMMENT("up #1 lines")}, + {"WA", 286 UNTIC_COMMENT("wait for dial-tone")}, + {"WG", 278 UNTIC_COMMENT("go to window #1")}, + {"XF", 154 UNTIC_COMMENT("XOFF character")}, + {"XN", 153 UNTIC_COMMENT("XON character")}, + {"Xh", 386 UNTIC_COMMENT("Enter horizontal highlight mode")}, + {"Xl", 387 UNTIC_COMMENT("Enter left highlight mode")}, + {"Xo", 388 UNTIC_COMMENT("Enter low highlight mode")}, + {"Xr", 389 UNTIC_COMMENT("Enter right highlight mode")}, + {"Xt", 390 UNTIC_COMMENT("Enter top highlight mode")}, + {"Xv", 391 UNTIC_COMMENT("Enter vertical highlight mode")}, + {"Xy", 370 UNTIC_COMMENT("Repeat bit image cell #1 #2 times")}, + {"YZ", 377 UNTIC_COMMENT("Set page length to #1 lines")}, + {"Yv", 372 UNTIC_COMMENT("Move to beginning of same row")}, + {"Yw", 373 UNTIC_COMMENT("Give name for color #1")}, + {"Yx", 374 UNTIC_COMMENT("Define rectangualar bit image region")}, + {"Yy", 375 UNTIC_COMMENT("End a bit-image region")}, + {"Yz", 376 UNTIC_COMMENT("Change to ribbon color #1")}, + {"ZA", 304 UNTIC_COMMENT("Change number of characters per inch")}, + {"ZB", 305 UNTIC_COMMENT("Change number of lines per inch")}, + {"ZC", 306 UNTIC_COMMENT("Change horizontal resolution")}, + {"ZD", 307 UNTIC_COMMENT("Change vertical resolution")}, + {"ZE", 308 UNTIC_COMMENT("Define a character")}, + {"ZF", 309 UNTIC_COMMENT("Enter double-wide mode")}, + {"ZG", 310 UNTIC_COMMENT("Enter draft-quality mode")}, + {"ZH", 311 UNTIC_COMMENT("Enter italic mode")}, + {"ZI", 312 UNTIC_COMMENT("Start leftward carriage motion")}, + {"ZJ", 313 UNTIC_COMMENT("Start micro-motion mode")}, + {"ZK", 314 UNTIC_COMMENT("Enter NLQ mode")}, + {"ZL", 315 UNTIC_COMMENT("Wnter normal-quality mode")}, + {"ZM", 316 UNTIC_COMMENT("Enter shadow-print mode")}, + {"ZN", 317 UNTIC_COMMENT("Enter subscript mode")}, + {"ZO", 318 UNTIC_COMMENT("Enter superscript mode")}, + {"ZP", 319 UNTIC_COMMENT("Start upward carriage motion")}, + {"ZQ", 320 UNTIC_COMMENT("End double-wide mode")}, + {"ZR", 321 UNTIC_COMMENT("End italic mode")}, + {"ZS", 322 UNTIC_COMMENT("End left-motion mode")}, + {"ZT", 323 UNTIC_COMMENT("End micro-motion mode")}, + {"ZU", 324 UNTIC_COMMENT("End shadow-print mode")}, + {"ZV", 325 UNTIC_COMMENT("End subscript mode")}, + {"ZW", 326 UNTIC_COMMENT("End superscript mode")}, + {"ZX", 327 UNTIC_COMMENT("End reverse character motion")}, + {"ZY", 328 UNTIC_COMMENT("Like column_address in micro mode")}, + {"ZZ", 329 UNTIC_COMMENT("Like cursor_down in micro mode")}, + {"Za", 330 UNTIC_COMMENT("Like cursor_left in micro mode")}, + {"Zb", 331 UNTIC_COMMENT("Like cursor_right in micro mode")}, + {"Zc", 332 UNTIC_COMMENT("Like row_address in micro mode")}, + {"Zd", 333 UNTIC_COMMENT("Like cursor_up in micro mode")}, + {"Ze", 334 UNTIC_COMMENT("Match software bits to print-head pins")}, + {"Zf", 335 UNTIC_COMMENT("Like parm_down_cursor in micro mode")}, + {"Zg", 336 UNTIC_COMMENT("Like parm_left_cursor in micro mode")}, + {"Zh", 337 UNTIC_COMMENT("Like parm_right_cursor in micro mode")}, + {"Zi", 338 UNTIC_COMMENT("Like parm_up_cursor in micro mode")}, + {"Zj", 339 UNTIC_COMMENT("Select character set")}, + {"Zk", 340 UNTIC_COMMENT("Set bottom margin at current line")}, + {"Zl", 341 UNTIC_COMMENT("Set bottom margin at line #1 or #2 lines from bottom")}, + {"Zm", 342 UNTIC_COMMENT("Set left (right) margin at column #1 (#2)")}, + {"Zn", 343 UNTIC_COMMENT("Set right margin at column #1")}, + {"Zo", 344 UNTIC_COMMENT("Set top margin at current line")}, + {"Zp", 345 UNTIC_COMMENT("Set top (bottom) margin at row #1 (#2)")}, + {"Zq", 346 UNTIC_COMMENT("Start printing bit image braphics")}, + {"Zr", 347 UNTIC_COMMENT("Start character set definition")}, + {"Zs", 348 UNTIC_COMMENT("Stop printing bit image graphics")}, + {"Zt", 349 UNTIC_COMMENT("End definition of character aet")}, + {"Zu", 350 UNTIC_COMMENT("List of subscriptable characters")}, + {"Zv", 351 UNTIC_COMMENT("List of superscriptable characters")}, + {"Zw", 352 UNTIC_COMMENT("Printing any of these chars causes CR")}, + {"Zx", 353 UNTIC_COMMENT("No motion for subsequent character")}, + {"Zy", 354 UNTIC_COMMENT("List of character set names")}, + {"Zz", 371 UNTIC_COMMENT("Move to next row of the bit image")}, + {"ac", 146 UNTIC_COMMENT("acs_chars")}, + {"ae", 38 UNTIC_COMMENT("exit_alt_charset_mode")}, + {"al", 53 UNTIC_COMMENT("insert line")}, + {"as", 25 UNTIC_COMMENT("enter_alt_charset_mode")}, + {"bc", 395 UNTIC_COMMENT("move left, if not ^H")}, + {"bl", 1 UNTIC_COMMENT("audible signal (bell)")}, + {"bt", 0 UNTIC_COMMENT("back tab")}, + {"bx", 411 UNTIC_COMMENT("box chars primary set")}, + {"cb", 269 UNTIC_COMMENT("Clear to beginning of line")}, + {"cd", 7 UNTIC_COMMENT("clear to end of screen")}, + {"ce", 6 UNTIC_COMMENT("clr_eol")}, + {"ch", 8 UNTIC_COMMENT("horizontal position #1, absolute")}, + {"ci", 363 UNTIC_COMMENT("Init sequence for multiple codesets")}, + {"cl", 5 UNTIC_COMMENT("clear screen and home cursor")}, + {"cm", 10 UNTIC_COMMENT("move to row #1 columns #2")}, + {"cr", 2 UNTIC_COMMENT("carriage return")}, + {"cs", 3 UNTIC_COMMENT("change region to line #1 to line #2")}, + {"ct", 4 UNTIC_COMMENT("clear all tab stops")}, + {"cv", 127 UNTIC_COMMENT("vertical position #1 absolute")}, + {"dc", 21 UNTIC_COMMENT("delete character")}, + {"dl", 22 UNTIC_COMMENT("delete line")}, + {"dm", 29 UNTIC_COMMENT("enter delete mode")}, + {"do", 11 UNTIC_COMMENT("down one line")}, + {"ds", 23 UNTIC_COMMENT("disable status line")}, + {"dv", 362 UNTIC_COMMENT("Indicate language/codeset support")}, + {"eA", 155 UNTIC_COMMENT("enable alternate char set")}, + {"ec", 37 UNTIC_COMMENT("erase #1 characters")}, + {"ed", 41 UNTIC_COMMENT("end delete mode")}, + {"ei", 42 UNTIC_COMMENT("exit insert mode")}, + {"ff", 46 UNTIC_COMMENT("hardcopy terminal page eject")}, + {"fh", 284 UNTIC_COMMENT("flash switch hook")}, + {"fs", 47 UNTIC_COMMENT("return from status line")}, + {"hd", 24 UNTIC_COMMENT("half a line down")}, + {"ho", 12 UNTIC_COMMENT("home cursor (if no cup)")}, + {"hu", 137 UNTIC_COMMENT("half a line up")}, + {"i1", 48 UNTIC_COMMENT("initialization string")}, + {"i2", 392 UNTIC_COMMENT("secondary initialization string")}, + {"i3", 50 UNTIC_COMMENT("initialization string")}, + {"iP", 138 UNTIC_COMMENT("path name of program for initialization")}, + {"ic", 52 UNTIC_COMMENT("insert character")}, + {"if", 51 UNTIC_COMMENT("name of initialization file")}, + {"im", 31 UNTIC_COMMENT("enter insert mode")}, + {"ip", 54 UNTIC_COMMENT("insert padding after inserted character")}, + {"is", 49 UNTIC_COMMENT("initialization string")}, + {"k0", 65 UNTIC_COMMENT("F0 function key")}, + {"k1", 66 UNTIC_COMMENT("F1 function key")}, + {"k2", 68 UNTIC_COMMENT("F2 function key")}, + {"k3", 69 UNTIC_COMMENT("F3 function key")}, + {"k4", 70 UNTIC_COMMENT("F4 function key")}, + {"k5", 71 UNTIC_COMMENT("F5 function key")}, + {"k6", 72 UNTIC_COMMENT("F6 function key")}, + {"k7", 73 UNTIC_COMMENT("F7 function key")}, + {"k8", 74 UNTIC_COMMENT("F8 fucntion key")}, + {"k9", 75 UNTIC_COMMENT("F9 function key")}, + {"k;", 67 UNTIC_COMMENT("F10 function key")}, + {"kA", 78 UNTIC_COMMENT("insert-line key")}, + {"kB", 148 UNTIC_COMMENT("back-tab key")}, + {"kC", 57 UNTIC_COMMENT("clear-screen or erase key")}, + {"kD", 59 UNTIC_COMMENT("delete-character key")}, + {"kE", 63 UNTIC_COMMENT("clear-to-end-of-line key")}, + {"kF", 84 UNTIC_COMMENT("scroll-forward key")}, + {"kH", 80 UNTIC_COMMENT("last-line key")}, + {"kI", 77 UNTIC_COMMENT("insert-character key")}, + {"kL", 60 UNTIC_COMMENT("delete-line key")}, + {"kM", 62 UNTIC_COMMENT("sent by rmir or smir in insert mode")}, + {"kN", 81 UNTIC_COMMENT("next-page key")}, + {"kP", 82 UNTIC_COMMENT("prev-page key")}, + {"kR", 85 UNTIC_COMMENT("scroll-backward key")}, + {"kS", 64 UNTIC_COMMENT("clear-to-end-of-screen key")}, + {"kT", 86 UNTIC_COMMENT("set-tab key")}, + {"ka", 56 UNTIC_COMMENT("clear-all-tabs key")}, + {"kb", 55 UNTIC_COMMENT("backspace key")}, + {"kd", 61 UNTIC_COMMENT("down-arrow key")}, + {"ke", 88 UNTIC_COMMENT("leave 'keyboard_transmit' mode")}, + {"kh", 76 UNTIC_COMMENT("home key")}, + {"kl", 79 UNTIC_COMMENT("left-arrow key")}, + {"ko", 396 UNTIC_COMMENT("list of self-mapped keycaps")}, + {"kr", 83 UNTIC_COMMENT("right-arrow key")}, + {"ks", 89 UNTIC_COMMENT("enter 'keyboard_transmit' mode")}, + {"kt", 58 UNTIC_COMMENT("clear-tab key")}, + {"ku", 87 UNTIC_COMMENT("up-arrow key")}, + {"l0", 90 UNTIC_COMMENT("label on function key f0 if not f0")}, + {"l1", 91 UNTIC_COMMENT("label on function key f1 if not f1")}, + {"l2", 93 UNTIC_COMMENT("label on function key f2 if not f2")}, + {"l3", 94 UNTIC_COMMENT("label on function key f3 if not f3")}, + {"l4", 95 UNTIC_COMMENT("label on function key f4 if not f4")}, + {"l5", 96 UNTIC_COMMENT("lable on function key f5 if not f5")}, + {"l6", 97 UNTIC_COMMENT("label on function key f6 if not f6")}, + {"l7", 98 UNTIC_COMMENT("label on function key f7 if not f7")}, + {"l8", 99 UNTIC_COMMENT("label on function key f8 if not f8")}, + {"l9", 100 UNTIC_COMMENT("label on function key f9 if not f9")}, + {"la", 92 UNTIC_COMMENT("label on function key f10 if not f10")}, + {"le", 14 UNTIC_COMMENT("move left one space")}, + {"ll", 18 UNTIC_COMMENT("last line, first column (if no cup)")}, + {"ma", 397 UNTIC_COMMENT("map arrow keys rogue(1) motion keys")}, + {"mb", 26 UNTIC_COMMENT("turn on blinking")}, + {"md", 27 UNTIC_COMMENT("turn on bold (extra bright) mode")}, + {"me", 39 UNTIC_COMMENT("turn off all attributes")}, + {"mh", 30 UNTIC_COMMENT("turn on half-bright mode")}, + {"mk", 32 UNTIC_COMMENT("turn on blank mode (characters invisible)")}, + {"ml", 409 UNTIC_COMMENT("memory lock above")}, + {"mm", 102 UNTIC_COMMENT("turn on meta mode (8th-bit on)")}, + {"mo", 101 UNTIC_COMMENT("turn off meta mode")}, + {"mp", 33 UNTIC_COMMENT("turn on protected mode")}, + {"mr", 34 UNTIC_COMMENT("turn on reverse video mode")}, + {"mu", 410 UNTIC_COMMENT("memory unlock")}, + {"nd", 17 UNTIC_COMMENT("move right one space")}, + {"nl", 394 UNTIC_COMMENT("use to move down")}, + {"nw", 103 UNTIC_COMMENT("newline (behave like cr followed by lf)")}, + {"oc", 298 UNTIC_COMMENT("Set all color pairs to the original ones")}, + {"op", 297 UNTIC_COMMENT("Set default pair to its original value")}, + {"pO", 144 UNTIC_COMMENT("turn on printer for #1 bytes")}, + {"pc", 104 UNTIC_COMMENT("padding char (instead of null)")}, + {"pf", 119 UNTIC_COMMENT("turn off printer")}, + {"pk", 115 UNTIC_COMMENT("program function key #1 to type string #2")}, + {"pl", 116 UNTIC_COMMENT("program function key #1 to execute string #2")}, + {"pn", 147 UNTIC_COMMENT("program label #1 to show string #2")}, + {"po", 120 UNTIC_COMMENT("turn on printer")}, + {"ps", 118 UNTIC_COMMENT("print contents of screen")}, + {"px", 117 UNTIC_COMMENT("program function key #1 to transmit string #2")}, + {"r1", 122 UNTIC_COMMENT("reset string")}, + {"r2", 123 UNTIC_COMMENT("reset string")}, + {"r3", 124 UNTIC_COMMENT("reset string")}, + {"rP", 145 UNTIC_COMMENT("like ip but when in insert mode")}, + {"rc", 126 UNTIC_COMMENT("restore cursor to last position of sc")}, + {"rf", 125 UNTIC_COMMENT("name of reset file")}, + {"rp", 121 UNTIC_COMMENT("repeat char #1 #2 times")}, + {"rs", 393 UNTIC_COMMENT("terminal reset string")}, + {"s0", 364 UNTIC_COMMENT("Shift to code set 0 (EUC set 0, ASCII)")}, + {"s1", 365 UNTIC_COMMENT("Shift to code set 1")}, + {"s2", 366 UNTIC_COMMENT("Shift to code set 2")}, + {"s3", 367 UNTIC_COMMENT("Shift to code set 3")}, + {"sa", 131 UNTIC_COMMENT("define video attributes #1-#9 (PG9)")}, + {"sc", 128 UNTIC_COMMENT("save current cursor position")}, + {"se", 43 UNTIC_COMMENT("exit standout mode")}, + {"sf", 129 UNTIC_COMMENT("scroll text up")}, + {"so", 35 UNTIC_COMMENT("begin standout mode")}, + {"sp", 301 UNTIC_COMMENT("Set current color pair to #1")}, + {"sr", 130 UNTIC_COMMENT("scroll text down")}, + {"st", 132 UNTIC_COMMENT("set a tab in every row, current columns")}, + {"ta", 134 UNTIC_COMMENT("tab to next 8-space hardware tab stop")}, + {"te", 40 UNTIC_COMMENT("strings to end programs using cup")}, + {"ti", 28 UNTIC_COMMENT("string to start programs using cup")}, + {"ts", 135 UNTIC_COMMENT("move to status line")}, + {"u0", 287 UNTIC_COMMENT("User string #0")}, + {"u1", 288 UNTIC_COMMENT("User string #1")}, + {"u2", 289 UNTIC_COMMENT("User string #2")}, + {"u3", 290 UNTIC_COMMENT("User string #3")}, + {"u4", 291 UNTIC_COMMENT("User string #4")}, + {"u5", 292 UNTIC_COMMENT("User string #5")}, + {"u6", 293 UNTIC_COMMENT("User string #6")}, + {"u7", 294 UNTIC_COMMENT("User string #7")}, + {"u8", 295 UNTIC_COMMENT("User string #8")}, + {"u9", 296 UNTIC_COMMENT("User string #9")}, + {"uc", 136 UNTIC_COMMENT("underline char and move past it")}, + {"ue", 44 UNTIC_COMMENT("exit underline mode")}, + {"up", 19 UNTIC_COMMENT("up one line")}, + {"us", 36 UNTIC_COMMENT("begin underline mode")}, + {"vb", 45 UNTIC_COMMENT("visible bell (may not move cursor)")}, + {"ve", 16 UNTIC_COMMENT("make cursor appear normal (undo civis/cvvis)")}, + {"vi", 13 UNTIC_COMMENT("make cursor invisible")}, + {"vs", 20 UNTIC_COMMENT("make cursor very visible")}, + {"wi", 133 UNTIC_COMMENT("current window is lines #1-#2 cols #3-#4")}, + {"xl", 361 UNTIC_COMMENT("Program function key #1 to type string #2 and show string #3")}, + {"", -1 UNTIC_COMMENT(NULL)} +}; + +static int compute_cap_offset (char *cap, SLterminfo_Type *t, Tgetstr_Map_Type *map, unsigned int max_ofs) +{ + char cha, chb; + + (void) t; + cha = *cap++; chb = *cap; + + while (*map->name != 0) + { + if ((cha == *map->name) && (chb == *(map->name + 1))) + { + if (map->offset >= (int) max_ofs) return -1; + return map->offset; + } + map++; + } + return -1; +} + +char *_SLtt_tigetstr (SLterminfo_Type *t, char *cap) +{ + int offset; + + if (t == NULL) + return NULL; + + if (t->flags == SLTERMCAP) return tcap_getstr (cap, t); + + offset = compute_cap_offset (cap, t, Tgetstr_Map, t->num_string_offsets); + if (offset < 0) return NULL; + offset = make_integer (t->string_offsets + 2 * offset); + if (offset < 0) return NULL; + return t->string_table + offset; +} + +static Tgetstr_Map_Type Tgetnum_Map[] = +{ + {"BT", 30 UNTIC_COMMENT("number of buttons on mouse")}, + {"Co", 13 UNTIC_COMMENT("maximum numbers of colors on screen")}, + {"MW", 12 UNTIC_COMMENT("maxumum number of defineable windows")}, + {"NC", 15 UNTIC_COMMENT("video attributes that can't be used with colors")}, + {"Nl", 8 UNTIC_COMMENT("number of labels on screen")}, + {"Ya", 16 UNTIC_COMMENT("numbers of bytes buffered before printing")}, + {"Yb", 17 UNTIC_COMMENT("spacing of pins vertically in pins per inch")}, + {"Yc", 18 UNTIC_COMMENT("spacing of dots horizontally in dots per inch")}, + {"Yd", 19 UNTIC_COMMENT("maximum value in micro_..._address")}, + {"Ye", 20 UNTIC_COMMENT("maximum value in parm_..._micro")}, + {"Yf", 21 UNTIC_COMMENT("character size when in micro mode")}, + {"Yg", 22 UNTIC_COMMENT("line size when in micro mode")}, + {"Yh", 23 UNTIC_COMMENT("numbers of pins in print-head")}, + {"Yi", 24 UNTIC_COMMENT("horizontal resolution in units per line")}, + {"Yj", 25 UNTIC_COMMENT("vertical resolution in units per line")}, + {"Yk", 26 UNTIC_COMMENT("horizontal resolution in units per inch")}, + {"Yl", 27 UNTIC_COMMENT("vertical resolution in units per inch")}, + {"Ym", 28 UNTIC_COMMENT("print rate in chars per second")}, + {"Yn", 29 UNTIC_COMMENT("character step size when in double wide mode")}, + {"Yo", 31 UNTIC_COMMENT("number of passed for each bit-image row")}, + {"Yp", 32 UNTIC_COMMENT("type of bit-image device")}, + {"co", 0 UNTIC_COMMENT("number of columns in aline")}, + {"dB", 36 UNTIC_COMMENT("padding required for ^H")}, + {"dC", 34 UNTIC_COMMENT("pad needed for CR")}, + {"dN", 35 UNTIC_COMMENT("pad needed for LF")}, + {"dT", 37 UNTIC_COMMENT("padding required for ^I")}, + {"it", 1 UNTIC_COMMENT("tabs initially every # spaces")}, + {"kn", 38 UNTIC_COMMENT("count of function keys")}, + {"lh", 9 UNTIC_COMMENT("rows in each label")}, + {"li", 2 UNTIC_COMMENT("number of lines on screen or page")}, + {"lm", 3 UNTIC_COMMENT("lines of memory if > line. 0 => varies")}, + {"lw", 10 UNTIC_COMMENT("columns in each label")}, + {"ma", 11 UNTIC_COMMENT("maximum combined attributes terminal can handle")}, + {"pa", 14 UNTIC_COMMENT("maximum number of color-pairs on the screen")}, + {"pb", 5 UNTIC_COMMENT("lowest baud rate where padding needed")}, + {"sg", 4 UNTIC_COMMENT("number of blank chars left by smso or rmso")}, + {"ug", 33 UNTIC_COMMENT("number of blanks left by ul")}, + {"vt", 6 UNTIC_COMMENT("virtual terminal number (CB/unix)")}, + {"ws", 7 UNTIC_COMMENT("columns in status line")}, + {"", -1 UNTIC_COMMENT(NULL)} +}; + +int _SLtt_tigetnum (SLterminfo_Type *t, char *cap) +{ + int offset; + + if (t == NULL) + return -1; + + if (t->flags == SLTERMCAP) return tcap_getnum (cap, t); + + offset = compute_cap_offset (cap, t, Tgetnum_Map, t->num_numbers); + if (offset < 0) return -1; + return make_integer (t->numbers + 2 * offset); +} + +static Tgetstr_Map_Type Tgetflag_Map[] = +{ + {"5i", 22 UNTIC_COMMENT("printer won't echo on screen")}, + {"HC", 23 UNTIC_COMMENT("cursor is hard to see")}, + {"MT", 40 UNTIC_COMMENT("has meta key")}, + {"ND", 26 UNTIC_COMMENT("scrolling region is non-destructive")}, + {"NL", 41 UNTIC_COMMENT("move down with \n")}, + {"NP", 25 UNTIC_COMMENT("pad character does not exist")}, + {"NR", 24 UNTIC_COMMENT("smcup does not reverse rmcup")}, + {"YA", 30 UNTIC_COMMENT("only positive motion for hpa/mhpa caps")}, + {"YB", 31 UNTIC_COMMENT("using cr turns off micro mode")}, + {"YC", 32 UNTIC_COMMENT("printer needs operator to change character set")}, + {"YD", 33 UNTIC_COMMENT("only positive motion for vpa/mvpa caps")}, + {"YE", 34 UNTIC_COMMENT("printing in last column causes cr")}, + {"YF", 35 UNTIC_COMMENT("changing character pitch changes resolution")}, + {"YG", 36 UNTIC_COMMENT("changing line pitch changes resolution")}, + {"am", 1 UNTIC_COMMENT("terminal has automatic margins")}, + {"bs", 37 UNTIC_COMMENT("uses ^H to move left")}, + {"bw", 0 UNTIC_COMMENT("cub1 wraps from column 0 to last column")}, + {"cc", 27 UNTIC_COMMENT("terminal can re-define existing colors")}, + {"da", 11 UNTIC_COMMENT("display may be retained above the screen")}, + {"db", 12 UNTIC_COMMENT("display may be retained below the screen")}, + {"eo", 5 UNTIC_COMMENT("can erase overstrikes with a blank")}, + {"es", 16 UNTIC_COMMENT("escape can be used on the status line")}, + {"gn", 6 UNTIC_COMMENT("generic line type")}, + {"hc", 7 UNTIC_COMMENT("hardcopy terminal")}, + {"hl", 29 UNTIC_COMMENT("terminal uses only HLS color notation (tektronix)")}, + {"hs", 9 UNTIC_COMMENT("has extra status line")}, + {"hz", 18 UNTIC_COMMENT("can't print ~'s (hazeltine)")}, + {"in", 10 UNTIC_COMMENT("insert mode distinguishes nulls")}, + {"km", 8 UNTIC_COMMENT("Has a meta key, sets msb high")}, + {"mi", 13 UNTIC_COMMENT("safe to move while in insert mode")}, + {"ms", 14 UNTIC_COMMENT("safe to move while in standout mode")}, + {"nc", 39 UNTIC_COMMENT("no way to go to start of line")}, + {"ns", 38 UNTIC_COMMENT("crt cannot scroll")}, + {"nx", 21 UNTIC_COMMENT("padding won't work, xon/xoff required")}, + {"os", 15 UNTIC_COMMENT("terminal can overstrike")}, + {"pt", 42 UNTIC_COMMENT("has 8-char tabs invoked with ^I")}, + {"ul", 19 UNTIC_COMMENT("underline character overstrikes")}, + {"ut", 28 UNTIC_COMMENT("screen erased with background color")}, + {"xb", 2 UNTIC_COMMENT("beehive (f1=escape, f2=ctrl C)")}, + {"xn", 4 UNTIC_COMMENT("newline ignored after 80 cols (concept)")}, + {"xo", 20 UNTIC_COMMENT("terminal uses xon/xoff handshaking")}, + {"xr", 43 UNTIC_COMMENT("return clears the line")}, + {"xs", 3 UNTIC_COMMENT("standout not erased by overwriting (hp)")}, + {"xt", 17 UNTIC_COMMENT("tabs destructive, magic so char (t1061)")}, + {"", -1 UNTIC_COMMENT(NULL)} +}; + +int _SLtt_tigetflag (SLterminfo_Type *t, char *cap) +{ + int offset; + + if (t == NULL) return -1; + + if (t->flags == SLTERMCAP) return tcap_getflag (cap, t); + + offset = compute_cap_offset (cap, t, Tgetflag_Map, t->boolean_section_size); + + if (offset < 0) return -1; + return (int) *(t->boolean_flags + offset); +} + +/* These are my termcap routines. They only work with the TERMCAP environment + * variable. This variable must contain the termcap entry and NOT the file. + */ + +static int tcap_getflag (char *cap, SLterminfo_Type *t) +{ + char a, b; + char *f = (char *) t->boolean_flags; + char *fmax; + + if (f == NULL) return 0; + fmax = f + t->boolean_section_size; + + a = *cap; + b = *(cap + 1); + while (f < fmax) + { + if ((a == f[0]) && (b == f[1])) + return 1; + f += 2; + } + return 0; +} + +static char *tcap_get_cap (unsigned char *cap, unsigned char *caps, unsigned int len) +{ + unsigned char c0, c1; + unsigned char *caps_max; + + c0 = cap[0]; + c1 = cap[1]; + + if (caps == NULL) return NULL; + caps_max = caps + len; + while (caps < caps_max) + { + if ((c0 == caps[0]) && (c1 == caps[1])) + { + return (char *) caps + 3; + } + caps += (int) caps[2]; + } + return NULL; +} + +static int tcap_getnum (char *cap, SLterminfo_Type *t) +{ + cap = tcap_get_cap ((unsigned char *) cap, t->numbers, t->num_numbers); + if (cap == NULL) return -1; + return atoi (cap); +} + +static char *tcap_getstr (char *cap, SLterminfo_Type *t) +{ + return tcap_get_cap ((unsigned char *) cap, (unsigned char *) t->string_table, t->string_table_size); +} + +static int tcap_extract_field (unsigned char *t0) +{ + register unsigned char ch, *t = t0; + while (((ch = *t) != 0) && (ch != ':')) t++; + if (ch == ':') return (int) (t - t0); + return -1; +} + +int SLtt_Try_Termcap = 1; +static int tcap_getent (char *term, SLterminfo_Type *ti) +{ + unsigned char *termcap, ch; + unsigned char *buf, *b; + unsigned char *t; + int len; + + if (SLtt_Try_Termcap == 0) return -1; +#if 1 + /* XFREE86 xterm sets the TERMCAP environment variable to an invalid + * value. Specifically, it lacks the tc= string. + */ + if (!strncmp (term, "xterm", 5)) + return -1; +#endif + termcap = (unsigned char *) getenv ("TERMCAP"); + if ((termcap == NULL) || (*termcap == '/')) return -1; + + /* SUN Solaris 7&8 have bug in tset program under tcsh, + * eval `tset -s -A -Q` sets value of TERMCAP to ":", + * under other shells it works fine. + * SUN was informed, they marked it as duplicate of bug 4086585 + * but didn't care to fix it... + */ + if ((termcap[0] == ':') && (termcap[1] == 0)) + return -1; + + + /* We have a termcap so lets use it provided it does not have a reference + * to another terminal via tc=. In that case, use terminfo. The alternative + * would be to parse the termcap file which I do not want to do right now. + * Besides, this is a terminfo based system and if the termcap were parsed + * terminfo would almost never get a chance to run. In addition, the tc= + * thing should not occur if tset is used to set the termcap entry. + */ + t = termcap; + while ((len = tcap_extract_field (t)) != -1) + { + if ((len > 3) && (t[0] == 't') && (t[1] == 'c') && (t[2] == '=')) + return -1; + t += (len + 1); + } + + /* malloc some extra space just in case it is needed. */ + len = strlen ((char *) termcap) + 256; + if (NULL == (buf = (unsigned char *) SLmalloc ((unsigned int) len))) return -1; + + b = buf; + + /* The beginning of the termcap entry contains the names of the entry. + * It is terminated by a colon. + */ + + ti->terminal_names = (char *) b; + t = termcap; + len = tcap_extract_field (t); + if (len < 0) + { + SLfree ((char *)buf); + return -1; + } + strncpy ((char *) b, (char *) t, (unsigned int) len); + b[len] = 0; + b += len + 1; + ti->name_section_size = len; + + /* Now, we are really at the start of the termcap entries. Point the + * termcap variable here since we want to refer to this a number of times. + */ + termcap = t + (len + 1); + + /* Process strings first. */ + ti->string_table = (char *) b; + t = termcap; + while (-1 != (len = tcap_extract_field (t))) + { + unsigned char *b1; + unsigned char *tmax; + + /* We are looking for: XX=something */ + if ((len < 4) || (t[2] != '=') || (*t == '.')) + { + t += len + 1; + continue; + } + tmax = t + len; + b1 = b; + + while (t < tmax) + { + ch = *t++; + if ((ch == '\\') && (t < tmax)) + { + t = (unsigned char *) _SLexpand_escaped_char ((char *) t, (char *) &ch); + } + else if ((ch == '^') && (t < tmax)) + { + ch = *t++; + if (ch == '?') ch = 127; + else ch = (ch | 0x20) - ('a' - 1); + } + *b++ = ch; + } + /* Null terminate it. */ + *b++ = 0; + len = (int) (b - b1); + b1[2] = (unsigned char) len; /* replace the = by the length */ + /* skip colon to next field. */ + t++; + } + ti->string_table_size = (int) (b - (unsigned char *) ti->string_table); + + /* Now process the numbers. */ + + t = termcap; + ti->numbers = b; + while (-1 != (len = tcap_extract_field (t))) + { + unsigned char *b1; + unsigned char *tmax; + + /* We are looking for: XX#NUMBER */ + if ((len < 4) || (t[2] != '#') || (*t == '.')) + { + t += len + 1; + continue; + } + tmax = t + len; + b1 = b; + + while (t < tmax) + { + *b++ = *t++; + } + /* Null terminate it. */ + *b++ = 0; + len = (int) (b - b1); + b1[2] = (unsigned char) len; /* replace the # by the length */ + t++; + } + ti->num_numbers = (int) (b - ti->numbers); + + /* Now process the flags. */ + t = termcap; + ti->boolean_flags = b; + while (-1 != (len = tcap_extract_field (t))) + { + /* We are looking for: XX#NUMBER */ + if ((len != 2) || (*t == '.') || (*t <= ' ')) + { + t += len + 1; + continue; + } + b[0] = t[0]; + b[1] = t[1]; + t += 3; + b += 2; + } + ti->boolean_section_size = (int) (b - ti->boolean_flags); + ti->flags = SLTERMCAP; + return 0; +} + + +/* These routines are provided only for backward binary compatability. + * They will vanish in V2.x + */ +char *SLtt_tigetent (char *s) +{ + return (char *) _SLtt_tigetent (s); +} + +extern char *SLtt_tigetstr (char *s, char **p) +{ + if (p == NULL) + return NULL; + return _SLtt_tigetstr ((SLterminfo_Type *) *p, s); +} + +extern int SLtt_tigetnum (char *s, char **p) +{ + if (p == NULL) + return -1; + return _SLtt_tigetnum ((SLterminfo_Type *) *p, s); +} + + diff --git a/libslang/src/sltime.c b/libslang/src/sltime.c new file mode 100644 index 0000000..bfb7609 --- /dev/null +++ b/libslang/src/sltime.c @@ -0,0 +1,305 @@ +/* time related system calls */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include +#include + +#if defined(__BORLANDC__) +# include +#endif +#if defined(__GO32__) || (defined(__WATCOMC__) && !defined(__QNX__)) +# include +# include +#endif + +#include + +#include "slang.h" +#include "_slang.h" + +#ifdef __WIN32__ +#include +/* Sleep is defined badly in MSVC... */ +# ifdef _MSC_VER +# define sleep(n) _sleep((n)*1000) +# else +# ifdef sleep +# undef sleep +# endif +# define sleep(x) if(x)Sleep((x)*1000) +# endif +#endif + + +#if defined(IBMPC_SYSTEM) +/* For other system (Unix and VMS), _SLusleep is in sldisply.c */ +int _SLusleep (unsigned long s) +{ + sleep (s/1000000L); + s = s % 1000000L; + +# if defined(__WIN32__) + Sleep (s/1000); +#else +# if defined(__IBMC__) + DosSleep(s/1000); +# else +# if defined(_MSC_VER) + _sleep (s/1000); +# endif +# endif +#endif + return 0; +} +#endif + +#if defined(__IBMC__) && !defined(_AIX) +/* sleep is not a standard function in VA3. */ +unsigned int sleep (unsigned int seconds) +{ + DosSleep(1000L * ((long)seconds)); + return 0; +} +#endif + +static char *ctime_cmd (unsigned long *tt) +{ + char *t; + + t = ctime ((time_t *) tt); + t[24] = 0; /* knock off \n */ + return (t); +} + +static void sleep_cmd (void) +{ + unsigned int secs; +#if SLANG_HAS_FLOAT + unsigned long usecs; + double x; + + if (-1 == SLang_pop_double (&x, NULL, NULL)) + return; + + if (x < 0.0) + x = 0.0; + secs = (unsigned int) x; + sleep (secs); + x -= (double) secs; + usecs = (unsigned long) (1e6 * x); + if (usecs > 0) _SLusleep (usecs); +#else + if (-1 == SLang_pop_uinteger (&secs)) + return; + if (secs != 0) sleep (secs); +#endif +} + +static unsigned long _time_cmd (void) +{ + return (unsigned long) time (NULL); +} + +#if defined(__GO32__) +static char *djgpp_current_time (void) /*{{{*/ +{ + union REGS rg; + unsigned int year; + unsigned char month, day, weekday, hour, minute, sec; + char days[] = "SunMonTueWedThuFriSat"; + char months[] = "JanFebMarAprMayJunJulAugSepOctNovDec"; + static char the_date[26]; + + rg.h.ah = 0x2A; +#ifndef __WATCOMC__ + int86(0x21, &rg, &rg); + year = rg.x.cx & 0xFFFF; +#else + int386(0x21, &rg, &rg); + year = rg.x.ecx & 0xFFFF; +#endif + + month = 3 * (rg.h.dh - 1); + day = rg.h.dl; + weekday = 3 * rg.h.al; + + rg.h.ah = 0x2C; + +#ifndef __WATCOMC__ + int86(0x21, &rg, &rg); +#else + int386(0x21, &rg, &rg); +#endif + + hour = rg.h.ch; + minute = rg.h.cl; + sec = rg.h.dh; + + /* we want this form: Thu Apr 14 15:43:39 1994\n */ + sprintf(the_date, "%.3s %.3s%3d %02d:%02d:%02d %d\n", + days + weekday, months + month, + day, hour, minute, sec, year); + return the_date; +} + +/*}}}*/ + +#endif + +char *SLcurrent_time_string (void) /*{{{*/ +{ + char *the_time; +#ifndef __GO32__ + time_t myclock; + + myclock = time((time_t *) 0); + the_time = (char *) ctime(&myclock); +#else + the_time = djgpp_current_time (); +#endif + /* returns the form Sun Sep 16 01:03:52 1985\n\0 */ + the_time[24] = '\0'; + return(the_time); +} + +/*}}}*/ + +static SLang_CStruct_Field_Type TM_Struct [] = +{ + MAKE_CSTRUCT_INT_FIELD(struct tm, tm_sec, "tm_sec", 0), + MAKE_CSTRUCT_INT_FIELD(struct tm, tm_min, "tm_min", 0), + MAKE_CSTRUCT_INT_FIELD(struct tm, tm_hour, "tm_hour", 0), + MAKE_CSTRUCT_INT_FIELD(struct tm, tm_mday, "tm_mday", 0), + MAKE_CSTRUCT_INT_FIELD(struct tm, tm_mon, "tm_mon", 0), + MAKE_CSTRUCT_INT_FIELD(struct tm, tm_year, "tm_year", 0), + MAKE_CSTRUCT_INT_FIELD(struct tm, tm_wday, "tm_wday", 0), + MAKE_CSTRUCT_INT_FIELD(struct tm, tm_yday, "tm_yday", 0), + MAKE_CSTRUCT_INT_FIELD(struct tm, tm_isdst, "tm_isdst", 0), + SLANG_END_CSTRUCT_TABLE +}; + +static int push_tm_struct (struct tm *tms) +{ + return SLang_push_cstruct ((VOID_STAR) tms, TM_Struct); +} + +static void localtime_cmd (long *t) +{ + time_t tt = (time_t) *t; + (void) push_tm_struct (localtime (&tt)); +} + +static void gmtime_cmd (long *t) +{ +#ifdef HAVE_GMTIME + time_t tt = (time_t) *t; + (void) push_tm_struct (gmtime (&tt)); +#else + localtime_cmd (t); +#endif +} + +#ifdef HAVE_TIMES + +# ifdef HAVE_SYS_TIMES_H +# include +# endif + +#include + +#ifdef CLK_TCK +# define SECS_PER_TICK (1.0/(double)CLK_TCK) +#else +# ifdef CLOCKS_PER_SEC +# define SECS_PER_TICK (1.0/(double)CLOCKS_PER_SEC) +# else +# define SECS_PER_TICK (1.0/60.0) +# endif +#endif + +typedef struct +{ + double tms_utime; + double tms_stime; + double tms_cutime; + double tms_cstime; +} +TMS_Type; + +static SLang_CStruct_Field_Type TMS_Struct [] = +{ + MAKE_CSTRUCT_FIELD(TMS_Type, tms_utime, "tms_utime", SLANG_DOUBLE_TYPE, 0), + MAKE_CSTRUCT_FIELD(TMS_Type, tms_utime, "tms_stime", SLANG_DOUBLE_TYPE, 0), + MAKE_CSTRUCT_FIELD(TMS_Type, tms_utime, "tms_cutime", SLANG_DOUBLE_TYPE, 0), + MAKE_CSTRUCT_FIELD(TMS_Type, tms_utime, "tms_cstime", SLANG_DOUBLE_TYPE, 0), + SLANG_END_CSTRUCT_TABLE +}; + +static void times_cmd (void) +{ + TMS_Type d; + struct tms t; + + (void) times (&t); + + d.tms_utime = SECS_PER_TICK * (double)t.tms_utime; + d.tms_stime = SECS_PER_TICK * (double)t.tms_stime; + d.tms_cutime = SECS_PER_TICK * (double)t.tms_cutime; + d.tms_cstime = SECS_PER_TICK * (double)t.tms_cstime; + (void) SLang_push_cstruct ((VOID_STAR)&d, TMS_Struct); +} + +static struct tms Tic_TMS; + +static void tic_cmd (void) +{ + (void) times (&Tic_TMS); +} + +static double toc_cmd (void) +{ + struct tms t; + double d; + + (void) times (&t); + d = ((t.tms_utime - Tic_TMS.tms_utime) + + (t.tms_stime - Tic_TMS.tms_stime)) * SECS_PER_TICK; + Tic_TMS = t; + return d; +} + +#endif /* HAVE_TIMES */ + + +static SLang_Intrin_Fun_Type Time_Funs_Table [] = +{ + MAKE_INTRINSIC_1("ctime", ctime_cmd, SLANG_STRING_TYPE, SLANG_ULONG_TYPE), + MAKE_INTRINSIC_0("sleep", sleep_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_time", _time_cmd, SLANG_ULONG_TYPE), + MAKE_INTRINSIC_0("time", SLcurrent_time_string, SLANG_STRING_TYPE), + MAKE_INTRINSIC_1("localtime", localtime_cmd, SLANG_VOID_TYPE, SLANG_LONG_TYPE), + MAKE_INTRINSIC_1("gmtime", gmtime_cmd, SLANG_VOID_TYPE, SLANG_LONG_TYPE), + +#ifdef HAVE_TIMES + MAKE_INTRINSIC_0("times", times_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("tic", tic_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("toc", toc_cmd, SLANG_DOUBLE_TYPE), +#endif + SLANG_END_INTRIN_FUN_TABLE +}; + +int _SLang_init_sltime (void) +{ +#ifdef HAVE_TIMES + (void) tic_cmd (); +#endif + return SLadd_intrin_fun_table (Time_Funs_Table, NULL); +} + diff --git a/libslang/src/sltoken.c b/libslang/src/sltoken.c new file mode 100644 index 0000000..db8a6c4 --- /dev/null +++ b/libslang/src/sltoken.c @@ -0,0 +1,1533 @@ +/* Copyright (c) 1998, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#define MAX_TOKEN_LEN 254 +#define MAX_FILE_LINE_LEN 256 + +static char Empty_Line[1] = {0}; + +static int Default_Compile_Line_Num_Info; +static char *Input_Line = Empty_Line; +static char *Input_Line_Pointer; + +static SLPreprocess_Type *This_SLpp; + +static SLang_Load_Type *LLT; + +static char *map_token_to_string (_SLang_Token_Type *tok) +{ + char *s; + static char numbuf [32]; + unsigned char type; + s = NULL; + + if (tok != NULL) type = tok->type; + else type = 0; + + switch (type) + { + case 0: + s = "??"; + break; + + case CHAR_TOKEN: + case SHORT_TOKEN: + case INT_TOKEN: + case LONG_TOKEN: + s = numbuf; + sprintf (s, "%ld", tok->v.long_val); + break; + + case UCHAR_TOKEN: + case USHORT_TOKEN: + case UINT_TOKEN: + case ULONG_TOKEN: + s = numbuf; + sprintf (s, "%lu", (unsigned long)tok->v.long_val); + break; + + case OBRACKET_TOKEN: s = "["; break; + case CBRACKET_TOKEN: s = "]"; break; + case OPAREN_TOKEN: s = "("; break; + case CPAREN_TOKEN: s = ")"; break; + case OBRACE_TOKEN: s = "{"; break; + case CBRACE_TOKEN: s = "}"; break; + case DEREF_TOKEN: s = "@"; break; + case POUND_TOKEN: s = "#"; break; + case COMMA_TOKEN: s = ","; break; + case SEMICOLON_TOKEN: s = ";"; break; + case COLON_TOKEN: s = ":"; break; + +#if SLANG_HAS_FLOAT + case FLOAT_TOKEN: + case DOUBLE_TOKEN: + case COMPLEX_TOKEN: +#endif + case IDENT_TOKEN: + if ((tok->free_sval_flag == 0) || (tok->num_refs == 0)) + break; + /* drop */ + default: + s = tok->v.s_val; + break; + } + + if (s == NULL) + { + s = numbuf; + sprintf (s, "(0x%02X)", type); + } + + return s; +} + +static char *make_line_file_error (char *buf, unsigned int buflen, + _SLang_Token_Type *tok, char *dsc, int line, char *file) +{ +#if _SLANG_HAS_DEBUG_CODE + if (tok != NULL) line = tok->line_number; +#endif + if (file == NULL) file = "??"; + + (void) _SLsnprintf (buf, buflen, "%s: found '%s', line %d, file: %s", + dsc, map_token_to_string (tok), line, file); + + return buf; +} + +void _SLparse_error(char *str, _SLang_Token_Type *tok, int flag) +{ + char buf [1024]; + + if (str == NULL) + str = "Parse Error"; + + make_line_file_error (buf, sizeof (buf), tok, str, LLT->line_num, (char *) LLT->name); + + if ((flag == 0) && SLang_Error) + return; + + SLang_verror (SL_SYNTAX_ERROR, "%s", buf); +} + +static void do_line_file_error (int line, char *file) +{ + SLang_verror (SL_SYNTAX_ERROR, + "called from line %d, file: %s", line, file); +} + +#define ALPHA_CHAR 1 +#define DIGIT_CHAR 2 +#define EXCL_CHAR 3 +#define SEP_CHAR 4 +#define OP_CHAR 5 +#define DOT_CHAR 6 +#define BOLDOT_CHAR 7 +#define DQUOTE_CHAR 8 +#define QUOTE_CHAR 9 +#define COMMENT_CHAR 10 +#define NL_CHAR 11 +#define BAD_CHAR 12 +#define WHITE_CHAR 13 + +#define CHAR_EOF 255 + +#define CHAR_CLASS(c) (Char_Type_Table[(c)][0]) +#define CHAR_DATA(c) (Char_Type_Table[(c)][1]) + +/* In this table, if a single character can represent an operator, e.g., + * '&' (BAND_TOKEN), then it must be placed before multiple-character + * operators that begin with the same character, e.g., "&=". See + * get_op_token to see how this is exploited. + * + * The third character null terminates the operator string. This is for + * the token structure. + */ +static SLCONST char Operators [29][4] = +{ +#define OFS_EXCL 0 + {'!', '=', 0, NE_TOKEN}, +#define OFS_POUND 1 + {'#', 0, 0, POUND_TOKEN}, +#define OFS_BAND 2 + {'&', 0, 0, BAND_TOKEN}, + {'&', '&', 0, EOF_TOKEN}, + {'&', '=', 0, BANDEQS_TOKEN}, +#define OFS_STAR 5 + {'*', 0, 0, TIMES_TOKEN}, + {'*', '=', 0, TIMESEQS_TOKEN}, +#define OFS_PLUS 7 + {'+', 0, 0, ADD_TOKEN}, + {'+', '+', 0, PLUSPLUS_TOKEN}, + {'+', '=', 0, PLUSEQS_TOKEN}, +#define OFS_MINUS 10 + {'-', 0, 0, SUB_TOKEN}, + {'-', '-', 0, MINUSMINUS_TOKEN}, + {'-', '=', 0, MINUSEQS_TOKEN}, + {'-', '>', 0, NAMESPACE_TOKEN}, +#define OFS_DIV 14 + {'/', 0, 0, DIV_TOKEN}, + {'/', '=', 0, DIVEQS_TOKEN}, +#define OFS_LT 16 + {'<', 0, 0, LT_TOKEN}, + {'<', '=', 0, LE_TOKEN}, +#define OFS_EQS 18 + {'=', 0, 0, ASSIGN_TOKEN}, + {'=', '=', 0, EQ_TOKEN}, +#define OFS_GT 20 + {'>', 0, 0, GT_TOKEN}, + {'>', '=', 0, GE_TOKEN}, +#define OFS_AT 22 + {'@', 0, 0, DEREF_TOKEN}, +#define OFS_POW 23 + {'^', 0, 0, POW_TOKEN}, +#define OFS_BOR 24 + {'|', 0, 0, BOR_TOKEN}, + {'|', '|', 0, EOF_TOKEN}, + {'|', '=', 0, BOREQS_TOKEN}, +#define OFS_BNOT 27 + {'~', 0, 0, BNOT_TOKEN}, + { 0, 0, 0, EOF_TOKEN} +}; + +static SLCONST unsigned char Char_Type_Table[256][2] = +{ + { NL_CHAR, 0 }, /* 0x0 */ { BAD_CHAR, 0 }, /* 0x1 */ + { BAD_CHAR, 0 }, /* 0x2 */ { BAD_CHAR, 0 }, /* 0x3 */ + { BAD_CHAR, 0 }, /* 0x4 */ { BAD_CHAR, 0 }, /* 0x5 */ + { BAD_CHAR, 0 }, /* 0x6 */ { BAD_CHAR, 0 }, /* 0x7 */ + { WHITE_CHAR, 0 }, /* 0x8 */ { WHITE_CHAR, 0 }, /* 0x9 */ + { NL_CHAR, 0 }, /* \n */ { WHITE_CHAR, 0 }, /* 0xb */ + { WHITE_CHAR, 0 }, /* 0xc */ { WHITE_CHAR, 0 }, /* \r */ + { BAD_CHAR, 0 }, /* 0xe */ { BAD_CHAR, 0 }, /* 0xf */ + { BAD_CHAR, 0 }, /* 0x10 */ { BAD_CHAR, 0 }, /* 0x11 */ + { BAD_CHAR, 0 }, /* 0x12 */ { BAD_CHAR, 0 }, /* 0x13 */ + { BAD_CHAR, 0 }, /* 0x14 */ { BAD_CHAR, 0 }, /* 0x15 */ + { BAD_CHAR, 0 }, /* 0x16 */ { BAD_CHAR, 0 }, /* 0x17 */ + { BAD_CHAR, 0 }, /* 0x18 */ { BAD_CHAR, 0 }, /* 0x19 */ + { BAD_CHAR, 0 }, /* 0x1a */ { BAD_CHAR, 0 }, /* 0x1b */ + { BAD_CHAR, 0 }, /* 0x1c */ { BAD_CHAR, 0 }, /* 0x1d */ + { BAD_CHAR, 0 }, /* 0x1e */ { BAD_CHAR, 0 }, /* 0x1f */ + { WHITE_CHAR, 0 }, /* 0x20 */ { EXCL_CHAR, OFS_EXCL }, /* ! */ + { DQUOTE_CHAR, 0 }, /* " */ { OP_CHAR, OFS_POUND }, /* # */ + { ALPHA_CHAR, 0 }, /* $ */ { NL_CHAR, 0 },/* % */ + { OP_CHAR, OFS_BAND }, /* & */ { QUOTE_CHAR, 0 }, /* ' */ + { SEP_CHAR, OPAREN_TOKEN }, /* ( */ { SEP_CHAR, CPAREN_TOKEN }, /* ) */ + { OP_CHAR, OFS_STAR }, /* * */ { OP_CHAR, OFS_PLUS}, /* + */ + { SEP_CHAR, COMMA_TOKEN }, /* , */ { OP_CHAR, OFS_MINUS }, /* - */ + { DOT_CHAR, 0 }, /* . */ { OP_CHAR, OFS_DIV }, /* / */ + { DIGIT_CHAR, 0 }, /* 0 */ { DIGIT_CHAR, 0 }, /* 1 */ + { DIGIT_CHAR, 0 }, /* 2 */ { DIGIT_CHAR, 0 }, /* 3 */ + { DIGIT_CHAR, 0 }, /* 4 */ { DIGIT_CHAR, 0 }, /* 5 */ + { DIGIT_CHAR, 0 }, /* 6 */ { DIGIT_CHAR, 0 }, /* 7 */ + { DIGIT_CHAR, 0 }, /* 8 */ { DIGIT_CHAR, 0 }, /* 9 */ + { SEP_CHAR, COLON_TOKEN }, /* : */ { SEP_CHAR, SEMICOLON_TOKEN }, /* ; */ + { OP_CHAR, OFS_LT }, /* < */ { OP_CHAR, OFS_EQS }, /* = */ + { OP_CHAR, OFS_GT }, /* > */ { BAD_CHAR, 0 }, /* ? */ + { OP_CHAR, OFS_AT}, /* @ */ { ALPHA_CHAR, 0 }, /* A */ + { ALPHA_CHAR, 0 }, /* B */ { ALPHA_CHAR, 0 }, /* C */ + { ALPHA_CHAR, 0 }, /* D */ { ALPHA_CHAR, 0 }, /* E */ + { ALPHA_CHAR, 0 }, /* F */ { ALPHA_CHAR, 0 }, /* G */ + { ALPHA_CHAR, 0 }, /* H */ { ALPHA_CHAR, 0 }, /* I */ + { ALPHA_CHAR, 0 }, /* J */ { ALPHA_CHAR, 0 }, /* K */ + { ALPHA_CHAR, 0 }, /* L */ { ALPHA_CHAR, 0 }, /* M */ + { ALPHA_CHAR, 0 }, /* N */ { ALPHA_CHAR, 0 }, /* O */ + { ALPHA_CHAR, 0 }, /* P */ { ALPHA_CHAR, 0 }, /* Q */ + { ALPHA_CHAR, 0 }, /* R */ { ALPHA_CHAR, 0 }, /* S */ + { ALPHA_CHAR, 0 }, /* T */ { ALPHA_CHAR, 0 }, /* U */ + { ALPHA_CHAR, 0 }, /* V */ { ALPHA_CHAR, 0 }, /* W */ + { ALPHA_CHAR, 0 }, /* X */ { ALPHA_CHAR, 0 }, /* Y */ + { ALPHA_CHAR, 0 }, /* Z */ { SEP_CHAR, OBRACKET_TOKEN }, /* [ */ + { BAD_CHAR, 0 }, /* \ */ { SEP_CHAR, CBRACKET_TOKEN }, /* ] */ + { OP_CHAR, OFS_POW }, /* ^ */ { ALPHA_CHAR, 0 }, /* _ */ + { BAD_CHAR, 0 }, /* ` */ { ALPHA_CHAR, 0 }, /* a */ + { ALPHA_CHAR, 0 }, /* b */ { ALPHA_CHAR, 0 }, /* c */ + { ALPHA_CHAR, 0 }, /* d */ { ALPHA_CHAR, 0 }, /* e */ + { ALPHA_CHAR, 0 }, /* f */ { ALPHA_CHAR, 0 }, /* g */ + { ALPHA_CHAR, 0 }, /* h */ { ALPHA_CHAR, 0 }, /* i */ + { ALPHA_CHAR, 0 }, /* j */ { ALPHA_CHAR, 0 }, /* k */ + { ALPHA_CHAR, 0 }, /* l */ { ALPHA_CHAR, 0 }, /* m */ + { ALPHA_CHAR, 0 }, /* n */ { ALPHA_CHAR, 0 }, /* o */ + { ALPHA_CHAR, 0 }, /* p */ { ALPHA_CHAR, 0 }, /* q */ + { ALPHA_CHAR, 0 }, /* r */ { ALPHA_CHAR, 0 }, /* s */ + { ALPHA_CHAR, 0 }, /* t */ { ALPHA_CHAR, 0 }, /* u */ + { ALPHA_CHAR, 0 }, /* v */ { ALPHA_CHAR, 0 }, /* w */ + { ALPHA_CHAR, 0 }, /* x */ { ALPHA_CHAR, 0 }, /* y */ + { ALPHA_CHAR, 0 }, /* z */ { SEP_CHAR, OBRACE_TOKEN }, /* { */ + { OP_CHAR, OFS_BOR }, /* | */ { SEP_CHAR, CBRACE_TOKEN }, /* } */ + { OP_CHAR, OFS_BNOT }, /* ~ */ { BAD_CHAR, 0 }, /* 0x7f */ + + { ALPHA_CHAR, 0 }, /* € */ { ALPHA_CHAR, 0 }, /* */ + { ALPHA_CHAR, 0 }, /* ‚ */ { ALPHA_CHAR, 0 }, /* ƒ */ + { ALPHA_CHAR, 0 }, /* „ */ { ALPHA_CHAR, 0 }, /* … */ + { ALPHA_CHAR, 0 }, /* † */ { ALPHA_CHAR, 0 }, /* ‡ */ + { ALPHA_CHAR, 0 }, /* ˆ */ { ALPHA_CHAR, 0 }, /* ‰ */ + { ALPHA_CHAR, 0 }, /* Š */ { ALPHA_CHAR, 0 }, /* ‹ */ + { ALPHA_CHAR, 0 }, /* Œ */ { ALPHA_CHAR, 0 }, /* */ + { ALPHA_CHAR, 0 }, /* Ž */ { ALPHA_CHAR, 0 }, /* */ + { ALPHA_CHAR, 0 }, /* */ { ALPHA_CHAR, 0 }, /* ‘ */ + { ALPHA_CHAR, 0 }, /* ’ */ { ALPHA_CHAR, 0 }, /* “ */ + { ALPHA_CHAR, 0 }, /* ” */ { ALPHA_CHAR, 0 }, /* • */ + { ALPHA_CHAR, 0 }, /* – */ { ALPHA_CHAR, 0 }, /* — */ + { ALPHA_CHAR, 0 }, /* ˜ */ { ALPHA_CHAR, 0 }, /* ™ */ + { ALPHA_CHAR, 0 }, /* š */ { ALPHA_CHAR, 0 }, /* › */ + { ALPHA_CHAR, 0 }, /* œ */ { ALPHA_CHAR, 0 }, /* */ + { ALPHA_CHAR, 0 }, /* ž */ { ALPHA_CHAR, 0 }, /* Ÿ */ + { ALPHA_CHAR, 0 }, /*   */ { ALPHA_CHAR, 0 }, /* ¡ */ + { ALPHA_CHAR, 0 }, /* ¢ */ { ALPHA_CHAR, 0 }, /* £ */ + { ALPHA_CHAR, 0 }, /* ¤ */ { ALPHA_CHAR, 0 }, /* ¥ */ + { ALPHA_CHAR, 0 }, /* ¦ */ { ALPHA_CHAR, 0 }, /* § */ + { ALPHA_CHAR, 0 }, /* ¨ */ { ALPHA_CHAR, 0 }, /* © */ + { ALPHA_CHAR, 0 }, /* ª */ { ALPHA_CHAR, 0 }, /* « */ + { ALPHA_CHAR, 0 }, /* ¬ */ { ALPHA_CHAR, 0 }, /* ­ */ + { ALPHA_CHAR, 0 }, /* ® */ { ALPHA_CHAR, 0 }, /* ¯ */ + { ALPHA_CHAR, 0 }, /* ° */ { ALPHA_CHAR, 0 }, /* ± */ + { ALPHA_CHAR, 0 }, /* ² */ { ALPHA_CHAR, 0 }, /* ³ */ + { ALPHA_CHAR, 0 }, /* ´ */ { ALPHA_CHAR, 0 }, /* µ */ + { ALPHA_CHAR, 0 }, /* ¶ */ { ALPHA_CHAR, 0 }, /* · */ + { ALPHA_CHAR, 0 }, /* ¸ */ { ALPHA_CHAR, 0 }, /* ¹ */ + { ALPHA_CHAR, 0 }, /* º */ { ALPHA_CHAR, 0 }, /* » */ + { ALPHA_CHAR, 0 }, /* ¼ */ { ALPHA_CHAR, 0 }, /* ½ */ + { ALPHA_CHAR, 0 }, /* ¾ */ { ALPHA_CHAR, 0 }, /* ¿ */ + { ALPHA_CHAR, 0 }, /* À */ { ALPHA_CHAR, 0 }, /* Á */ + { ALPHA_CHAR, 0 }, /*  */ { ALPHA_CHAR, 0 }, /* à */ + { ALPHA_CHAR, 0 }, /* Ä */ { ALPHA_CHAR, 0 }, /* Å */ + { ALPHA_CHAR, 0 }, /* Æ */ { ALPHA_CHAR, 0 }, /* Ç */ + { ALPHA_CHAR, 0 }, /* È */ { ALPHA_CHAR, 0 }, /* É */ + { ALPHA_CHAR, 0 }, /* Ê */ { ALPHA_CHAR, 0 }, /* Ë */ + { ALPHA_CHAR, 0 }, /* Ì */ { ALPHA_CHAR, 0 }, /* Í */ + { ALPHA_CHAR, 0 }, /* Î */ { ALPHA_CHAR, 0 }, /* Ï */ + { ALPHA_CHAR, 0 }, /* Ð */ { ALPHA_CHAR, 0 }, /* Ñ */ + { ALPHA_CHAR, 0 }, /* Ò */ { ALPHA_CHAR, 0 }, /* Ó */ + { ALPHA_CHAR, 0 }, /* Ô */ { ALPHA_CHAR, 0 }, /* Õ */ + { ALPHA_CHAR, 0 }, /* Ö */ { ALPHA_CHAR, 0 }, /* × */ + { ALPHA_CHAR, 0 }, /* Ø */ { ALPHA_CHAR, 0 }, /* Ù */ + { ALPHA_CHAR, 0 }, /* Ú */ { ALPHA_CHAR, 0 }, /* Û */ + { ALPHA_CHAR, 0 }, /* Ü */ { ALPHA_CHAR, 0 }, /* Ý */ + { ALPHA_CHAR, 0 }, /* Þ */ { ALPHA_CHAR, 0 }, /* ß */ + { ALPHA_CHAR, 0 }, /* à */ { ALPHA_CHAR, 0 }, /* á */ + { ALPHA_CHAR, 0 }, /* â */ { ALPHA_CHAR, 0 }, /* ã */ + { ALPHA_CHAR, 0 }, /* ä */ { ALPHA_CHAR, 0 }, /* å */ + { ALPHA_CHAR, 0 }, /* æ */ { ALPHA_CHAR, 0 }, /* ç */ + { ALPHA_CHAR, 0 }, /* è */ { ALPHA_CHAR, 0 }, /* é */ + { ALPHA_CHAR, 0 }, /* ê */ { ALPHA_CHAR, 0 }, /* ë */ + { ALPHA_CHAR, 0 }, /* ì */ { ALPHA_CHAR, 0 }, /* í */ + { ALPHA_CHAR, 0 }, /* î */ { ALPHA_CHAR, 0 }, /* ï */ + { ALPHA_CHAR, 0 }, /* ð */ { ALPHA_CHAR, 0 }, /* ñ */ + { ALPHA_CHAR, 0 }, /* ò */ { ALPHA_CHAR, 0 }, /* ó */ + { ALPHA_CHAR, 0 }, /* ô */ { ALPHA_CHAR, 0 }, /* õ */ + { ALPHA_CHAR, 0 }, /* ö */ { ALPHA_CHAR, 0 }, /* ÷ */ + { ALPHA_CHAR, 0 }, /* ø */ { ALPHA_CHAR, 0 }, /* ù */ + { ALPHA_CHAR, 0 }, /* ú */ { ALPHA_CHAR, 0 }, /* û */ + { ALPHA_CHAR, 0 }, /* ü */ { ALPHA_CHAR, 0 }, /* ý */ + { ALPHA_CHAR, 0 }, /* þ */ { ALPHA_CHAR, 0 }, /* ÿ */ +}; + +int _SLcheck_identifier_syntax (char *name) +{ + unsigned char *p; + + p = (unsigned char *) name; + if (ALPHA_CHAR == Char_Type_Table[*p][0]) while (1) + { + unsigned ch; + unsigned char type; + + ch = *++p; + + type = Char_Type_Table [ch][0]; + if ((type != ALPHA_CHAR) && (type != DIGIT_CHAR)) + { + if (ch == 0) + return 0; + break; + } + } + + SLang_verror (SL_SYNTAX_ERROR, + "Identifier or structure field name '%s' contains an illegal character", name); + return -1; +} + +static unsigned char prep_get_char (void) +{ + register unsigned char ch; + + if (0 != (ch = *Input_Line_Pointer++)) + return ch; + + Input_Line_Pointer--; + return 0; +} + +static void unget_prep_char (unsigned char ch) +{ + if ((Input_Line_Pointer != Input_Line) + && (ch != 0)) + Input_Line_Pointer--; + /* *Input_Line_Pointer = ch; -- Do not modify the Input_Line */ +} + +#include "keywhash.c" + +static int get_ident_token (_SLang_Token_Type *tok, unsigned char *s, unsigned int len) +{ + unsigned char ch; + unsigned char type; + Keyword_Table_Type *table; + + while (1) + { + ch = prep_get_char (); + type = CHAR_CLASS (ch); + if ((type != ALPHA_CHAR) && (type != DIGIT_CHAR)) + { + unget_prep_char (ch); + break; + } + s [len++] = ch; + } + + s[len] = 0; + + /* check if keyword */ + table = is_keyword ((char *) s, len); + if (table != NULL) + { + tok->v.s_val = table->name; + return (tok->type = table->type); + } + + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, len, &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = IDENT_TOKEN); +} + +static int get_number_token (_SLang_Token_Type *tok, unsigned char *s, unsigned int len) +{ + unsigned char ch; + unsigned char type; + + /* Look for pattern [0-9.xX]*([eE][-+]?[digits])?[ijfhul]? */ + while (1) + { + ch = prep_get_char (); + + type = CHAR_CLASS (ch); + if ((type != DIGIT_CHAR) && (type != DOT_CHAR)) + { + if ((ch != 'x') && (ch != 'X')) + break; + /* It must be hex */ + do + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + + s[len++] = ch; + ch = prep_get_char (); + type = CHAR_CLASS (ch); + } + while ((type == DIGIT_CHAR) || (type == ALPHA_CHAR)); + break; + } + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s [len++] = ch; + } + + /* At this point, type and ch are synchronized */ + + if ((ch == 'e') || (ch == 'E')) + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s[len++] = ch; + ch = prep_get_char (); + if ((ch == '+') || (ch == '-')) + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s[len++] = ch; + ch = prep_get_char (); + } + + while (DIGIT_CHAR == (type = CHAR_CLASS(ch))) + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s[len++] = ch; + ch = prep_get_char (); + } + } + + while (ALPHA_CHAR == type) + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s[len++] = ch; + ch = prep_get_char (); + type = CHAR_CLASS(ch); + } + + unget_prep_char (ch); + s[len] = 0; + + switch (SLang_guess_type ((char *) s)) + { + default: + tok->v.s_val = (char *) s; + _SLparse_error ("Not a number", tok, 0); + return (tok->type = EOF_TOKEN); + +#if SLANG_HAS_FLOAT + case SLANG_FLOAT_TYPE: + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, len, &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = FLOAT_TOKEN); + + case SLANG_DOUBLE_TYPE: + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, len, &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = DOUBLE_TOKEN); +#endif +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, len, &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = COMPLEX_TOKEN); +#endif + case SLANG_CHAR_TYPE: + tok->v.long_val = (char)SLatol (s); + return tok->type = CHAR_TOKEN; + case SLANG_UCHAR_TYPE: + tok->v.long_val = (unsigned char)SLatol (s); + return tok->type = UCHAR_TOKEN; + case SLANG_SHORT_TYPE: + tok->v.long_val = (short)SLatol (s); + return tok->type = SHORT_TOKEN; + case SLANG_USHORT_TYPE: + tok->v.long_val = (unsigned short)SLatoul (s); + return tok->type = USHORT_TOKEN; + case SLANG_INT_TYPE: + tok->v.long_val = (int)SLatol (s); + return tok->type = INT_TOKEN; + case SLANG_UINT_TYPE: + tok->v.long_val = (unsigned int)SLatoul (s); + return tok->type = UINT_TOKEN; + case SLANG_LONG_TYPE: + tok->v.long_val = SLatol (s); + return tok->type = LONG_TOKEN; + case SLANG_ULONG_TYPE: + tok->v.long_val = SLatoul (s); + return tok->type = ULONG_TOKEN; + } + + too_long_return_error: + _SLparse_error ("Number too long for buffer", NULL, 0); + return (tok->type == EOF_TOKEN); +} + +static int get_op_token (_SLang_Token_Type *tok, char ch) +{ + unsigned int offset; + char second_char; + unsigned char type; + SLCONST char *name; + + /* operators are: + - / * ++ -- += -= = == != > < >= <= | etc.. + * These lex to the longest valid operator token. + */ + + offset = CHAR_DATA((unsigned char) ch); + if (0 == Operators [offset][1]) + { + name = Operators [offset]; + type = name [3]; + } + else + { + type = EOF_TOKEN; + name = NULL; + } + + second_char = prep_get_char (); + do + { + if (second_char == Operators[offset][1]) + { + name = Operators [offset]; + type = name [3]; + break; + } + offset++; + } + while (ch == Operators[offset][0]); + + tok->type = type; + + if (type == EOF_TOKEN) + { + _SLparse_error ("Operator not supported", NULL, 0); + return type; + } + + tok->v.s_val = (char *)name; + + if (name[1] == 0) + unget_prep_char (second_char); + + return type; +} + +/* If this returns non-zero, then it is a binary string */ +static int expand_escaped_string (register char *s, + register char *t, register char *tmax, + unsigned int *lenp) +{ + char *s0; + int is_binary = 0; + char ch; + + s0 = s; + while (t < tmax) + { + ch = *t++; + if (ch == '\\') + { + t = _SLexpand_escaped_char (t, &ch); + if (ch == 0) is_binary = 1; + } + *s++ = ch; + } + *s = 0; + + *lenp = (unsigned char) (s - s0); + return is_binary; +} + +static int get_string_token (_SLang_Token_Type *tok, unsigned char quote_char, + unsigned char *s) +{ + unsigned char ch; + unsigned int len = 0; + int has_quote = 0; + int is_binary; + + while (1) + { + ch = prep_get_char (); + if (ch == 0) + { + _SLparse_error("Expecting quote-character", NULL, 0); + return (tok->type = EOF_TOKEN); + } + if (ch == quote_char) break; + + s[len++] = ch; + + if (len == (MAX_TOKEN_LEN - 1)) + { + _SLparse_error ("String too long for buffer", NULL, 0); + return (tok->type == EOF_TOKEN); + } + + if (ch == '\\') + { + has_quote = 1; + ch = prep_get_char (); + s[len++] = ch; + } + } + + s[len] = 0; + + if (has_quote) + is_binary = expand_escaped_string ((char *) s, (char *)s, (char *)s + len, &len); + else is_binary = 0; + + if ('"' == quote_char) + { + tok->free_sval_flag = 1; + if (is_binary) + { + tok->v.b_val = SLbstring_create (s, len); + return tok->type = BSTRING_TOKEN; + } + else + { + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, + len, + &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = STRING_TOKEN); + } + } + + /* else single character */ + if ((len == 0) || (s[1] != 0)) + { + _SLparse_error("Single char expected", NULL, 0); + return (tok->type = EOF_TOKEN); + } + + tok->v.long_val = s[0]; + return (tok->type = UCHAR_TOKEN); +} + +static int extract_token (_SLang_Token_Type *tok, unsigned char ch, unsigned char t) +{ + unsigned char s [MAX_TOKEN_LEN]; + unsigned int slen; + + s[0] = (char) ch; + slen = 1; + + switch (t) + { + case ALPHA_CHAR: + return get_ident_token (tok, s, slen); + + case OP_CHAR: + return get_op_token (tok, ch); + + case DIGIT_CHAR: + return get_number_token (tok, s, slen); + + case EXCL_CHAR: + ch = prep_get_char (); + s [slen++] = ch; + t = CHAR_CLASS(ch); + if (t == ALPHA_CHAR) return get_ident_token (tok, s, slen); + if (t == OP_CHAR) + { + unget_prep_char (ch); + return get_op_token (tok, '!'); + } + _SLparse_error("Misplaced !", NULL, 0); + return -1; + + case DOT_CHAR: + ch = prep_get_char (); + if (DIGIT_CHAR == CHAR_CLASS(ch)) + { + s [slen++] = ch; + return get_number_token (tok, s, slen); + } + unget_prep_char (ch); + return (tok->type = DOT_TOKEN); + + case SEP_CHAR: + return (tok->type = CHAR_DATA(ch)); + + case DQUOTE_CHAR: + case QUOTE_CHAR: + return get_string_token (tok, ch, s); + + default: + _SLparse_error("Invalid character", NULL, 0); + return (tok->type = EOF_TOKEN); + } +} + +int _SLget_rpn_token (_SLang_Token_Type *tok) +{ + unsigned char ch; + + tok->v.s_val = "??"; + while ((ch = *Input_Line_Pointer) != 0) + { + unsigned char t; + + Input_Line_Pointer++; + if (WHITE_CHAR == (t = CHAR_CLASS(ch))) + continue; + + if (NL_CHAR == t) + break; + + return extract_token (tok, ch, t); + } + Input_Line_Pointer = Empty_Line; + return EOF_TOKEN; +} + +int _SLget_token (_SLang_Token_Type *tok) +{ + unsigned char ch; + unsigned char t; + + tok->num_refs = 1; + tok->free_sval_flag = 0; + tok->v.s_val = "??"; +#if _SLANG_HAS_DEBUG_CODE + tok->line_number = LLT->line_num; +#endif + if (SLang_Error || (Input_Line == NULL)) + return (tok->type = EOF_TOKEN); + + while (1) + { + ch = *Input_Line_Pointer++; + if (WHITE_CHAR == (t = CHAR_CLASS (ch))) + continue; + + if (t != NL_CHAR) + return extract_token (tok, ch, t); + + do + { + LLT->line_num++; +#if _SLANG_HAS_DEBUG_CODE + tok->line_number++; +#endif + Input_Line = LLT->read(LLT); + if ((NULL == Input_Line) || SLang_Error) + { + Input_Line_Pointer = Input_Line = NULL; + return (tok->type = EOF_TOKEN); + } + } + while (0 == SLprep_line_ok(Input_Line, This_SLpp)); + + Input_Line_Pointer = Input_Line; + if (*Input_Line_Pointer == '.') + { + Input_Line_Pointer++; + return tok->type = RPN_TOKEN; + } + } +} + +static int prep_exists_function (char *line, char comment) +{ + char buf[MAX_FILE_LINE_LEN], *b, *bmax; + unsigned char ch; + + bmax = buf + (sizeof (buf) - 1); + + while (1) + { + /* skip whitespace */ + while ((ch = (unsigned char) *line), + ch && (ch != '\n') && (ch <= ' ')) + line++; + + if ((ch <= '\n') + || (ch == (unsigned char) comment)) break; + + b = buf; + while ((ch = (unsigned char) *line) > ' ') + { + if (b < bmax) *b++ = (char) ch; + line++; + } + *b = 0; + + if (SLang_is_defined (buf)) + return 1; + } + + return 0; +} + +static int prep_eval_expr (char *expr) +{ + int ret; + char *end; + + end = strchr (expr, '\n'); + if (end == NULL) + end = expr + strlen (expr); + expr = SLmake_nstring (expr, (unsigned int) (end - expr)); + if (expr == NULL) + return -1; + + if ((0 != SLang_load_string (expr)) + || (-1 == SLang_pop_integer (&ret))) + ret = -1; + else + ret = (ret != 0); + + SLfree (expr); + return ret; +} + + +int SLang_load_object (SLang_Load_Type *x) +{ + SLPreprocess_Type this_pp; + SLPreprocess_Type *save_this_pp; + SLang_Load_Type *save_llt; + char *save_input_line, *save_input_line_ptr; +#if _SLANG_HAS_DEBUG_CODE + int save_compile_line_num_info; +#endif + int save_auto_declare_variables; + + if (SLprep_exists_hook == NULL) + SLprep_exists_hook = prep_exists_function; + + if (_SLprep_eval_hook == NULL) + _SLprep_eval_hook = prep_eval_expr; + + if (-1 == SLprep_open_prep (&this_pp)) return -1; + + if (-1 == _SLcompile_push_context (x)) + return -1; + +#if _SLANG_HAS_DEBUG_CODE + save_compile_line_num_info = _SLang_Compile_Line_Num_Info; +#endif + save_this_pp = This_SLpp; + save_input_line = Input_Line; + save_input_line_ptr = Input_Line_Pointer; + save_llt = LLT; + save_auto_declare_variables = _SLang_Auto_Declare_Globals; + + This_SLpp = &this_pp; + Input_Line_Pointer = Input_Line = Empty_Line; + LLT = x; + + x->line_num = 0; + x->parse_level = 0; + _SLang_Auto_Declare_Globals = x->auto_declare_globals; + +#if _SLANG_HAS_DEBUG_CODE + _SLang_Compile_Line_Num_Info = Default_Compile_Line_Num_Info; +#endif + + _SLparse_start (x); + if (SLang_Error) + do_line_file_error (x->line_num, x->name); + + _SLang_Auto_Declare_Globals = save_auto_declare_variables; + + if (SLang_Error) SLang_restart (0); + + (void) _SLcompile_pop_context (); + + Input_Line = save_input_line; + Input_Line_Pointer = save_input_line_ptr; + LLT = save_llt; + This_SLpp = save_this_pp; + +#if _SLANG_HAS_DEBUG_CODE + _SLang_Compile_Line_Num_Info = save_compile_line_num_info; +#endif + + if (SLang_Error) return -1; + return 0; +} + +SLang_Load_Type *SLns_allocate_load_type (char *name, char *namespace_name) +{ + SLang_Load_Type *x; + + if (NULL == (x = (SLang_Load_Type *)SLmalloc (sizeof (SLang_Load_Type)))) + return NULL; + memset ((char *) x, 0, sizeof (SLang_Load_Type)); + + if (name == NULL) name = ""; + + if (NULL == (x->name = SLang_create_slstring (name))) + { + SLfree ((char *) x); + return NULL; + } + + if (namespace_name != NULL) + { + if (NULL == (x->namespace_name = SLang_create_slstring (namespace_name))) + { + SLang_free_slstring (x->name); + SLfree ((char *) x); + return NULL; + } + } + + return x; +} + +SLang_Load_Type *SLallocate_load_type (char *name) +{ + return SLns_allocate_load_type (name, NULL); +} + +void SLdeallocate_load_type (SLang_Load_Type *x) +{ + if (x != NULL) + { + SLang_free_slstring (x->name); + SLang_free_slstring (x->namespace_name); + SLfree ((char *) x); + } +} + +typedef struct +{ + char *string; + char *ptr; +} +String_Client_Data_Type; + +static char *read_from_string (SLang_Load_Type *x) +{ + String_Client_Data_Type *data; + char *s, *s1, ch; + + data = (String_Client_Data_Type *)x->client_data; + s1 = s = data->ptr; + + if (*s == 0) + return NULL; + + while ((ch = *s) != 0) + { + s++; + if (ch == '\n') + break; + } + + data->ptr = s; + return s1; +} + +int SLang_load_string (char *string) +{ + return SLns_load_string (string, NULL); +} + +int SLns_load_string (char *string, char *ns_name) +{ + SLang_Load_Type *x; + String_Client_Data_Type data; + int ret; + + if (string == NULL) + return -1; + + /* Grab a private copy in case loading modifies string */ + if (NULL == (string = SLang_create_slstring (string))) + return -1; + + /* To avoid creating a static data space for every string loaded, + * all string objects will be regarded as identical. So, identify + * all of them by ***string*** + */ + if (NULL == (x = SLns_allocate_load_type ("***string***", ns_name))) + { + SLang_free_slstring (string); + return -1; + } + + x->client_data = (VOID_STAR) &data; + x->read = read_from_string; + + data.ptr = data.string = string; + if (-1 == (ret = SLang_load_object (x))) + SLang_verror (SLang_Error, "called from eval: %s", string); + + SLang_free_slstring (string); + SLdeallocate_load_type (x); + return ret; +} + +typedef struct +{ + char *buf; + FILE *fp; +} +File_Client_Data_Type; + +char *SLang_User_Prompt; +static char *read_from_file (SLang_Load_Type *x) +{ + FILE *fp; + File_Client_Data_Type *c; + + c = (File_Client_Data_Type *)x->client_data; + fp = c->fp; + + if ((fp == stdin) && (SLang_User_Prompt != NULL)) + { + fputs (SLang_User_Prompt, stdout); + fflush (stdout); + } + + return fgets (c->buf, MAX_FILE_LINE_LEN, c->fp); +} + +static int Load_File_Verbose = 0; +int SLang_load_file_verbose (int v) +{ + int v1 = Load_File_Verbose; + Load_File_Verbose = v; + return v1; +} + +/* Note that file could be freed from Slang during run of this routine + * so get it and store it !! (e.g., autoloading) + */ +int (*SLang_Load_File_Hook) (char *); +int (*SLns_Load_File_Hook) (char *, char *); +int SLang_load_file (char *f) +{ + return SLns_load_file (f, NULL); +} + +int SLns_load_file (char *f, char *ns_name) +{ + File_Client_Data_Type client_data; + SLang_Load_Type *x; + char *name, *buf; + FILE *fp; + + if ((ns_name == NULL) && (NULL != SLang_Load_File_Hook)) + return (*SLang_Load_File_Hook) (f); + + if (SLns_Load_File_Hook != NULL) + return (*SLns_Load_File_Hook) (f, ns_name); + + if (f == NULL) + name = SLang_create_slstring (""); + else + name = _SLpath_find_file (f); + + if (name == NULL) + return -1; + + if (NULL == (x = SLns_allocate_load_type (name, ns_name))) + { + SLang_free_slstring (name); + return -1; + } + + buf = NULL; + + if (f != NULL) + { + fp = fopen (name, "r"); + if (Load_File_Verbose) + SLang_vmessage ("Loading %s", name); + } + else + fp = stdin; + + if (fp == NULL) + SLang_verror (SL_OBJ_NOPEN, "Unable to open %s", name); + else if (NULL != (buf = SLmalloc (MAX_FILE_LINE_LEN + 1))) + { + client_data.fp = fp; + client_data.buf = buf; + x->client_data = (VOID_STAR) &client_data; + x->read = read_from_file; + + (void) SLang_load_object (x); + } + + if ((fp != NULL) && (fp != stdin)) + fclose (fp); + + SLfree (buf); + SLang_free_slstring (name); + SLdeallocate_load_type (x); + + if (SLang_Error) + return -1; + + return 0; +} + +static char *check_byte_compiled_token (char *buf) +{ + unsigned int len_lo, len_hi, len; + + len_lo = (unsigned char) *Input_Line_Pointer++; + if ((len_lo < 32) + || ((len_hi = (unsigned char)*Input_Line_Pointer++) < 32) + || ((len = (len_lo - 32) | ((len_hi - 32) << 7)) >= MAX_TOKEN_LEN)) + { + SLang_doerror ("Byte compiled file appears corrupt"); + return NULL; + } + + SLMEMCPY (buf, Input_Line_Pointer, len); + buf += len; + Input_Line_Pointer += len; + *buf = 0; + return buf; +} + +void _SLcompile_byte_compiled (void) +{ + unsigned char type; + _SLang_Token_Type tok; + char buf[MAX_TOKEN_LEN]; + char *ebuf; + unsigned int len; + + memset ((char *) &tok, 0, sizeof (_SLang_Token_Type)); + + while (SLang_Error == 0) + { + top_of_switch: + type = (unsigned char) *Input_Line_Pointer++; + switch (type) + { + case '\n': + case 0: + if (NULL == (Input_Line = LLT->read(LLT))) + { + Input_Line_Pointer = Input_Line = NULL; + return; + } + Input_Line_Pointer = Input_Line; + goto top_of_switch; + + case LINE_NUM_TOKEN: + case CHAR_TOKEN: + case UCHAR_TOKEN: + case SHORT_TOKEN: + case USHORT_TOKEN: + case INT_TOKEN: + case UINT_TOKEN: + case LONG_TOKEN: + case ULONG_TOKEN: + if (NULL == check_byte_compiled_token (buf)) + return; + tok.v.long_val = atol (buf); + break; + + case COMPLEX_TOKEN: + case FLOAT_TOKEN: + case DOUBLE_TOKEN: + if (NULL == check_byte_compiled_token (buf)) + return; + tok.v.s_val = buf; + break; + + case ESC_STRING_TOKEN: + if (NULL == (ebuf = check_byte_compiled_token (buf))) + return; + tok.v.s_val = buf; + if (expand_escaped_string (buf, buf, ebuf, &len)) + { + tok.hash = len; + type = _BSTRING_TOKEN; + } + else + { + tok.hash = _SLstring_hash ((unsigned char *)buf, (unsigned char *)buf + len); + type = STRING_TOKEN; + } + break; + + case TMP_TOKEN: + case DEFINE_TOKEN: + case DEFINE_STATIC_TOKEN: + case DEFINE_PRIVATE_TOKEN: + case DEFINE_PUBLIC_TOKEN: + case DOT_TOKEN: + case STRING_TOKEN: + case IDENT_TOKEN: + case _REF_TOKEN: + case _DEREF_ASSIGN_TOKEN: + case _SCALAR_ASSIGN_TOKEN: + case _SCALAR_PLUSEQS_TOKEN: + case _SCALAR_MINUSEQS_TOKEN: + case _SCALAR_TIMESEQS_TOKEN: + case _SCALAR_DIVEQS_TOKEN: + case _SCALAR_BOREQS_TOKEN: + case _SCALAR_BANDEQS_TOKEN: + case _SCALAR_PLUSPLUS_TOKEN: + case _SCALAR_POST_PLUSPLUS_TOKEN: + case _SCALAR_MINUSMINUS_TOKEN: + case _SCALAR_POST_MINUSMINUS_TOKEN: + case _STRUCT_ASSIGN_TOKEN: + case _STRUCT_PLUSEQS_TOKEN: + case _STRUCT_MINUSEQS_TOKEN: + case _STRUCT_TIMESEQS_TOKEN: + case _STRUCT_DIVEQS_TOKEN: + case _STRUCT_BOREQS_TOKEN: + case _STRUCT_BANDEQS_TOKEN: + case _STRUCT_POST_MINUSMINUS_TOKEN: + case _STRUCT_MINUSMINUS_TOKEN: + case _STRUCT_POST_PLUSPLUS_TOKEN: + case _STRUCT_PLUSPLUS_TOKEN: + if (NULL == (ebuf = check_byte_compiled_token (buf))) + return; + tok.v.s_val = buf; + tok.hash = _SLstring_hash ((unsigned char *)buf, (unsigned char *)ebuf); + break; + + default: + break; + } + tok.type = type; + + (*_SLcompile_ptr) (&tok); + } +} + +static int escape_string (unsigned char *s, unsigned char *smax, + unsigned char *buf, unsigned char *buf_max, + int *is_escaped) +{ + unsigned char ch; + + *is_escaped = 0; + while (buf < buf_max) + { + if (s == smax) + { + *buf = 0; + return 0; + } + + ch = *s++; + switch (ch) + { + default: + *buf++ = ch; + break; + + case 0: + *buf++ = '\\'; + if (buf < buf_max) *buf++ = 'x'; + if (buf < buf_max) *buf++ = '0'; + if (buf < buf_max) *buf++ = '0'; + *is_escaped = 1; + break; /* return 0; */ + + case '\n': + *buf++ = '\\'; + if (buf < buf_max) *buf++ = 'n'; + *is_escaped = 1; + break; + + case '\r': + *buf++ = '\\'; + if (buf < buf_max) *buf++ = 'r'; + *is_escaped = 1; + break; + + case 0x1A: /* ^Z */ + *buf++ = '\\'; + if (buf < buf_max) *buf++ = 'x'; + if (buf < buf_max) *buf++ = '1'; + if (buf < buf_max) *buf++ = 'A'; + *is_escaped = 1; + break; + + case '\\': + *buf++ = ch; + if (buf < buf_max) *buf++ = ch; + *is_escaped = 1; + break; + } + } + _SLparse_error ("String too long to byte-compile", NULL, 0); + return -1; +} + +static FILE *Byte_Compile_Fp; +static unsigned int Byte_Compile_Line_Len; + +static int bytecomp_write_data (char *buf, unsigned int len) +{ + char *err = "Write Error"; + + if ((Byte_Compile_Line_Len + len + 1) >= MAX_FILE_LINE_LEN) + { + if (EOF == fputs ("\n", Byte_Compile_Fp)) + { + SLang_doerror (err); + return -1; + } + Byte_Compile_Line_Len = 0; + } + + if (EOF == fputs (buf, Byte_Compile_Fp)) + { + SLang_doerror (err); + return -1; + } + Byte_Compile_Line_Len += len; + return 0; +} + +static void byte_compile_token (_SLang_Token_Type *tok) +{ + unsigned char buf [MAX_TOKEN_LEN + 4], *buf_max; + unsigned int len; + char *b3; + int is_escaped; + unsigned char *s; + + if (SLang_Error) return; + + buf [0] = (unsigned char) tok->type; + buf [1] = 0; + + buf_max = buf + sizeof(buf); + b3 = (char *) buf + 3; + + switch (tok->type) + { + case LINE_NUM_TOKEN: + case CHAR_TOKEN: + case SHORT_TOKEN: + case INT_TOKEN: + case LONG_TOKEN: + sprintf (b3, "%ld", tok->v.long_val); + break; + + case UCHAR_TOKEN: + case USHORT_TOKEN: + case UINT_TOKEN: + case ULONG_TOKEN: + sprintf (b3, "%lu", tok->v.long_val); + break; + + case _BSTRING_TOKEN: + s = (unsigned char *) tok->v.s_val; + len = (unsigned int) tok->hash; + + if (-1 == escape_string (s, s + len, + (unsigned char *)b3, buf_max, + &is_escaped)) + return; + + buf[0] = ESC_STRING_TOKEN; + break; + + case BSTRING_TOKEN: + if (NULL == (s = SLbstring_get_pointer (tok->v.b_val, &len))) + return; + + if (-1 == escape_string (s, s + len, + (unsigned char *)b3, buf_max, + &is_escaped)) + return; + buf[0] = ESC_STRING_TOKEN; + break; + + case STRING_TOKEN: + s = (unsigned char *)tok->v.s_val; + + if (-1 == escape_string (s, s + strlen ((char *)s), + (unsigned char *)b3, buf_max, + &is_escaped)) + return; + + if (is_escaped) + buf[0] = ESC_STRING_TOKEN; + break; + + /* a _SCALAR_* token is attached to an identifier. */ + case _DEREF_ASSIGN_TOKEN: + case _SCALAR_ASSIGN_TOKEN: + case _SCALAR_PLUSEQS_TOKEN: + case _SCALAR_MINUSEQS_TOKEN: + case _SCALAR_TIMESEQS_TOKEN: + case _SCALAR_DIVEQS_TOKEN: + case _SCALAR_BOREQS_TOKEN: + case _SCALAR_BANDEQS_TOKEN: + case _SCALAR_PLUSPLUS_TOKEN: + case _SCALAR_POST_PLUSPLUS_TOKEN: + case _SCALAR_MINUSMINUS_TOKEN: + case _SCALAR_POST_MINUSMINUS_TOKEN: + case DOT_TOKEN: + case TMP_TOKEN: + case DEFINE_TOKEN: + case DEFINE_STATIC_TOKEN: + case DEFINE_PRIVATE_TOKEN: + case DEFINE_PUBLIC_TOKEN: + case FLOAT_TOKEN: + case DOUBLE_TOKEN: + case COMPLEX_TOKEN: + case IDENT_TOKEN: + case _REF_TOKEN: + case _STRUCT_ASSIGN_TOKEN: + case _STRUCT_PLUSEQS_TOKEN: + case _STRUCT_MINUSEQS_TOKEN: + case _STRUCT_TIMESEQS_TOKEN: + case _STRUCT_DIVEQS_TOKEN: + case _STRUCT_BOREQS_TOKEN: + case _STRUCT_BANDEQS_TOKEN: + case _STRUCT_POST_MINUSMINUS_TOKEN: + case _STRUCT_MINUSMINUS_TOKEN: + case _STRUCT_POST_PLUSPLUS_TOKEN: + case _STRUCT_PLUSPLUS_TOKEN: + strcpy (b3, tok->v.s_val); + break; + + default: + b3 = NULL; + } + + if (b3 != NULL) + { + len = strlen (b3); + buf[1] = (unsigned char) ((len & 0x7F) + 32); + buf[2] = (unsigned char) (((len >> 7) & 0x7F) + 32); + len += 3; + } + else len = 1; + + (void) bytecomp_write_data ((char *)buf, len); +} + +int SLang_byte_compile_file (char *name, int method) +{ + char file [1024]; + + (void) method; + if (strlen (name) + 2 >= sizeof (file)) + { + SLang_verror (SL_INVALID_PARM, "Filename too long"); + return -1; + } + sprintf (file, "%sc", name); + if (NULL == (Byte_Compile_Fp = fopen (file, "w"))) + { + SLang_verror(SL_OBJ_NOPEN, "%s: unable to open", file); + return -1; + } + + Byte_Compile_Line_Len = 0; + if (-1 != bytecomp_write_data (".#", 2)) + { + _SLcompile_ptr = byte_compile_token; + (void) SLang_load_file (name); + _SLcompile_ptr = _SLcompile; + + (void) bytecomp_write_data ("\n", 1); + } + + if (EOF == fclose (Byte_Compile_Fp)) + SLang_doerror ("Write Error"); + + if (SLang_Error) + { + SLang_verror (0, "Error processing %s", name); + return -1; + } + return 0; +} + +int SLang_generate_debug_info (int x) +{ + int y = Default_Compile_Line_Num_Info; + Default_Compile_Line_Num_Info = x; + return y; +} diff --git a/libslang/src/sltypes.c b/libslang/src/sltypes.c new file mode 100644 index 0000000..fe08556 --- /dev/null +++ b/libslang/src/sltypes.c @@ -0,0 +1,1007 @@ +/* Basic type operations for S-Lang */ +/* Copyright (c) 1992, 1996, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if SLANG_HAS_FLOAT +# include +#endif + +/* #define SL_APP_WANTS_FOREACH */ /* for String_Type */ +#include "slang.h" +#include "_slang.h" + +int SLpop_string (char **s) /*{{{*/ +{ + char *sls; + + *s = NULL; + + if (-1 == SLang_pop_slstring (&sls)) + return -1; + + if (NULL == (*s = SLmake_string (sls))) + { + SLang_free_slstring (sls); + return -1; + } + + SLang_free_slstring (sls); + return 0; +} + +/*}}}*/ + +int SLang_pop_slstring (char **s) /*{{{*/ +{ + return SLclass_pop_ptr_obj (SLANG_STRING_TYPE, (VOID_STAR *)s); +} + +/*}}}*/ + +/* if *data != 0, string should be freed upon use. */ +int SLang_pop_string(char **s, int *data) /*{{{*/ +{ + if (SLpop_string (s)) + return -1; + + *data = 1; + return 0; +} + +/*}}}*/ + +int _SLang_push_slstring (char *s) +{ + if (0 == SLclass_push_ptr_obj (SLANG_STRING_TYPE, (VOID_STAR)s)) + return 0; + + SLang_free_slstring (s); + return -1; +} + +int _SLpush_alloced_slstring (char *s, unsigned int len) +{ + if (NULL == (s = _SLcreate_via_alloced_slstring (s, len))) + return -1; + + return _SLang_push_slstring (s); +} + +int SLang_push_string (char *t) /*{{{*/ +{ + if (t == NULL) + return SLang_push_null (); + + if (NULL == (t = SLang_create_slstring (t))) + return -1; + + return _SLang_push_slstring (t); +} + +/*}}}*/ + +int _SLang_dup_and_push_slstring (char *s) +{ + if (NULL == (s = _SLstring_dup_slstring (s))) + return SLang_push_null (); + + return _SLang_push_slstring (s); +} + + +/* This function _always_ frees the malloced string */ +int SLang_push_malloced_string (char *c) /*{{{*/ +{ + int ret; + + ret = SLang_push_string (c); + SLfree (c); + + return ret; +} + +/*}}}*/ + +#if 0 +static int int_int_power (int a, int b) +{ + int r, s; + + if (a == 0) return 0; + if (b < 0) return 0; + if (b == 0) return 1; + + s = 1; + if (a < 0) + { + if ((b % 2) == 1) s = -1; + a = -a; + } + + /* FIXME: Priority=low + * This needs optimized + */ + r = 1; + while (b) + { + r = r * a; + b--; + } + return r * s; +} +#endif + +static int +string_string_bin_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) a; + (void) b; + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + *c = SLANG_STRING_TYPE; + break; + + case SLANG_GT: + case SLANG_GE: + case SLANG_LT: + case SLANG_LE: + case SLANG_EQ: + case SLANG_NE: + *c = SLANG_CHAR_TYPE; + break; + } + return 1; +} + +static int +string_string_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + char **a, **b, **c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + if (na == 1) da = 0; else da = 1; + if (nb == 1) db = 0; else db = 1; + + if (na > nb) n_max = na; else n_max = nb; + + a = (char **) ap; + b = (char **) bp; + + if ((op != SLANG_NE) && (op != SLANG_EQ)) + for (n = 0; n < n_max; n++) + { + if ((*a == NULL) || (*b == NULL)) + { + SLang_verror (SL_VARIABLE_UNINITIALIZED, "String element[%u] not initialized for binary operation", n); + return -1; + } + a += da; b += db; + } + + a = (char **) ap; + b = (char **) bp; + ic = (char *) cp; + c = NULL; + + switch (op) + { + case SLANG_DIVIDE: + case SLANG_MINUS: + default: + return 0; + + case SLANG_PLUS: + /* Concat */ + c = (char **) cp; + for (n = 0; n < n_max; n++) + { + if (NULL == (c[n] = SLang_concat_slstrings (*a, *b))) + goto return_error; + + a += da; b += db; + } + break; + + case SLANG_NE: + for (n = 0; n < n_max; n++) + { + if ((*a == NULL) || (*b == NULL)) + ic [n] = (*a != *b); + else + ic [n] = (*a != *b) && (0 != strcmp (*a, *b)); + + a += da; + b += db; + } + break; + case SLANG_GT: + for (n = 0; n < n_max; n++) + { + ic [n] = (strcmp (*a, *b) > 0); + a += da; + b += db; + } + break; + case SLANG_GE: + for (n = 0; n < n_max; n++) + { + ic [n] = (strcmp (*a, *b) >= 0); + a += da; + b += db; + } + break; + case SLANG_LT: + for (n = 0; n < n_max; n++) + { + ic [n] = (strcmp (*a, *b) < 0); + a += da; + b += db; + } + break; + case SLANG_LE: + for (n = 0; n < n_max; n++) + { + ic [n] = (strcmp (*a, *b) <= 0); + a += da; + b += db; + } + break; + case SLANG_EQ: + for (n = 0; n < n_max; n++) + { + if ((*a == NULL) || (*b == NULL)) + ic[n] = (*a == *b); + else + ic [n] = (*a == *b) || (strcmp (*a, *b) == 0); + a += da; + b += db; + } + break; + } + return 1; + + return_error: + if (c != NULL) + { + unsigned int nn; + for (nn = 0; nn < n; nn++) + { + SLang_free_slstring (c[nn]); + c[nn] = NULL; + } + for (nn = n; nn < n_max; nn++) + c[nn] = NULL; + } + return -1; +} + +static void string_destroy (unsigned char unused, VOID_STAR s) +{ + (void) unused; + SLang_free_slstring (*(char **) s); +} + +static int string_push (unsigned char unused, VOID_STAR sptr) +{ + (void) unused; + return SLang_push_string (*(char **) sptr); +} + +static int string_cmp (unsigned char unused, VOID_STAR ap, VOID_STAR bp, int *c) +{ + char *a, *b; + (void) unused; + + a = *(char **) ap; + b = *(char **) bp; + if (a != b) + { + if (a == NULL) *c = -1; + else if (b == NULL) *c = 1; + else *c = strcmp (a, b); + return 0; + } + *c = 0; + return 0; +} + +static int string_to_int (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + char **s; + unsigned int i; + int *b; + + (void) a_type; + (void) b_type; + + s = (char **) ap; + b = (int *) bp; + for (i = 0; i < na; i++) + { + if (s[i] == NULL) b[i] = 0; + else b[i] = s[i][0]; + } + return 1; +} + +static int string_acopy (SLtype unused, VOID_STAR src_sptr, VOID_STAR dest_sptr) +{ + char *s; + (void) unused; + if (NULL == (s = SLang_create_slstring (*(char **)src_sptr))) + return -1; + *(char **)dest_sptr = s; + return 0; +} + +struct _SLang_Foreach_Context_Type +{ + char *string; + unsigned int n; +}; + +static SLang_Foreach_Context_Type * +string_foreach_open (unsigned char type, unsigned int num) +{ + char *s; + SLang_Foreach_Context_Type *c; + + (void) type; + if (num != 0) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "'foreach using' form not supported by String_Type"); + SLdo_pop_n (num + 1); + return NULL; + } + if (-1 == SLang_pop_slstring (&s)) + return NULL; + + c = (SLang_Foreach_Context_Type *)SLmalloc (sizeof (SLang_Foreach_Context_Type)); + if (c == NULL) + { + SLang_free_slstring (s); + return NULL; + } + + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + c->string = s; + + return c; +} + +static void string_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + SLang_free_slstring (c->string); + SLfree ((char *) c); +} + +static int string_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + char ch; + + (void) type; + ch = c->string[c->n]; + if (ch == 0) + return 0; /* done */ + + c->n += 1; + + if (-1 == SLclass_push_int_obj (SLANG_INT_TYPE, ch)) + return -1; + + return 1; +} + +int _SLstring_list_push (_SLString_List_Type *p) +{ + unsigned int num; + int inum; + SLang_Array_Type *at; + char **buf; + + if ((buf = p->buf) == NULL) + return SLang_push_null (); + + num = p->num; + inum = (int) num; + + if (num == 0) num++; + if (num != p->max_num) + { + if (NULL == (buf = (char **)SLrealloc ((char *) buf, sizeof (char *) * num))) + { + _SLstring_list_delete (p); + return -1; + } + p->max_num = num; + p->buf = buf; + } + + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) buf, &inum, 1))) + { + _SLstring_list_delete (p); + return -1; + } + p->buf = NULL; + _SLstring_list_delete (p); + return SLang_push_array (at, 1); +} + +int _SLstring_list_init (_SLString_List_Type *p, unsigned int max_num, unsigned int delta_num) +{ + if (NULL == (p->buf = (char **) SLmalloc (max_num * sizeof (char *)))) + return -1; + + p->max_num = max_num; + p->num = 0; + p->delta_num = delta_num; + return 0; +} + +int _SLstring_list_append (_SLString_List_Type *p, char *s) +{ + if (s == NULL) + { + _SLstring_list_delete (p); + return -1; + } + + if (p->max_num == p->num) + { + char **b; + unsigned int max_num = p->num + p->delta_num; + b = (char **)SLrealloc ((char *)p->buf, max_num * sizeof (char *)); + if (b == NULL) + { + _SLstring_list_delete (p); + SLang_free_slstring (s); + return -1; + } + p->buf = b; + p->max_num = max_num; + } + + p->buf[p->num] = s; + p->num++; + return 0; +} + +void _SLstring_list_delete (_SLString_List_Type *p) +{ + if (p->buf != NULL) + { + unsigned int i, imax; + char **buf = p->buf; + imax = p->num; + for (i = 0; i < imax; i++) + SLang_free_slstring (buf[i]); + SLfree ((char *)buf); + p->buf = NULL; + } +} + +/* Ref type */ +int SLang_pop_ref (SLang_Ref_Type **ref) +{ + return SLclass_pop_ptr_obj (SLANG_REF_TYPE, (VOID_STAR *)ref); +} + +/* Note: This is ok if ptr is NULL. Some routines rely on this behavior */ +int _SLang_push_ref (int is_global, VOID_STAR ptr) +{ + SLang_Ref_Type *r; + + if (ptr == NULL) + return SLang_push_null (); + + r = (SLang_Ref_Type *) SLmalloc (sizeof (SLang_Ref_Type)); + if (r == NULL) return -1; + + r->is_global = is_global; + r->v.nt = (SLang_Name_Type *) ptr; + + if (-1 == SLclass_push_ptr_obj (SLANG_REF_TYPE, (VOID_STAR) r)) + { + SLfree ((char *) r); + return -1; + } + return 0; +} + +static void ref_destroy (unsigned char type, VOID_STAR ptr) +{ + (void) type; + SLfree ((char *) *(SLang_Ref_Type **)ptr); +} + +void SLang_free_ref (SLang_Ref_Type *ref) +{ + SLfree ((char *) ref); +} + +static int ref_push (unsigned char type, VOID_STAR ptr) +{ + SLang_Ref_Type *ref; + + (void) type; + + ref = *(SLang_Ref_Type **) ptr; + + if (ref == NULL) + return SLang_push_null (); + + return _SLang_push_ref (ref->is_global, (VOID_STAR) ref->v.nt); +} + +int SLang_assign_to_ref (SLang_Ref_Type *ref, SLtype type, VOID_STAR v) +{ + SLang_Object_Type *stkptr; + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + + /* Use apush since this function is passing ``array'' bytes rather than the + * address of the data. I need to somehow make this more consistent. To + * see what I mean, consider: + * + * double z[2]; + * char *s = "silly"; + * char bytes[10]; BAD--- Don't do this + * int i; + * + * SLang_assign_to_ref (ref, SLANG_INT_TYPE, &i); + * SLang_assign_to_ref (ref, SLANG_STRING_TYPE, &s); + * SLang_assign_to_ref (ref, SLANG_COMPLEX_TYPE, z); + * + * That is, all external routines that take a VOID_STAR argument need to + * be documented such that how the function should be called with the + * various class_types. + */ + if (-1 == (*cl->cl_apush) (type, v)) + return -1; + + stkptr = _SLang_get_run_stack_pointer (); + if (0 == _SLang_deref_assign (ref)) + return 0; + + if (stkptr != _SLang_get_run_stack_pointer ()) + SLdo_pop (); + + return -1; +} + +static char *ref_string (unsigned char type, VOID_STAR ptr) +{ + SLang_Ref_Type *ref; + + (void) type; + ref = *(SLang_Ref_Type **) ptr; + if (ref->is_global) + { + char *name, *s; + + name = ref->v.nt->name; + if ((name != NULL) + && (NULL != (s = SLmalloc (strlen(name) + 2)))) + { + *s = '&'; + strcpy (s + 1, name); + return s; + } + + return NULL; + } + return SLmake_string ("Local Variable Reference"); +} + +static int ref_dereference (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return _SLang_dereference_ref (*(SLang_Ref_Type **) ptr); +} + +static int ref_cmp (unsigned char type, VOID_STAR a, VOID_STAR b, int *c) +{ + SLang_Ref_Type *ra, *rb; + + (void) type; + + ra = *(SLang_Ref_Type **)a; + rb = *(SLang_Ref_Type **)b; + + if (ra == NULL) + { + if (rb == NULL) *c = 0; + else *c = -1; + return 0; + } + if (rb == NULL) + { + *c = 1; + return 0; + } + + if (ra->v.nt == rb->v.nt) + *c = 0; + else *c = strcmp (ra->v.nt->name, rb->v.nt->name); + return 0; +} + + +SLang_Name_Type *SLang_pop_function (void) +{ + SLang_Ref_Type *ref; + SLang_Name_Type *f; + + if (SLang_peek_at_stack () == SLANG_STRING_TYPE) + { + char *name; + + if (-1 == SLang_pop_slstring (&name)) + return NULL; + + if (NULL == (f = SLang_get_function (name))) + { + SLang_verror (SL_UNDEFINED_NAME, "Function %s does not exist", name); + SLang_free_slstring (name); + return NULL; + } + SLang_free_slstring (name); + return f; + } + + if (-1 == SLang_pop_ref (&ref)) + return NULL; + + f = SLang_get_fun_from_ref (ref); + SLang_free_ref (ref); + return f; +} + +/* This is a placeholder for version 2 */ +void SLang_free_function (SLang_Name_Type *f) +{ + (void) f; +} + +/* NULL type */ +int SLang_push_null (void) +{ + return SLclass_push_ptr_obj (SLANG_NULL_TYPE, NULL); +} + +int SLang_pop_null (void) +{ + SLang_Object_Type obj; + return _SLang_pop_object_of_type (SLANG_NULL_TYPE, &obj, 0); +} + +static int null_push (unsigned char unused, VOID_STAR ptr_unused) +{ + (void) unused; (void) ptr_unused; + return SLang_push_null (); +} + +static int null_pop (unsigned char type, VOID_STAR ptr) +{ + (void) type; + + if (-1 == SLang_pop_null ()) + return -1; + + *(char **) ptr = NULL; + return 0; +} + +/* Implement foreach (NULL) using (whatever) to do nothing. This is useful + * because suppose that X is a list but is NULL in some situations. Then + * when it is NULL, we want foreach(X) to do nothing. + */ +static SLang_Foreach_Context_Type * +null_foreach_open (unsigned char type, unsigned int num) +{ + (void) type; + SLdo_pop_n (num + 1); + return (SLang_Foreach_Context_Type *)1; +} + +static void null_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + (void) c; +} + +static int null_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + (void) c; + return 0; +} + +static int null_to_bool (unsigned char type, int *t) +{ + (void) type; + *t = 0; + return SLang_pop_null (); +} + +/* AnyType */ +int _SLanytype_typecast (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + SLang_Class_Type *cl; + SLang_Any_Type **any; + unsigned int i; + unsigned int sizeof_type; + + (void) b_type; + + any = (SLang_Any_Type **) bp; + + cl = _SLclass_get_class (a_type); + sizeof_type = cl->cl_sizeof_type; + + for (i = 0; i < na; i++) + { + if ((-1 == (*cl->cl_apush) (a_type, ap)) + || (-1 == SLang_pop_anytype (&any[i]))) + { + while (i != 0) + { + i--; + SLang_free_anytype (any[i]); + any[i] = NULL; + } + return -1; + } + ap = (VOID_STAR)((char *)ap + sizeof_type); + } + + return 1; +} + +int SLang_pop_anytype (SLang_Any_Type **any) +{ + SLang_Object_Type *obj; + + *any = NULL; + + if (NULL == (obj = (SLang_Object_Type *) SLmalloc (sizeof (SLang_Object_Type)))) + return -1; + + if (-1 == SLang_pop (obj)) + { + SLfree ((char *) obj); + return -1; + } + *any = (SLang_Any_Type *)obj; + return 0; +} + +/* This function will result in an object that is represented by the + * anytype object. + */ +int SLang_push_anytype (SLang_Any_Type *any) +{ + return _SLpush_slang_obj ((SLang_Object_Type *)any); +} + +/* After this call, the stack will contain an Any_Type object */ +static int anytype_push (unsigned char type, VOID_STAR ptr) +{ + SLang_Any_Type *obj; + + /* Push the object onto the stack, then pop it back off into our anytype + * container. That way, any memory managing associated with the type + * will be performed automatically. Another way to think of it is that + * pushing an Any_Type onto the stack will create another copy of the + * object represented by it. + */ + if (-1 == _SLpush_slang_obj (*(SLang_Object_Type **)ptr)) + return -1; + + if (-1 == SLang_pop_anytype (&obj)) + return -1; + + /* There is no need to reference count the anytype objects since every + * push results in a new anytype container. + */ + if (-1 == SLclass_push_ptr_obj (type, (VOID_STAR) obj)) + { + SLang_free_anytype (obj); + return -1; + } + + return 0; +} + +static void anytype_destroy (unsigned char type, VOID_STAR ptr) +{ + SLang_Object_Type *obj; + + (void) type; + obj = *(SLang_Object_Type **)ptr; + SLang_free_object (obj); + SLfree ((char *) obj); +} + +void SLang_free_anytype (SLang_Any_Type *any) +{ + if (any != NULL) + anytype_destroy (SLANG_ANY_TYPE, (VOID_STAR) &any); +} + +static int anytype_dereference (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return _SLpush_slang_obj (*(SLang_Object_Type **) ptr); +} + +#if 0 +/* This function performs a deref since we may want the symmetry + * a = Any_Type[1]; a[x] = "foo"; bar = a[x]; ==> bar == "foo" + * That is, we do not want bar to be an Any_Type. + * + * Unfortunately, this does not work because of the use of the transfer + * buffer by both slarray.c and sltypecast.c. I can work around that + * but I am not sure that I like typeof(Any_Type[0]) != Any_Type. + */ +static int anytype_apush (SLtype type, VOID_STAR ptr) +{ + (void) type; + return _SLpush_slang_obj (*(SLang_Object_Type **)ptr); +} +#endif + +/* SLANG_INTP_TYPE */ +static int intp_push (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return SLclass_push_int_obj (SLANG_INT_TYPE, **(int **)ptr); +} + +static int intp_pop (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return SLang_pop_integer (*(int **) ptr); +} + +static int undefined_push (unsigned char t, VOID_STAR p) +{ + (void) t; (void) p; + if (SLang_Error == 0) + SLang_Error = SL_VARIABLE_UNINITIALIZED; + return -1; +} + +int _SLregister_types (void) +{ + SLang_Class_Type *cl; + +#if 1 + /* A good compiler should optimize this code away. */ + if ((sizeof(short) != SIZEOF_SHORT) + || (sizeof(int) != SIZEOF_INT) + || (sizeof(long) != SIZEOF_LONG) + || (sizeof(float) != SIZEOF_FLOAT) + || (sizeof(double) != SIZEOF_DOUBLE)) + SLang_exit_error ("S-Lang Library not built properly. Fix SIZEOF_* in config.h and recompile"); +#endif + if (-1 == _SLclass_init ()) + return -1; + + /* Undefined Type */ + if (NULL == (cl = SLclass_allocate_class ("Undefined_Type"))) + return -1; + (void) SLclass_set_push_function (cl, undefined_push); + (void) SLclass_set_pop_function (cl, undefined_push); + if (-1 == SLclass_register_class (cl, SLANG_UNDEFINED_TYPE, sizeof (int), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + /* Make Void_Type a synonym for Undefined_Type. Note that this does + * not mean that Void_Type represents SLANG_VOID_TYPE. Void_Type is + * used by array_map to indicate no array is to be created. + */ + if (-1 == SLclass_create_synonym ("Void_Type", SLANG_UNDEFINED_TYPE)) + return -1; + + if (-1 == _SLarith_register_types ()) + return -1; + + /* SLANG_INTP_TYPE */ + if (NULL == (cl = SLclass_allocate_class ("_IntegerP_Type"))) + return -1; + (void) SLclass_set_push_function (cl, intp_push); + (void) SLclass_set_pop_function (cl, intp_pop); + if (-1 == SLclass_register_class (cl, SLANG_INTP_TYPE, sizeof (int), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + + /* String Type */ + + if (NULL == (cl = SLclass_allocate_class ("String_Type"))) + return -1; + (void) SLclass_set_destroy_function (cl, string_destroy); + (void) SLclass_set_push_function (cl, string_push); + (void) SLclass_set_acopy_function (cl, string_acopy); + cl->cl_foreach_open = string_foreach_open; + cl->cl_foreach_close = string_foreach_close; + cl->cl_foreach = string_foreach; + cl->cl_cmp = string_cmp; + if (-1 == SLclass_register_class (cl, SLANG_STRING_TYPE, sizeof (char *), + SLANG_CLASS_TYPE_PTR)) + return -1; + + /* ref Type */ + if (NULL == (cl = SLclass_allocate_class ("Ref_Type"))) + return -1; + cl->cl_dereference = ref_dereference; + cl->cl_push = ref_push; + cl->cl_destroy = ref_destroy; + cl->cl_string = ref_string; + cl->cl_cmp = ref_cmp; + if (-1 == SLclass_register_class (cl, SLANG_REF_TYPE, + sizeof (SLang_Ref_Type *), + SLANG_CLASS_TYPE_PTR)) + return -1; + + /* NULL Type */ + + if (NULL == (cl = SLclass_allocate_class ("Null_Type"))) + return -1; + cl->cl_push = null_push; + cl->cl_pop = null_pop; + cl->cl_foreach_open = null_foreach_open; + cl->cl_foreach_close = null_foreach_close; + cl->cl_foreach = null_foreach; + cl->cl_to_bool = null_to_bool; + if (-1 == SLclass_register_class (cl, SLANG_NULL_TYPE, sizeof (char *), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + + /* AnyType */ + if (NULL == (cl = SLclass_allocate_class ("Any_Type"))) + return -1; + (void) SLclass_set_push_function (cl, anytype_push); + (void) SLclass_set_destroy_function (cl, anytype_destroy); +#if 0 + (void) SLclass_set_apush_function (cl, anytype_apush); +#endif + cl->cl_dereference = anytype_dereference; + if (-1 == SLclass_register_class (cl, SLANG_ANY_TYPE, sizeof (VOID_STAR), + SLANG_CLASS_TYPE_PTR)) + return -1; + + if (-1 == _SLang_init_bstring ()) + return -1; + + if ((-1 == SLclass_add_typecast (SLANG_STRING_TYPE, SLANG_INT_TYPE, string_to_int, 0)) + || (-1 == SLclass_add_binary_op (SLANG_STRING_TYPE, SLANG_STRING_TYPE, string_string_bin_op, string_string_bin_op_result))) + return -1; + + return 0; +} + diff --git a/libslang/src/slutty.c b/libslang/src/slutty.c new file mode 100644 index 0000000..a3f5e77 --- /dev/null +++ b/libslang/src/slutty.c @@ -0,0 +1,604 @@ +/* slutty.c --- Unix Low level terminal (tty) functions for S-Lang */ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include +/* sequent support thanks to Kenneth Lorber */ +/* SYSV (SYSV ISC R3.2 v3.0) provided by iain.lea@erlm.siemens.de */ + +#if defined (_AIX) && !defined (_ALL_SOURCE) +# define _ALL_SOURCE /* so NBBY is defined in */ +#endif + +#include +#include + +#ifdef SYSV +# include +# ifndef CRAY +# include +# include +# include +# include +# endif +#endif + +#ifdef __BEOS__ +/* Prototype for select */ +# include +#endif + +#include + +#ifndef sun +# include +#endif + +#ifdef __QNX__ +# include +#endif + +#include +#include + +#if defined (_AIX) && !defined (FD_SET) +# include /* for FD_ISSET, FD_SET, FD_ZERO */ +#endif + +#ifndef O_RDWR +# include +#endif + +#include "slang.h" +#include "_slang.h" + +int SLang_TT_Read_FD = -1; +int SLang_TT_Baud_Rate; + +#ifdef HAVE_TERMIOS_H +# if !defined(HAVE_TCGETATTR) || !defined(HAVE_TCSETATTR) +# undef HAVE_TERMIOS_H +# endif +#endif + +#ifndef HAVE_TERMIOS_H + +# if !defined(CBREAK) && defined(sun) +# ifndef BSD_COMP +# define BSD_COMP 1 +# endif +# include +# endif + +typedef struct + { + struct tchars t; + struct ltchars lt; + struct sgttyb s; + } +TTY_Termio_Type; +#else +# include +typedef struct termios TTY_Termio_Type; +#endif + +static TTY_Termio_Type Old_TTY; + +#ifdef HAVE_TERMIOS_H +typedef SLCONST struct +{ + unsigned int key; + unsigned int value; +} Baud_Rate_Type; + +static Baud_Rate_Type Baud_Rates [] = +{ +#ifdef B0 + {B0, 0}, +#endif +#ifdef B50 + {B50, 50}, +#endif +#ifdef B75 + {B75, 75}, +#endif +#ifdef B110 + {B110, 110}, +#endif +#ifdef B134 + {B134, 134}, +#endif +#ifdef B150 + {B150, 150}, +#endif +#ifdef B200 + {B200, 200}, +#endif +#ifdef B300 + {B300, 300}, +#endif +#ifdef B600 + {B600, 600}, +#endif +#ifdef B1200 + {B1200, 1200}, +#endif +#ifdef B1800 + {B1800, 1800}, +#endif +#ifdef B2400 + {B2400, 2400}, +#endif +#ifdef B4800 + {B4800, 4800}, +#endif +#ifdef B9600 + {B9600, 9600}, +#endif +#ifdef B19200 + {B19200, 19200}, +#endif +#ifdef B38400 + {B38400, 38400}, +#endif +#ifdef B57600 + {B57600, 57600}, +#endif +#ifdef B115200 + {B115200, 115200}, +#endif +#ifdef B230400 + {B230400, 230400}, +#endif + {0, 0} +}; + +static void +set_baud_rate (TTY_Termio_Type *tty) +{ +#ifdef HAVE_CFGETOSPEED + unsigned int speed; + Baud_Rate_Type *b, *bmax; + + if (SLang_TT_Baud_Rate) + return; /* already set */ + + speed = (unsigned int) cfgetospeed (tty); + + b = Baud_Rates; + bmax = b + (sizeof (Baud_Rates)/sizeof(Baud_Rates[0])); + while (b < bmax) + { + if (b->key == speed) + { + SLang_TT_Baud_Rate = b->value; + return; + } + b++; + } +#else + (void) tty; +#endif +} + +#endif /* HAVE_TERMIOS_H */ + +#ifdef HAVE_TERMIOS_H +# define GET_TERMIOS(fd, x) tcgetattr(fd, x) +# define SET_TERMIOS(fd, x) tcsetattr(fd, TCSADRAIN, x) +#else +# ifdef TCGETS +# define GET_TERMIOS(fd, x) ioctl(fd, TCGETS, x) +# define SET_TERMIOS(fd, x) ioctl(fd, TCSETS, x) +# else +# define X(x,m) &(((TTY_Termio_Type *)(x))->m) +# define GET_TERMIOS(fd, x) \ + ((ioctl(fd, TIOCGETC, X(x,t)) || \ + ioctl(fd, TIOCGLTC, X(x,lt)) || \ + ioctl(fd, TIOCGETP, X(x,s))) ? -1 : 0) +# define SET_TERMIOS(fd, x) \ + ((ioctl(fd, TIOCSETC, X(x,t)) ||\ + ioctl(fd, TIOCSLTC, X(x,lt)) || \ + ioctl(fd, TIOCSETP, X(x,s))) ? -1 : 0) +# endif +#endif + +static int TTY_Inited = 0; +static int TTY_Open = 0; + +#ifdef ultrix /* Ultrix gets _POSIX_VDISABLE wrong! */ +# define NULL_VALUE -1 +#else +# ifdef _POSIX_VDISABLE +# define NULL_VALUE _POSIX_VDISABLE +# else +# define NULL_VALUE 255 +# endif +#endif + +int SLang_init_tty (int abort_char, int no_flow_control, int opost) +{ + TTY_Termio_Type newtty; + + SLsig_block_signals (); + + if (TTY_Inited) + { + SLsig_unblock_signals (); + return 0; + } + + TTY_Open = 0; + + if ((SLang_TT_Read_FD == -1) + || (1 != isatty (SLang_TT_Read_FD))) + { +#ifdef O_RDWR +# if !defined(__BEOS__) && !defined(__APPLE__) + /* I have been told that BEOS will HANG if passed /dev/tty */ + if ((SLang_TT_Read_FD = open("/dev/tty", O_RDWR)) >= 0) + { + TTY_Open = 1; + } +# endif +#endif + if (TTY_Open == 0) + { + SLang_TT_Read_FD = fileno (stderr); + if (1 != isatty (SLang_TT_Read_FD)) + { + SLang_TT_Read_FD = fileno (stdin); + if (1 != isatty (SLang_TT_Read_FD)) + { + fprintf (stderr, "Failed to open terminal."); + return -1; + } + } + } + } + + SLang_Abort_Char = abort_char; + + /* Some systems may not permit signals to be blocked. As a result, the + * return code must be checked. + */ + while (-1 == GET_TERMIOS(SLang_TT_Read_FD, &Old_TTY)) + { + if (errno != EINTR) + { + SLsig_unblock_signals (); + return -1; + } + } + + while (-1 == GET_TERMIOS(SLang_TT_Read_FD, &newtty)) + { + if (errno != EINTR) + { + SLsig_unblock_signals (); + return -1; + } + } + +#ifndef HAVE_TERMIOS_H + (void) opost; + (void) no_flow_control; + newtty.s.sg_flags &= ~(ECHO); + newtty.s.sg_flags &= ~(CRMOD); + /* if (Flow_Control == 0) newtty.s.sg_flags &= ~IXON; */ + newtty.t.t_eofc = 1; + if (abort_char == -1) SLang_Abort_Char = newtty.t.t_intrc; + newtty.t.t_intrc = SLang_Abort_Char; /* ^G */ + newtty.t.t_quitc = 255; + newtty.lt.t_suspc = 255; /* to ignore ^Z */ + newtty.lt.t_dsuspc = 255; /* to ignore ^Y */ + newtty.lt.t_lnextc = 255; + newtty.s.sg_flags |= CBREAK; /* do I want cbreak or raw????? */ +#else + + /* get baud rate */ + + newtty.c_iflag &= ~(ECHO | INLCR | ICRNL); +#ifdef ISTRIP + /* newtty.c_iflag &= ~ISTRIP; */ +#endif + if (opost == 0) newtty.c_oflag &= ~OPOST; + + set_baud_rate (&newtty); + + if (no_flow_control) newtty.c_iflag &= ~IXON; else newtty.c_iflag |= IXON; + + newtty.c_cc[VEOF] = 1; + newtty.c_cc[VMIN] = 1; + newtty.c_cc[VTIME] = 0; + newtty.c_lflag = ISIG | NOFLSH; + if (abort_char == -1) SLang_Abort_Char = newtty.c_cc[VINTR]; + newtty.c_cc[VINTR] = SLang_Abort_Char; /* ^G */ + newtty.c_cc[VQUIT] = NULL_VALUE; + newtty.c_cc[VSUSP] = NULL_VALUE; /* to ignore ^Z */ +#ifdef VDSUSP + newtty.c_cc[VDSUSP] = NULL_VALUE; /* to ignore ^Y */ +#endif +#ifdef VLNEXT + newtty.c_cc[VLNEXT] = NULL_VALUE; /* to ignore ^V ? */ +#endif +#ifdef VSWTCH + newtty.c_cc[VSWTCH] = NULL_VALUE; /* to ignore who knows what */ +#endif +#endif /* NOT HAVE_TERMIOS_H */ + + while (-1 == SET_TERMIOS(SLang_TT_Read_FD, &newtty)) + { + if (errno != EINTR) + { + SLsig_unblock_signals (); + return -1; + } + } + + TTY_Inited = 1; + SLsig_unblock_signals (); + return 0; +} + +void SLtty_set_suspend_state (int mode) +{ + TTY_Termio_Type newtty; + + SLsig_block_signals (); + + if (TTY_Inited == 0) + { + SLsig_unblock_signals (); + return; + } + + while ((-1 == GET_TERMIOS (SLang_TT_Read_FD, &newtty)) + && (errno == EINTR)) + ; + +#ifndef HAVE_TERMIOS_H + /* I do not know if all systems define the t_dsuspc field */ + if (mode == 0) + { + newtty.lt.t_suspc = 255; + newtty.lt.t_dsuspc = 255; + } + else + { + newtty.lt.t_suspc = Old_TTY.lt.t_suspc; + newtty.lt.t_dsuspc = Old_TTY.lt.t_dsuspc; + } +#else + if (mode == 0) + { + newtty.c_cc[VSUSP] = NULL_VALUE; +#ifdef VDSUSP + newtty.c_cc[VDSUSP] = NULL_VALUE; +#endif + } + else + { + newtty.c_cc[VSUSP] = Old_TTY.c_cc[VSUSP]; +#ifdef VDSUSP + newtty.c_cc[VDSUSP] = Old_TTY.c_cc[VDSUSP]; +#endif + } +#endif + + while ((-1 == SET_TERMIOS (SLang_TT_Read_FD, &newtty)) + && (errno == EINTR)) + ; + + SLsig_unblock_signals (); +} + +void SLang_reset_tty (void) +{ + SLsig_block_signals (); + + if (TTY_Inited == 0) + { + SLsig_unblock_signals (); + return; + } + + while ((-1 == SET_TERMIOS(SLang_TT_Read_FD, &Old_TTY)) + && (errno == EINTR)) + ; + + if (TTY_Open) + { + while ((-1 == close (SLang_TT_Read_FD)) + && (errno == EINTR)) + ; + + TTY_Open = 0; + SLang_TT_Read_FD = -1; + } + + TTY_Inited = 0; + SLsig_unblock_signals (); +} + +static void default_sigint (int sig) +{ + sig = errno; /* use parameter */ + + SLKeyBoard_Quit = 1; + if (SLang_Ignore_User_Abort == 0) SLang_Error = SL_USER_BREAK; + SLsignal_intr (SIGINT, default_sigint); + errno = sig; +} + +int SLang_set_abort_signal (void (*hand)(int)) +{ + int save_errno = errno; + SLSig_Fun_Type *f; + + if (hand == NULL) hand = default_sigint; + f = SLsignal_intr (SIGINT, hand); + + errno = save_errno; + + if (f == (SLSig_Fun_Type *) SIG_ERR) + return -1; + + return 0; +} + +#ifndef FD_SET +#define FD_SET(fd, tthis) *(tthis) = 1 << (fd) +#define FD_ZERO(tthis) *(tthis) = 0 +#define FD_ISSET(fd, tthis) (*(tthis) & (1 << fd)) +typedef int fd_set; +#endif + +static fd_set Read_FD_Set; + +/* HACK: If > 0, use 1/10 seconds. If < 0, use 1/1000 seconds */ + +int _SLsys_input_pending(int tsecs) +{ + struct timeval wait; + long usecs, secs; + + if ((TTY_Inited == 0) + || (SLang_TT_Read_FD < 0)) + { + errno = EBADF; + return -1; + } + + if (tsecs >= 0) + { + secs = tsecs / 10; + usecs = (tsecs % 10) * 100000; + } + else + { + tsecs = -tsecs; + secs = tsecs / 1000; + usecs = (tsecs % 1000) * 1000; + } + + wait.tv_sec = secs; + wait.tv_usec = usecs; + + FD_ZERO(&Read_FD_Set); + FD_SET(SLang_TT_Read_FD, &Read_FD_Set); + + return select(SLang_TT_Read_FD + 1, &Read_FD_Set, NULL, NULL, &wait); +} + +int (*SLang_getkey_intr_hook) (void); + +static int handle_interrupt (void) +{ + if (SLang_getkey_intr_hook != NULL) + { + int save_tty_fd = SLang_TT_Read_FD; + + if (-1 == (*SLang_getkey_intr_hook) ()) + return -1; + + if (save_tty_fd != SLang_TT_Read_FD) + return -1; + } + + return 0; +} + +unsigned int _SLsys_getkey (void) +{ + unsigned char c; + + if (TTY_Inited == 0) + { + int ic = fgetc (stdin); + if (ic == EOF) return SLANG_GETKEY_ERROR; + return (unsigned int) ic; + } + + while (1) + { + int ret; + + if (SLKeyBoard_Quit) + return SLang_Abort_Char; + + if (0 == (ret = _SLsys_input_pending (100))) + continue; + + if (ret != -1) + break; + + if (SLKeyBoard_Quit) + return SLang_Abort_Char; + + if (errno == EINTR) + { + if (-1 == handle_interrupt ()) + return SLANG_GETKEY_ERROR; + + continue; + } + + break; /* let read handle it */ + } + + while (1) + { + int status = read(SLang_TT_Read_FD, (char *) &c, 1); + + if (status > 0) + break; + + if (status == 0) + { + /* We are at the end of a file. Let application handle it. */ + return SLANG_GETKEY_ERROR; + } + + if (errno == EINTR) + { + if (-1 == handle_interrupt ()) + return SLANG_GETKEY_ERROR; + + if (SLKeyBoard_Quit) + return SLang_Abort_Char; + + continue; + } +#ifdef EAGAIN + if (errno == EAGAIN) + { + sleep (1); + continue; + } +#endif +#ifdef EWOULDBLOCK + if (errno == EWOULDBLOCK) + { + sleep (1); + continue; + } +#endif +#ifdef EIO + if (errno == EIO) + { + SLang_exit_error ("_SLsys_getkey: EIO error."); + } +#endif + return SLANG_GETKEY_ERROR; + } + + return((unsigned int) c); +} + diff --git a/libslang/src/slvideo.c b/libslang/src/slvideo.c new file mode 100644 index 0000000..7c4a26c --- /dev/null +++ b/libslang/src/slvideo.c @@ -0,0 +1,2337 @@ +/* -*- mode: C; mode: fold -*- */ +/* Copyright (c) 1992, 1997, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* This file is best edited with a folding editor */ + +#include "slinclud.h" + +#if !defined(__WIN32__) && !defined(__IBMC__) +# include +#endif + +#include "slang.h" +#include "_slang.h" + +int SLtt_Term_Cannot_Insert; +int SLtt_Term_Cannot_Scroll; +int SLtt_Ignore_Beep = 3; +int SLtt_Use_Ansi_Colors; +int SLtt_Has_Status_Line = 0; +int SLtt_Screen_Rows = 25; +int SLtt_Screen_Cols = 80; +int SLtt_Msdos_Cheap_Video = 0; + +void (*_SLtt_color_changed_hook)(void); + +/* This definition will need changing when SLsmg_Char_Type changes. */ +#define SLSMG_CHAR_TO_USHORT(x) ((unsigned short)(x)) + +/*{{{ ------------- static local variables ---------- */ + +static int Attribute_Byte; +static int Scroll_r1 = 0, Scroll_r2 = 25; +static int Cursor_Row = 1, Cursor_Col = 1; +static int Current_Color; +static int IsColor = 1; +static int Blink_Killed = 1; /* high intensity background enabled */ + +#define JMAX_COLORS 256 +#define JNORMAL_COLOR 0 +#define JNO_COLOR -1 + +static unsigned char Color_Map [JMAX_COLORS] = +{ + 0x7, 0x70, 0x70, 0x70, 0x70, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, + 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7, 0x7 +}; + +#define JMAX_COLOR_NAMES 16 +static SLCONST char *Color_Names [JMAX_COLOR_NAMES] = +{ + "black", "blue", "green", "cyan", + "red", "magenta", "brown", "lightgray", + "gray", "brightblue", "brightgreen", "brightcyan", + "brightred", "brightmagenta", "yellow", "white" +}; + +static void fixup_colors (void); + +/*}}}*/ + +static void goto_rc_abs (int r, int c) +{ + SLtt_goto_rc (r - Scroll_r1, c); +} + +#if defined(__BORLANDC__) && defined(__MSDOS__) +# define IBMPC_ASM_VIDEO 1 +#endif + +#if defined(__WATCOMC__) && !defined(__NT__) && !defined(__os2__) +# define WATCOM_VIDEO 1 +#endif + +#if defined (__GO32__) +# define GO32_VIDEO 1 +#endif + +#if defined (__EMX__) /* EMX video does both DOS & OS/2 */ +# define EMX_VIDEO 1 +#else +# if defined(__os2__) +# define OS2_VIDEO 1 +# endif +#endif + +#if defined (__WIN32__) +# define WIN32_VIDEO 1 +#endif + +/* The functions in these folds contain somewhat video system specific code + * that if merged together into single functions will become a confusing + * mess. + */ + +#ifdef IBMPC_ASM_VIDEO /*{{{*/ + +# include +# include +# include + +/* buffer to hold a line of character/attribute pairs */ +#define MAXCOLS 256 +static unsigned char Line_Buffer [MAXCOLS*2]; + +#define MK_SPACE_CHAR() (((Attribute_Byte) << 8) | 0x20) + +static unsigned char *Video_Base; +# define MK_SCREEN_POINTER(row,col) ((unsigned short *)\ + (Video_Base +\ + 2 * (SLtt_Screen_Cols * (row)\ + + (col)))) +static int Video_Status_Port; + +# define MONO_STATUS 0x3BA +# define CGA_STATUS 0x3DA +# define CGA_SETMODE 0x3D8 + +# define SNOW_CHECK \ + if (SLtt_Msdos_Cheap_Video)\ + { while ((inp (CGA_STATUS) & 0x08)); while (!(inp (CGA_STATUS) & 0x08)); } + +void SLtt_write_string (char *str) +{ + /* FIXME: Priority=medium + * This should not go to stdout. */ + fputs (str, stdout); +} + +/* row is with respect to the scrolling region. */ +void SLtt_goto_rc (int r, int c) +{ + union REGS regs; + + r += Scroll_r1; + + if (r > SLtt_Screen_Rows - 1) r = SLtt_Screen_Rows - 1; + if (c > SLtt_Screen_Cols - 1) c = SLtt_Screen_Cols - 1; + + Cursor_Row = r; + Cursor_Col = c; + + regs.h.dh = r; + regs.h.dl = c; + regs.h.bh = 0; + regs.h.ah = 2; + int86 (0x10, ®s, ®s); +} + +static void asm_video_getxy (void) +{ + asm mov ah, 3 + asm mov bh, 0 + asm int 10h + asm xor ax, ax + asm mov al, dh + asm mov Cursor_Row, ax + asm xor ax, ax + asm mov al, dl + asm mov Cursor_Col, ax +} + +void SLtt_begin_insert (void) +{ + unsigned short *p; + int n; + + asm_video_getxy (); + n = SLtt_Screen_Cols - Cursor_Col; + p = MK_SCREEN_POINTER (Cursor_Row, SLtt_Screen_Cols - 1); + + SNOW_CHECK; + asm mov ax, ds + asm mov bx, di + asm mov dx, si + + asm mov cx, n + asm les di, p + asm lds si, p + asm sub si, 2 + asm std + asm rep movsw + + asm mov ds, ax + asm mov di, bx + asm mov si, dx +} + +void SLtt_end_insert (void) +{ +} + +void SLtt_delete_char (void) +{ + unsigned short *p; + int n; + + asm_video_getxy (); + n = SLtt_Screen_Cols - Cursor_Col - 1; + p = MK_SCREEN_POINTER (Cursor_Row, Cursor_Col); + + SNOW_CHECK; + asm mov ax, ds + asm mov bx, si + asm mov dx, di + + asm mov cx, n + asm les di, p + asm lds si, p + asm add si, 2 + asm cld + asm rep movsw + + asm mov ds, ax + asm mov si, bx + asm mov di, dx +} + +void SLtt_erase_line (void) +{ + unsigned short w, *p; + + p = MK_SCREEN_POINTER (Cursor_Row, 0); + Attribute_Byte = 0x07; + + w = MK_SPACE_CHAR (); + + SNOW_CHECK; + asm mov dx, di + asm mov ax, w + asm mov cx, SLtt_Screen_Cols + asm les di, p + asm cld + asm rep stosw + asm mov di, dx + + Current_Color = JNO_COLOR; /* since we messed with attribute byte */ +} + +void SLtt_delete_nlines (int nlines) +{ + SLtt_normal_video (); + + /* This has the effect of pulling all lines below it up */ + asm mov ax, nlines + asm mov ah, 6 /* int 6h */ + asm xor cx, cx + asm mov ch, byte ptr Scroll_r1 + asm mov dx, SLtt_Screen_Cols + asm dec dx + asm mov dh, byte ptr Scroll_r2 + asm mov bh, byte ptr Attribute_Byte + asm int 10h +} + +void SLtt_reverse_index (int nlines) +{ + SLtt_normal_video (); + asm xor cx, cx + asm mov ch, byte ptr Scroll_r1 + asm mov dx, SLtt_Screen_Cols + asm dec dx + asm mov dh, byte ptr Scroll_r2 + asm mov bh, byte ptr Attribute_Byte + asm mov ah, 7 + asm mov al, byte ptr nlines + asm int 10h +} + +static void asm_video_invert_region (int top_row, int bot_row) +{ + register unsigned short ch, sh; + register unsigned short *pmin = MK_SCREEN_POINTER (top_row, 0); + register unsigned short *pmax = MK_SCREEN_POINTER (bot_row, 0); + + while (pmin < pmax) + { + sh = *pmin; + ch = sh; + ch = ch ^ 0xFF00; + *pmin = (ch & 0xFF00) | (sh & 0x00FF); + pmin++; + } +} + +void SLtt_del_eol (void) +{ + unsigned short *p; + unsigned short w; + int n; + + n = SLtt_Screen_Cols - Cursor_Col; + p = MK_SCREEN_POINTER (Cursor_Row, Cursor_Col); + if (Current_Color != JNO_COLOR) SLtt_normal_video (); + w = MK_SPACE_CHAR (); + + SNOW_CHECK; + asm mov dx, di + asm les di, p + asm mov ax, w + asm mov cx, n + asm cld + asm rep stosw + + asm mov di, dx +} + +static unsigned short *asm_video_write (register unsigned char *pp, + register unsigned char *p, + register unsigned short *pos) +{ + int n = (int) (p - pp); /* num of characters of PP to write */ + + asm push si + asm push ds + asm push di + + /* set up register for BOTH fast and slow */ + asm mov bx, SLtt_Msdos_Cheap_Video + + /* These are the registers needed for both fast AND slow */ + asm mov ah, byte ptr Attribute_Byte + asm mov cx, n + asm lds si, dword ptr pp + asm les di, dword ptr pos + asm cld + + asm cmp bx, 0 /* cheap video test */ + asm je L_fast + asm mov bx, ax + asm mov dx, CGA_STATUS + asm jg L_slow_blank + + /* slow video */ + asm cli + + /* wait for retrace */ + L_slow: + asm in al, dx + asm test al, 1 + asm jnz L_slow + + L_slow1: + asm in al, dx + asm test al, 1 + asm jz L_slow1 + + /* move a character out */ + asm mov ah, bh + asm lodsb + asm stosw + asm loop L_slow + + asm sti + asm jmp done + +/* -------------- slow video, vertical retace and pump --------------*/ + L_slow_blank: + L_slow_blank_loop: + asm in al, dx + asm test al, 8 + asm jnz L_slow_blank_loop + + L_slow_blank1: + asm in al, dx + asm test al, 8 + asm jz L_slow_blank1 + /* write line */ + asm mov ah, bh + L_slow_blank2: + asm lodsb + asm stosw + asm loop L_slow_blank2 + + asm jmp done +/*-------------- Fast video --------------*/ + + L_fast: + asm lodsb + asm stosw + asm loop L_fast + done: + asm pop di + asm pop ds + asm pop si + return (pos + n); +} + +static void write_attributes (SLsmg_Char_Type *src, unsigned int count) +{ + register unsigned char *p; + register unsigned short pair; + unsigned char ch, color; + register unsigned short *pos; + + p = Line_Buffer; + pos = MK_SCREEN_POINTER (Cursor_Row, 0); + + while (count--) + { + pair = SLSMG_CHAR_TO_USHORT(*src); /* character/color pair */ + src++; + ch = pair & 0xff; /* character value */ + color = pair >> 8; /* color value */ + if (color != Current_Color) /* need a new color */ + { + if (p != Line_Buffer) + { + pos = asm_video_write (Line_Buffer, p, pos); + p = Line_Buffer; + } + SLtt_reverse_video (color); /* change color */ + } + *(p++) = ch; + } + pos = asm_video_write (Line_Buffer, p, pos); +} + +void SLtt_cls (void) +{ + SLtt_normal_video (); + + asm mov dx, SLtt_Screen_Cols + asm dec dx + asm mov ax, SLtt_Screen_Rows + asm dec ax + asm mov dh, al + asm xor cx, cx + asm xor ax, ax + asm mov ah, 7 + asm mov bh, byte ptr Attribute_Byte + asm int 10h +} + +void SLtt_putchar (char ch) +{ + unsigned short p, *pp; + + if (Current_Color) SLtt_normal_video (); + asm_video_getxy (); /* get current position */ + switch (ch) + { + case 7: /* ^G - break */ + SLtt_beep (); break; + case 8: /* ^H - backspace */ + goto_rc_abs (Cursor_Row, Cursor_Col - 1); break; + case 13: /* ^M - carriage return */ + goto_rc_abs (Cursor_Row, 0); break; + default: + /* write character to screen */ + pp = MK_SCREEN_POINTER (Cursor_Row, Cursor_Col); + p = (Attribute_Byte << 8) | (unsigned char) ch; + SNOW_CHECK; + *pp = p; + goto_rc_abs (Cursor_Row, Cursor_Col + 1); + } +} + +void SLtt_get_screen_size (void) +{ + int w, h; + + h = 0; + + /* Get BIOS's screenwidth, this works on ALL displays. */ + w = *((int *)MK_FP(0x40, 0x4a)); + + /* Use Ralf Brown test for EGA or greater */ + asm mov ah, 12h + asm mov bl, 10h + asm mov bh, 0xFF /* EGA or greater will change this */ + asm int 10h + asm cmp bh, 0xFF + asm je L1 + /* if EGA or compatible: Get BIOS's number of rows. */ + h = *(char *)MK_FP(0x40, 0x84) + 1; + /* scan_lines = *(int *) 0x485; */ + + L1: + if (h <= 0) h = 25; + + SLtt_Screen_Rows = h; + SLtt_Screen_Cols = w; +} + +void SLtt_get_terminfo (void) +{ + SLtt_get_screen_size (); +} + +/*----------------------------------------------------------------------*\ + * Function: int SLtt_init_video (void); +\*----------------------------------------------------------------------*/ +int SLtt_init_video (void) +{ + unsigned char *p; + +#ifdef HAS_SAVE_SCREEN + save_screen (); +#endif + + Cursor_Row = Cursor_Col = 0; + p = (unsigned char far *) 0x00400049L; + if (*p == 7) + { + Video_Status_Port = MONO_STATUS; + Video_Base = (unsigned char *) MK_FP (0xb000,0000); + IsColor = 0; + } + else + { + Video_Status_Port = CGA_STATUS; + Video_Base = (unsigned char *) MK_FP (0xb800,0000); + IsColor = 1; + } + + /* test for video adapter type. Of primary interest is whether there is + * snow or not. Assume snow if the card is color and not EGA or greater. + */ + + /* Use Ralf Brown test for EGA or greater */ + asm mov ah, 0x12 + asm mov bl, 0x10 + asm mov bh, 0xFF + asm int 10h + asm cmp bh, 0xFF + asm je L1 + + /* (V)EGA */ + asm xor bx, bx + asm mov SLtt_Msdos_Cheap_Video, bx + asm mov ax, Attribute_Byte + asm cmp ax, bx + asm jne L2 + asm mov ax, 0x17 + asm mov Attribute_Byte, ax + asm jmp L2 + + L1: + /* Not (V)EGA */ + asm mov ah, 0x0F + asm int 10h + asm cmp al, 7 + asm je L3 + asm mov ax, 1 + asm mov SLtt_Msdos_Cheap_Video, ax + L3: + asm mov ax, Attribute_Byte + asm cmp ax, 0 + asm jne L2 + asm mov ax, 0x07 + asm mov Attribute_Byte, ax + L2: + /* toggle the blink bit so we can use hi intensity background */ + if (IsColor && !SLtt_Msdos_Cheap_Video) + { + asm mov ax, 0x1003 + asm mov bx, 0 + asm int 0x10 + Blink_Killed = 1; + } + + SLtt_Use_Ansi_Colors = IsColor; + SLtt_get_screen_size (); + SLtt_reset_scroll_region (); + fixup_colors (); + return 0; +} + +void SLtt_beep (void) +{ + int audible; /* audible bell */ + int special = 0; /* first row to invert */ + int visual = 0; /* final row to invert */ + + if (!SLtt_Ignore_Beep) return; + + audible = (SLtt_Ignore_Beep & 1); + if ( (SLtt_Ignore_Beep & 4) ) + { + special = SLtt_Screen_Rows - 1; + visual = special--; /* only invert bottom status line */ + } + else if ( (SLtt_Ignore_Beep & 2) ) + { + visual = SLtt_Screen_Rows; + } + + if (visual) asm_video_invert_region (special, visual); + if (audible) sound (1500); delay (100); if (audible) nosound (); + if (visual) asm_video_invert_region (special, visual); +} + +#endif /* IBMPC_ASM_VIDEO */ + +/*}}}*/ + +#ifdef GO32_VIDEO /*{{{*/ + +# include +# define HAS_SAVE_SCREEN 1 + +# ifdef HAS_SAVE_SCREEN +static void *Saved_Screen_Buffer; +static int Saved_Cursor_Row; + +static void save_screen (void) +{ + int row, col; + + SLfree ((char *) Saved_Screen_Buffer); + Saved_Screen_Buffer = NULL; + + Saved_Screen_Buffer = (short *) SLmalloc (sizeof (short) * + ScreenCols () * ScreenRows ()); + + if (Saved_Screen_Buffer == NULL) + return; + + ScreenRetrieve (Saved_Screen_Buffer); + ScreenGetCursor (&row, &col); + Saved_Cursor_Row = row; +} + +static void restore_screen (void) +{ + if (Saved_Screen_Buffer == NULL) return; + ScreenUpdate (Saved_Screen_Buffer); + goto_rc_abs (Saved_Cursor_Row, 0); +} +#endif /* HAS_SAVE_SCREEN */ + +void SLtt_write_string (char *str) +{ + while (Cursor_Col < SLtt_Screen_Cols) + { + char ch = *str++; + + if (ch == 0) + break; + + ScreenPutChar (ch, Attribute_Byte, Cursor_Col, Cursor_Row); + Cursor_Col++; + } + goto_rc_abs (Cursor_Row, Cursor_Col); +} + +void SLtt_goto_rc (int row, int col) +{ + row += Scroll_r1; + if (row > SLtt_Screen_Rows) row = SLtt_Screen_Rows; + if (col > SLtt_Screen_Cols) col = SLtt_Screen_Cols; + + ScreenSetCursor (row, col); + + Cursor_Row = row; + Cursor_Col = col; +} + +static void go32_video_getxy (void) +{ + ScreenGetCursor (&Cursor_Row, &Cursor_Col); +} + +static void go32_video_deleol (int x) +{ + while (x < SLtt_Screen_Cols) + ScreenPutChar (32, Attribute_Byte, x++, Cursor_Row); +} + +void SLtt_begin_insert (void) +{ +} + +void SLtt_end_insert (void) +{ +} + +void SLtt_delete_char (void) +{ +} + +void SLtt_erase_line (void) +{ + Attribute_Byte = 0x07; + go32_video_deleol (0); + Current_Color = JNO_COLOR; /* since we messed with attribute byte */ +} + +void SLtt_delete_nlines (int nlines) +{ + union REGS r; + + SLtt_normal_video (); + + r.x.ax = nlines; + r.x.cx = 0; + r.h.ah = 6; + r.h.ch = Scroll_r1; + r.h.dl = SLtt_Screen_Cols - 1; + r.h.dh = Scroll_r2; + r.h.bh = Attribute_Byte; + int86 (0x10, &r, &r); +} + +void SLtt_reverse_index (int nlines) +{ + union REGS r; + + SLtt_normal_video (); + + r.h.al = nlines; + r.x.cx = 0; + r.h.ah = 7; + r.h.ch = Scroll_r1; + r.h.dl = SLtt_Screen_Cols - 1; + r.h.dh = Scroll_r2; + r.h.bh = Attribute_Byte; + int86 (0x10, &r, &r); +} + +static void go32_video_invert_region (int top_row, int bot_row) +{ + unsigned char buf [2 * 180 * 80]; /* 180 cols x 80 rows */ + unsigned char *b, *bmax; + + b = buf + 1 + 2 * SLtt_Screen_Cols * top_row; + bmax = buf + 1 + 2 * SLtt_Screen_Cols * bot_row; + + ScreenRetrieve (buf); + while (b < bmax) + { + *b ^= 0xFF; + b += 2; + } + ScreenUpdate (buf); +} + +void SLtt_beep (void) +{ + int audible; /* audible bell */ + int special = 0; /* first row to invert */ + int visual = 0; /* final row to invert */ + + if (!SLtt_Ignore_Beep) return; + + audible = (SLtt_Ignore_Beep & 1); + if ( (SLtt_Ignore_Beep & 4) ) + { + special = SLtt_Screen_Rows - 1; + visual = special--; /* only invert bottom status line */ + } + else if ( (SLtt_Ignore_Beep & 2) ) + { + visual = SLtt_Screen_Rows; + } + + if (visual) go32_video_invert_region (special, visual); + if (audible) sound (1500); delay (100); if (audible) nosound (); + if (visual) go32_video_invert_region (special, visual); +} + +void SLtt_del_eol (void) +{ + if (Current_Color != JNO_COLOR) SLtt_normal_video (); + go32_video_deleol (Cursor_Col); +} + +static void +write_attributes (SLsmg_Char_Type *src, unsigned int count) +{ + register unsigned short pair; + unsigned int n; + + /* write into a character/attribute pair */ + n = Cursor_Col; + while (count) + { + pair = SLSMG_CHAR_TO_USHORT(*src);/* character/color pair */ + src++; + SLtt_reverse_video (pair >> 8); /* color change */ + ScreenPutChar ((int)pair & 0xFF, Attribute_Byte, n, Cursor_Row); + n++; + count--; + } +} + +/*----------------------------------------------------------------------*\ + * Function: void SLtt_cls (void); +\*----------------------------------------------------------------------*/ +void SLtt_cls (void) +{ + SLtt_normal_video (); + SLtt_reset_scroll_region (); + SLtt_goto_rc (0, 0); + SLtt_delete_nlines (SLtt_Screen_Rows); +} + +void SLtt_putchar (char ch) +{ + if (Current_Color) SLtt_normal_video (); + + go32_video_getxy (); /* get current position */ + + switch (ch) + { + case 7: /* ^G - break */ + SLtt_beep (); break; + case 8: /* ^H - backspace */ + goto_rc_abs (Cursor_Row, Cursor_Col - 1); break; + case 13: /* ^M - carriage return */ + goto_rc_abs (Cursor_Row, 0); break; + default: /* write character to screen */ + ScreenPutChar ((int) ch, Attribute_Byte, Cursor_Col, Cursor_Row); + goto_rc_abs (Cursor_Row, Cursor_Col + 1); + } +} + +void SLtt_get_screen_size (void) +{ + SLtt_Screen_Rows = ScreenRows (); + SLtt_Screen_Cols = ScreenCols (); +} + +void SLtt_get_terminfo (void) +{ + SLtt_get_screen_size (); +} + +int SLtt_init_video (void) +{ +#ifdef HAS_SAVE_SCREEN + save_screen (); +#endif + + if (!Attribute_Byte) Attribute_Byte = 0x17; + + IsColor = 1; /* is it really? */ + + if (IsColor) + { + union REGS r; + r.x.ax = 0x1003; r.x.bx = 0; + int86 (0x10, &r, &r); + Blink_Killed = 1; + } + + Cursor_Row = Cursor_Col = 0; + + SLtt_Term_Cannot_Insert = 1; + SLtt_reset_scroll_region (); + SLtt_Use_Ansi_Colors = IsColor; + fixup_colors (); + return 0; +} + +#endif /* GO32_VIDEO */ + +/*}}}*/ + +#ifdef EMX_VIDEO /*{{{*/ + +# define INCL_VIO +# define INCL_DOSPROCESS +# include +# include +# include + +static VIOMODEINFO vioModeInfo; +/* buffer to hold a line of character/attribute pairs */ +#define MAXCOLS 256 +static unsigned char Line_Buffer [MAXCOLS*2]; + +/* this is how to make a space character */ +#define MK_SPACE_CHAR() (((Attribute_Byte) << 8) | 0x20) + +void SLtt_write_string (char *str) +{ + /* FIXME: Priority=medium + * This should not go to stdout. */ + fputs (str, stdout); +} + +void SLtt_goto_rc (int row, int col) +{ + row += Scroll_r1; + if (row > SLtt_Screen_Rows) row = SLtt_Screen_Rows; + if (col > SLtt_Screen_Cols) col = SLtt_Screen_Cols; + v_gotoxy (col, row); + Cursor_Row = row; + Cursor_Col = col; +} + +static void emx_video_getxy (void) +{ + v_getxy (&Cursor_Col, &Cursor_Row); +} + +static void emx_video_deleol (int x) +{ + unsigned char *p, *pmax; + int count = SLtt_Screen_Cols - x; + int w = MK_SPACE_CHAR (); + + p = Line_Buffer; + pmax = p + 2 * count; + + while (p < pmax) + { + *p++ = (unsigned char) w; + *p++ = (unsigned char) (w >> 8); + } + + v_putline (Line_Buffer, x, Cursor_Row, count); +} + +void SLtt_begin_insert (void) +{ + int n; + + emx_video_getxy (); + + n = SLtt_Screen_Cols - Cursor_Col; + v_getline (Line_Buffer, Cursor_Col, Cursor_Row, n); + v_putline (Line_Buffer, Cursor_Col+1, Cursor_Row, n - 1); +} + +void SLtt_end_insert (void) +{ +} + +void SLtt_delete_char (void) +{ + int n; + + emx_video_getxy (); + + n = SLtt_Screen_Cols - Cursor_Col - 1; + v_getline (Line_Buffer, Cursor_Col+1, Cursor_Row, n); + v_putline (Line_Buffer, Cursor_Col, Cursor_Row, n); +} + +void SLtt_erase_line (void) +{ + Attribute_Byte = 0x07; + emx_video_deleol (0); + Current_Color = JNO_COLOR; /* since we messed with attribute byte */ +} + +void SLtt_delete_nlines (int nlines) +{ + SLtt_normal_video (); + v_attrib (Attribute_Byte); + v_scroll (0, Scroll_r1, SLtt_Screen_Cols-1, Scroll_r2, nlines, V_SCROLL_UP); +} + +void SLtt_reverse_index (int nlines) +{ + SLtt_normal_video (); + + v_attrib (Attribute_Byte); + v_scroll (0, Scroll_r1, SLtt_Screen_Cols-1, Scroll_r2, nlines, + V_SCROLL_DOWN); +} + +static void emx_video_invert_region (int top_row, int bot_row) +{ + int row, col; + + for (row = top_row; row < bot_row; row++) + { + v_getline (Line_Buffer, 0, row, SLtt_Screen_Cols); + for (col = 1; col < SLtt_Screen_Cols * 2; col += 2) + Line_Buffer [col] ^= 0xff; + v_putline (Line_Buffer, 0, row, SLtt_Screen_Cols); + } +} + +void SLtt_beep (void) +{ + int audible; /* audible bell */ + int special = 0; /* first row to invert */ + int visual = 0; /* final row to invert */ + + if (!SLtt_Ignore_Beep) return; + + audible = (SLtt_Ignore_Beep & 1); + if ( (SLtt_Ignore_Beep & 4) ) + { + special = SLtt_Screen_Rows - 1; + visual = special--; /* only invert bottom status line */ + } + else if ( (SLtt_Ignore_Beep & 2) ) + { + visual = SLtt_Screen_Rows; + } + + if (visual) emx_video_invert_region (special, visual); + if (audible) /*sound (1500)*/; _sleep2 (100); if (audible) /* nosound () */; + if (visual) emx_video_invert_region (special, visual); +} + +void SLtt_del_eol (void) +{ + if (Current_Color != JNO_COLOR) SLtt_normal_video (); + emx_video_deleol (Cursor_Col); +} + +static void +write_attributes (SLsmg_Char_Type *src, unsigned int count) +{ + register unsigned char *p = Line_Buffer; + register unsigned short pair; + int n = count; + + /* write into a character/attribute pair */ + while (n-- > 0) + { + pair = SLSMG_CHAR_TO_USHORT(*src);/* character/color pair */ + src++; + SLtt_reverse_video (pair >> 8); /* color change */ + *(p++) = pair & 0xff; /* character byte */ + *(p++) = Attribute_Byte; /* attribute byte */ + } + v_putline (Line_Buffer, Cursor_Col, Cursor_Row, count); +} + +void SLtt_cls (void) +{ + SLtt_normal_video (); + SLtt_reset_scroll_region (); + SLtt_goto_rc (0, 0); + SLtt_delete_nlines (SLtt_Screen_Rows); +} + +void SLtt_putchar (char ch) +{ + if (Current_Color) SLtt_normal_video (); + + emx_video_getxy (); /* get current position */ + switch (ch) + { + case 7: /* ^G - break */ + SLtt_beep (); break; + case 8: /* ^H - backspace */ + goto_rc_abs (Cursor_Row, Cursor_Col - 1); break; + case 13: /* ^M - carriage return */ + goto_rc_abs (Cursor_Row, 0); break; + default: /* write character to screen */ + v_putn (ch, 1); + goto_rc_abs (Cursor_Row, Cursor_Col + 1); + } +} + +void SLtt_get_terminfo (void) +{ + SLtt_get_screen_size (); +} + +void SLtt_get_screen_size (void) +{ + vioModeInfo.cb = sizeof(vioModeInfo); + VioGetMode (&vioModeInfo, 0); + SLtt_Screen_Cols = vioModeInfo.col; + SLtt_Screen_Rows = vioModeInfo.row; +} + +int SLtt_init_video (void) +{ + int OldCol, OldRow; + PTIB ptib; + PPIB ppib; + USHORT args[3] = { 6, 2, 1 }; + +#ifdef HAS_SAVE_SCREEN + save_screen (); +#endif + + Cursor_Row = Cursor_Col = 0; + + v_init (); + if ( v_hardware () != V_MONOCHROME ) IsColor = 1; else IsColor = 0; + + v_getxy(&OldCol,&OldRow); + v_gotoxy (0, 0); + if (IsColor) + { + if (_osmode == OS2_MODE) + { +# if 0 + /* Enable high-intensity background colors */ + VIOINTENSITY RequestBlock; + RequestBlock.cb = sizeof (RequestBlock); + RequestBlock.type = 2; RequestBlock.fs = 1; + VioSetState (&RequestBlock, 0); /* nop if !fullscreen */ +# endif + } + } + + DosGetInfoBlocks (&ptib, &ppib); + if ((ppib->pib_ultype) == 2) /* VIO */ + Blink_Killed = 1; + else + { /* Fullscreen */ + if (VioSetState (args, 0) == 0) + Blink_Killed = 1; + else + Blink_Killed = 0; + } + + if (!Attribute_Byte) + { + /* find the attribute currently under the cursor */ + v_getline (Line_Buffer, OldCol, OldRow, 1); + Attribute_Byte = Line_Buffer[1]; + SLtt_set_color (JNORMAL_COLOR, NULL, + Color_Names[(Attribute_Byte) & 0xf], + Color_Names[(Attribute_Byte) >> 4]); + } + + v_attrib (Attribute_Byte); + + fixup_colors (); + + SLtt_get_screen_size (); + SLtt_Use_Ansi_Colors = IsColor; + SLtt_reset_scroll_region (); + return 0; +} + +#endif /* EMX_VIDEO */ + +/*}}}*/ + +#ifdef WIN32_VIDEO /*{{{*/ + +#include + +static HANDLE hStdout = INVALID_HANDLE_VALUE; + +#define MAXCOLS 256 +static CHAR_INFO Line_Buffer [MAXCOLS]; + +void SLtt_write_string (char *str) +{ + DWORD bytes; + int n, c; + if (str == NULL) return; + + n = (int) strlen (str); + c = n + Cursor_Col; + if (c >= SLtt_Screen_Cols) + n = SLtt_Screen_Cols - Cursor_Col; + if (n < 0) n = 0; + + (void) WriteConsole (hStdout, str, (unsigned int) n, &bytes, NULL); + + goto_rc_abs (Cursor_Row, Cursor_Col + n); +} + +void SLtt_goto_rc (int row, int col) +{ + COORD newPosition; + + row += Scroll_r1; + if (row > SLtt_Screen_Rows) row = SLtt_Screen_Rows; + if (col > SLtt_Screen_Cols) col = SLtt_Screen_Cols; + newPosition.X = col; + newPosition.Y = row; + + (void) SetConsoleCursorPosition(hStdout, newPosition); + + Cursor_Row = row; + Cursor_Col = col; +} + +static void win32_video_getxy (void) +{ + CONSOLE_SCREEN_BUFFER_INFO screenInfo; + + if (TRUE == GetConsoleScreenBufferInfo(hStdout, &screenInfo)) + { + Cursor_Row = screenInfo.dwCursorPosition.Y; + Cursor_Col = screenInfo.dwCursorPosition.X; + } +} + +static void win32_video_hscroll (int n) +{ + SMALL_RECT rc; + COORD c; + CHAR_INFO ci; + WORD w = 227; + DWORD d; + + win32_video_getxy (); + + rc.Left = Cursor_Col; + rc.Right = SLtt_Screen_Cols; + rc.Top = rc.Bottom = Cursor_Row; + + c.Y = Cursor_Row; +#if 1 + c.X = SLtt_Screen_Cols - 1; + ReadConsoleOutputAttribute(hStdout, &w, 1, c, &d); +#else + /* New region gets the current color */ + w = Attribute_Byte; +#endif + c.X = Cursor_Col + n; + + ci.Char.AsciiChar = ' '; + ci.Attributes = w; + + ScrollConsoleScreenBuffer(hStdout, &rc, &rc, c, &ci); +} + +static void win32_video_deleol (int x) +{ + DWORD d; + COORD c; + + c.X = x; + c.Y = Cursor_Row; + + x = SLtt_Screen_Cols - x; + FillConsoleOutputCharacter(hStdout, ' ', x, c, &d); + FillConsoleOutputAttribute(hStdout, (char)Attribute_Byte, x, c, &d); +} + +static void win32_video_vscroll (int n) +{ + SMALL_RECT rc, clip_rc; + COORD c; + CHAR_INFO ci; + + SLtt_normal_video(); + + /* ScrollConsoleScreenBuffer appears to have a bug when + * Scroll_r1 == Scroll_r2. Sigh. + */ + if (Scroll_r2 == Scroll_r1) + { + SLtt_goto_rc (0, 0); + win32_video_deleol (0); + return; + } + + rc.Left = clip_rc.Left = 0; + rc.Right = clip_rc.Right = SLtt_Screen_Cols - 1; + rc.Top = clip_rc.Top = Scroll_r1; + rc.Bottom = clip_rc.Bottom = Scroll_r2; + + c.X = 0; + c.Y = Scroll_r1 + n; + + ci.Char.AsciiChar = ' '; + ci.Attributes = Attribute_Byte; + + ScrollConsoleScreenBuffer(hStdout, &rc, &clip_rc, c, &ci); +} + +void SLtt_begin_insert (void) +{ + win32_video_hscroll (1); +} + +void SLtt_end_insert (void) +{ +} + +void SLtt_delete_char (void) +{ + win32_video_hscroll (-1); +} + +void SLtt_erase_line (void) +{ + Attribute_Byte = 0x7; + win32_video_deleol (0); + Current_Color = JNO_COLOR; +} + +void SLtt_delete_nlines (int nlines) +{ + win32_video_vscroll (-nlines); +} + +void SLtt_reverse_index (int nlines) +{ + win32_video_vscroll (nlines); +} + +static void win32_invert_region (int top_row, int bot_row) +{ + (void) top_row; (void) bot_row; +} + +void SLtt_beep (void) +{ + int audible; /* audible bell */ + int special = 0; /* first row to invert */ + int visual = 0; /* final row to invert */ + + if (!SLtt_Ignore_Beep) return; + + audible = (SLtt_Ignore_Beep & 1); + + if ( (SLtt_Ignore_Beep & 4) ) + { + special = SLtt_Screen_Rows - 1; + visual = special--; /* only invert bottom status line */ + } + else if ( (SLtt_Ignore_Beep & 2) ) + { + visual = SLtt_Screen_Rows; + } + + if (visual) win32_invert_region (special, visual); + if (audible) Beep (1500, 100); else Sleep (100); + if (visual) win32_invert_region (special, visual); +} + +void SLtt_del_eol (void) +{ + if (Current_Color != JNO_COLOR) + SLtt_normal_video (); + win32_video_deleol (Cursor_Col); +} + +static void +write_attributes (SLsmg_Char_Type *src, unsigned int count) +{ + unsigned short pair; + COORD coord, c; + CHAR_INFO *p; + unsigned int n; + SMALL_RECT rc; + + /* write into a character/attribute pair */ + n = count; + p = Line_Buffer; + while (n) + { + n--; + pair = SLSMG_CHAR_TO_USHORT(*src);/* character/color pair */ + src++; + SLtt_reverse_video (pair >> 8); /* color change */ + p->Char.AsciiChar = pair & 0xff; + p->Attributes = Attribute_Byte; + p++; + } + + c.X = count; + c.Y = 1; + coord.X = coord.Y = 0; + rc.Left = Cursor_Col; + rc.Right = Cursor_Col + count - 1; + rc.Top = rc.Bottom = Cursor_Row; + WriteConsoleOutput(hStdout, Line_Buffer, c, coord, &rc); +} + +void SLtt_cls (void) +{ + DWORD bytes; + COORD coord; + char ch; + + SLtt_normal_video (); + /* clear the WIN32 screen in one shot */ + coord.X = 0; + coord.Y = 0; + + ch = ' '; + + (void) FillConsoleOutputCharacter(hStdout, + ch, + SLtt_Screen_Cols * SLtt_Screen_Rows, + coord, + &bytes); + + /* now set screen to the current attribute */ + ch = Attribute_Byte; + (void) FillConsoleOutputAttribute(hStdout, + ch, + SLtt_Screen_Cols * SLtt_Screen_Rows, + coord, + &bytes); +} + +void SLtt_putchar (char ch) +{ + DWORD bytes; + WORD attr; + COORD c; + + if (Current_Color) SLtt_normal_video (); + win32_video_getxy (); + switch (ch) + { + case 7: /* ^G - break */ + SLtt_beep (); break; + case 8: /* ^H - backspace */ + goto_rc_abs (Cursor_Row, Cursor_Col - 1); break; + case 13: /* ^M - carriage return */ + goto_rc_abs (Cursor_Row, 0); break; + default: /* write character to screen */ + c.X = Cursor_Col; + c.Y = Cursor_Row; + attr = Attribute_Byte; + WriteConsoleOutputCharacter(hStdout, &ch, 1, c, &bytes); + WriteConsoleOutputAttribute(hStdout, &attr, 1, c, &bytes); + goto_rc_abs (Cursor_Row, Cursor_Col + 1); + } +} + +void SLtt_get_screen_size (void) +{ + CONSOLE_SCREEN_BUFFER_INFO csbi; + HANDLE h; + + h = hStdout; + if (h == INVALID_HANDLE_VALUE) + h = GetStdHandle (STD_OUTPUT_HANDLE); + + if ((h == INVALID_HANDLE_VALUE) + || (FALSE == GetConsoleScreenBufferInfo(h, &csbi))) + { + SLang_exit_error ("Unable to determine the screen size"); + return; + } +#if 0 + SLtt_Screen_Rows = csbi.dwSize.Y; + SLtt_Screen_Cols = csbi.dwSize.X; +#else + SLtt_Screen_Rows = (csbi.srWindow.Bottom - csbi.srWindow.Top) + 1; + SLtt_Screen_Cols = (csbi.srWindow.Right - csbi.srWindow.Left) + 1; +#endif +} + +void SLtt_get_terminfo (void) +{ + SLtt_get_screen_size (); +} + +static int win32_resize (void) +{ + SMALL_RECT windowRect; + + SLtt_get_screen_size (); + + windowRect.Left = 0; + windowRect.Top = 0; + windowRect.Right = SLtt_Screen_Cols - 1; + windowRect.Bottom = SLtt_Screen_Rows - 1; + + if (FALSE == SetConsoleWindowInfo(hStdout, TRUE, &windowRect)) + return -1; + + return 0; +} + +static int win32_init (void) +{ + SECURITY_ATTRIBUTES sec; + + memset ((char *) &sec, 0, sizeof(SECURITY_ATTRIBUTES)); + sec.nLength = sizeof (SECURITY_ATTRIBUTES); + sec.bInheritHandle = FALSE; + + hStdout = CreateConsoleScreenBuffer(GENERIC_READ | GENERIC_WRITE, + FILE_SHARE_READ|FILE_SHARE_WRITE, + &sec, + CONSOLE_TEXTMODE_BUFFER, + 0); + + if (hStdout == INVALID_HANDLE_VALUE) + return -1; + + if ((FALSE == SetConsoleActiveScreenBuffer(hStdout)) + || (FALSE == SetConsoleMode(hStdout, 0)) + || (-1 == win32_resize ())) + { + SLtt_reset_video (); + return -1; + } + + return 0; +} + +int SLtt_init_video (void) +{ + SLtt_reset_video (); + + if (-1 == win32_init ()) + return -1; + + /* It is possible for SLtt_init_video to be called after suspension. + * For all I know, the window size may have changed. So, resize it + * now. + */ + + Cursor_Row = Cursor_Col = 0; + SLtt_Use_Ansi_Colors = IsColor = 1; + Blink_Killed = 1; + + SLtt_reset_scroll_region (); + goto_rc_abs (0, 0); + fixup_colors (); + + return 0; +} + +int SLtt_reset_video (void) +{ + if (hStdout == INVALID_HANDLE_VALUE) + return 0; + + SLtt_reset_scroll_region (); + SLtt_goto_rc (SLtt_Screen_Rows - 1, 0); + Attribute_Byte = 0x7; + Current_Color = JNO_COLOR; + SLtt_del_eol (); + (void) CloseHandle (hStdout); + + hStdout = GetStdHandle (STD_OUTPUT_HANDLE); + if (hStdout != INVALID_HANDLE_VALUE) + (void) SetConsoleActiveScreenBuffer(hStdout); + + hStdout = INVALID_HANDLE_VALUE; + return 0; +} + +#endif + +/*}}}*/ + +#ifdef OS2_VIDEO /*{{{*/ + +# define INCL_BASE +# define INCL_NOPM +# define INCL_VIO +# define INCL_KBD + +# define INCL_DOSPROCESS + +# include +# ifndef __IBMC__ +# include +# endif +/* this is how to make a space character */ +#define MK_SPACE_CHAR() (((Attribute_Byte) << 8) | 0x20) + +/* buffer to hold a line of character/attribute pairs */ +#define MAXCOLS 256 +static unsigned char Line_Buffer [MAXCOLS*2]; + +void SLtt_write_string (char *str) +{ + /* FIXME: Priority=medium + * This should not go to stdout. */ + fputs (str, stdout); +} + +void SLtt_goto_rc (int row, int col) +{ + row += Scroll_r1; + VioSetCurPos (row, col, 0); + Cursor_Row = row; + Cursor_Col = col; +} + +static void os2_video_getxy (void) +{ + USHORT r, c; + + VioGetCurPos (&r, &c, 0); + Cursor_Row = r; + Cursor_Col = c; +} + +void SLtt_begin_insert (void) +{ + USHORT n; + + os2_video_getxy (); + n = SLtt_Screen_Cols - Cursor_Col; + + n = 2 * (n - 1); + VioReadCellStr ((PCH)Line_Buffer, &n, Cursor_Row, Cursor_Col, 0); + VioWrtCellStr ((PCH)Line_Buffer, n, Cursor_Row, Cursor_Col + 1, 0); +} + +void SLtt_end_insert (void) +{ +} + +void SLtt_delete_char (void) +{ + USHORT n; + + os2_video_getxy (); + n = SLtt_Screen_Cols - Cursor_Col - 1; + + n *= 2; + VioReadCellStr ((PCH)Line_Buffer, &n, Cursor_Row, Cursor_Col + 1, 0); + VioWrtCellStr ((PCH)Line_Buffer, n, Cursor_Row, Cursor_Col, 0); +} + +void SLtt_erase_line (void) +{ + USHORT w; + + Attribute_Byte = 0x07; + w = MK_SPACE_CHAR (); + + VioWrtNCell ((BYTE*)&w, SLtt_Screen_Cols, Cursor_Row, 0, 0); + + Current_Color = JNO_COLOR; /* since we messed with attribute byte */ +} + +void SLtt_delete_nlines (int nlines) +{ + SLtt_normal_video (); + + Line_Buffer[0] = ' '; Line_Buffer[1] = Attribute_Byte; + VioScrollUp (Scroll_r1, 0, Scroll_r2, SLtt_Screen_Cols-1, + nlines, (PCH) Line_Buffer, 0); +} + +void SLtt_reverse_index (int nlines) +{ + SLtt_normal_video (); + + Line_Buffer[0] = ' '; Line_Buffer[1] = Attribute_Byte; + VioScrollDn (Scroll_r1, 0, Scroll_r2, SLtt_Screen_Cols-1, + nlines, (PCH) Line_Buffer, 0); +} + +static void os2_video_invert_region (int top_row, int bot_row) +{ + int row, col; + USHORT length = SLtt_Screen_Cols * 2; + + for (row = top_row; row < bot_row; row++) + { + VioReadCellStr ((PCH)Line_Buffer, &length, row, 0, 0); + for (col = 1; col < length; col += 2) + Line_Buffer [col] ^= 0xff; + VioWrtCellStr ((PCH)Line_Buffer, length, row, 0, 0); + } +} + +void SLtt_beep (void) +{ + int audible; /* audible bell */ + int special = 0; /* first row to invert */ + int visual = 0; /* final row to invert */ + + if (!SLtt_Ignore_Beep) return; + + audible = (SLtt_Ignore_Beep & 1); + + if ( (SLtt_Ignore_Beep & 4) ) + { + special = SLtt_Screen_Rows - 1; + visual = special--; /* only invert bottom status line */ + } + else if ( (SLtt_Ignore_Beep & 2) ) + { + visual = SLtt_Screen_Rows; + } + + if (visual) os2_video_invert_region (special, visual); + if (audible) DosBeep (1500, 100); else DosSleep (100); + if (visual) os2_video_invert_region (special, visual); +} + +void SLtt_del_eol (void) +{ + USHORT w; + if (Current_Color != JNO_COLOR) SLtt_normal_video (); + + w = MK_SPACE_CHAR (); + + VioWrtNCell ((BYTE*)&w, (SLtt_Screen_Cols - Cursor_Col), + Cursor_Row, Cursor_Col, 0); +} + +static void +write_attributes (SLsmg_Char_Type *src, unsigned int count) +{ + register unsigned char *p = Line_Buffer; + register unsigned short pair; + int n = count; + + /* write into a character/attribute pair */ + while (n-- > 0) + { + pair = SLSMG_CHAR_TO_USHORT(*src);/* character/color pair */ + src++; + SLtt_reverse_video (pair >> 8); /* color change */ + *(p++) = pair & 0xff; /* character byte */ + *(p++) = Attribute_Byte; /* attribute byte */ + } + + VioWrtCellStr ((PCH)Line_Buffer, (USHORT)(2 * count), + (USHORT)Cursor_Row, (USHORT)Cursor_Col, 0); +} + +void SLtt_cls (void) +{ + SLtt_normal_video (); + Line_Buffer [0] = ' '; Line_Buffer [1] = Attribute_Byte; + VioScrollUp (0, 0, -1, -1, -1, (PCH)Line_Buffer, 0); +} + +void SLtt_putchar (char ch) +{ + unsigned short p, *pp; + + if (Current_Color) SLtt_normal_video (); + os2_video_getxy (); /* get current position */ + + switch (ch) + { + case 7: /* ^G - break */ + SLtt_beep (); break; + case 8: /* ^H - backspace */ + goto_rc_abs (Cursor_Row, Cursor_Col - 1); break; + case 13: /* ^M - carriage return */ + goto_rc_abs (Cursor_Row, 0); break; + default: /* write character to screen */ + VioWrtCharStrAtt (&ch, 1, Cursor_Row, Cursor_Col, + (BYTE*)&Attribute_Byte, 0); + goto_rc_abs (Cursor_Row, Cursor_Col + 1); + } +} + +void SLtt_get_screen_size (void) +{ +#ifdef __os2__ +# ifdef __IBMC__ + VIOMODEINFO vioModeInfo; +# endif + vioModeInfo.cb = sizeof(vioModeInfo); + VioGetMode (&vioModeInfo, 0); + SLtt_Screen_Cols = vioModeInfo.col; + SLtt_Screen_Rows = vioModeInfo.row; +#endif +} + +void SLtt_get_terminfo (void) +{ + SLtt_get_screen_size (); +} + +int SLtt_init_video (void) +{ + VIOINTENSITY RequestBlock; + PTIB ptib; + PPIB ppib; + USHORT args[3] = { 6, 2, 1 }; + + Cursor_Row = Cursor_Col = 0; + + IsColor = 1; /* is it really? */ + + /* Enable high-intensity background colors */ + RequestBlock.cb = sizeof (RequestBlock); + RequestBlock.type = 2; RequestBlock.fs = 1; + VioSetState (&RequestBlock, 0); /* nop if !fullscreen */ + + DosGetInfoBlocks (&ptib, &ppib); + if ((ppib->pib_ultype) == 2) /* VIO */ + Blink_Killed = 1; + else + { /* Fullscreen */ + if (VioSetState (args, 0) == 0) + Blink_Killed = 1; + else + Blink_Killed = 0; + } + + if (!Attribute_Byte) + { + /* find the attribute currently under the cursor */ + USHORT len, r, c; + + len = 2; + VioGetCurPos (&r, &c, 0); + VioReadCellStr ((PCH)Line_Buffer, &len, r, c, 0); + Attribute_Byte = Line_Buffer[1]; + + SLtt_set_color (JNORMAL_COLOR, NULL, + Color_Names[(Attribute_Byte) & 0xf], + Color_Names[(Attribute_Byte) >> 4]); + } + + SLtt_Use_Ansi_Colors = IsColor; + SLtt_get_screen_size (); + SLtt_reset_scroll_region (); + fixup_colors (); + + return 0; +} + +#endif /* OS2_VIDEO */ +/*}}}*/ + +#ifdef WATCOM_VIDEO /*{{{*/ + +# include +# define int86 int386 /* simplify code writing */ + +#include + +/* this is how to make a space character */ +#define MK_SPACE_CHAR() (((Attribute_Byte) << 8) | 0x20) + +/* buffer to hold a line of character/attribute pairs */ +#define MAXCOLS 256 +static unsigned char Line_Buffer [MAXCOLS*2]; + +/* define for direct to memory screen writes */ +static unsigned char *Video_Base; +#define MK_SCREEN_POINTER(row,col) \ + ((unsigned short *)(Video_Base + 2 * (SLtt_Screen_Cols * (row) + (col)))) + +#define ScreenPrimary (0xb800 << 4) +#define ScreenSize (SLtt_Screen_Cols * SLtt_Screen_Rows) +#define ScreenSetCursor(x,y) _settextposition (x+1,y+1) + +void ScreenGetCursor (int *x, int *y) +{ + struct rccoord rc = _gettextposition (); + *x = rc.row - 1; + *y = rc.col - 1; +} + +void ScreenRetrieve (unsigned char *dest) +{ + memcpy (dest, (unsigned char *) ScreenPrimary, 2 * ScreenSize); +} + +void ScreenUpdate (unsigned char *src) +{ + memcpy ((unsigned char *) ScreenPrimary, src, 2 * ScreenSize); +} + +void SLtt_write_string (char *str) +{ + /* FIXME: Priority=medium + * This should not go to stdout. */ + fputs (str, stdout); +} + +void SLtt_goto_rc (int row, int col) +{ + row += Scroll_r1; + if (row > SLtt_Screen_Rows) row = SLtt_Screen_Rows; + if (col > SLtt_Screen_Cols) col = SLtt_Screen_Cols; + ScreenSetCursor(row, col); + Cursor_Row = row; + Cursor_Col = col; +} + +static void watcom_video_getxy (void) +{ + ScreenGetCursor (&Cursor_Row, &Cursor_Col); +} + +void SLtt_begin_insert (void) +{ + unsigned short *p; + unsigned short *pmin; + int n; + + watcom_video_getxy (); + n = SLtt_Screen_Cols - Cursor_Col; + + p = MK_SCREEN_POINTER (Cursor_Row, SLtt_Screen_Cols - 1); + pmin = MK_SCREEN_POINTER (Cursor_Row, Cursor_Col); + + while (p-- > pmin) *(p + 1) = *p; +} + +void SLtt_end_insert (void) +{ +} + +void SLtt_delete_char (void) +{ + unsigned short *p; + register unsigned short *p1; + int n; + + watcom_video_getxy (); + n = SLtt_Screen_Cols - Cursor_Col - 1; + + p = MK_SCREEN_POINTER (Cursor_Row, Cursor_Col); + while (n--) + { + p1 = p + 1; + *p = *p1; + p++; + } +} + +void SLtt_erase_line (void) +{ + unsigned short w; + unsigned short *p = MK_SCREEN_POINTER (Cursor_Row, 0); + register unsigned short *pmax = p + SLtt_Screen_Cols; + + Attribute_Byte = 0x07; + w = MK_SPACE_CHAR (); + while (p < pmax) *p++ = w; + Current_Color = JNO_COLOR; /* since we messed with attribute byte */ +} + +void SLtt_delete_nlines (int nlines) +{ + union REGS r; + + SLtt_normal_video (); + r.x.eax = nlines; + r.x.ecx = 0; + r.h.ah = 6; + r.h.ch = Scroll_r1; + r.h.dl = SLtt_Screen_Cols - 1; + r.h.dh = Scroll_r2; + r.h.bh = Attribute_Byte; + int86 (0x10, &r, &r); +} + +void SLtt_reverse_index (int nlines) +{ + union REGS r; + + SLtt_normal_video (); + r.h.al = nlines; + r.x.ecx = 0; + r.h.ah = 7; + r.h.ch = Scroll_r1; + r.h.dl = SLtt_Screen_Cols - 1; + r.h.dh = Scroll_r2; + r.h.bh = Attribute_Byte; + int86 (0x10, &r, &r); +} + +static void watcom_video_invert_region (int top_row, int bot_row) +{ + unsigned char buf [2 * 180 * 80]; /* 180 cols x 80 rows */ + unsigned char *b, *bmax; + + b = buf + 1 + 2 * SLtt_Screen_Cols * top_row; + bmax = buf + 1 + 2 * SLtt_Screen_Cols * bot_row; + ScreenRetrieve (buf); + while (b < bmax) + { + *b ^= 0xFF; + b += 2; + } + ScreenUpdate (buf); +} + +void SLtt_beep (void) +{ + int audible; /* audible bell */ + int special = 0; /* first row to invert */ + int visual = 0; /* final row to invert */ + + if (!SLtt_Ignore_Beep) return; + + audible = (SLtt_Ignore_Beep & 1); + if ( (SLtt_Ignore_Beep & 4) ) + { + special = SLtt_Screen_Rows - 1; + visual = special--; /* only invert bottom status line */ + } + else if ( (SLtt_Ignore_Beep & 2) ) + { + visual = SLtt_Screen_Rows; + } + + if (visual) watcom_video_invert_region (special, visual); + if (audible) sound (1500); delay (100); if (audible) nosound (); + if (visual) watcom_video_invert_region (special, visual); +} + +void SLtt_del_eol (void) +{ + unsigned short *p, *pmax; + unsigned short w; + int n; + + n = SLtt_Screen_Cols - Cursor_Col; + p = MK_SCREEN_POINTER (Cursor_Row, Cursor_Col); + pmax = p + n; + + if (Current_Color != JNO_COLOR) SLtt_normal_video (); + + w = MK_SPACE_CHAR (); + while (p < pmax) *p++ = w; +} + +static void +write_attributes (SLsmg_Char_Type *src, unsigned int count) +{ + register unsigned short pair; + register unsigned short *pos = MK_SCREEN_POINTER (Cursor_Row, 0); + + /* write into a character/attribute pair */ + while (count--) + { + pair = SLSMG_CHAR_TO_USHORT(*src);/* character/color pair */ + src++; + SLtt_reverse_video (pair >> 8); /* color change */ + *(pos++) = ((unsigned short) Attribute_Byte << 8) | (pair & 0xff); + } +} + +void SLtt_cls (void) +{ + SLtt_normal_video (); + SLtt_reset_scroll_region (); + SLtt_goto_rc (0, 0); + SLtt_delete_nlines (SLtt_Screen_Rows); +} + +void SLtt_putchar (char ch) +{ + unsigned short p, *pp; + + if (Current_Color) SLtt_normal_video (); + watcom_video_getxy (); + switch (ch) + { + case 7: /* ^G - break */ + SLtt_beep (); break; + case 8: /* ^H - backspace */ + goto_rc_abs (Cursor_Row, Cursor_Col - 1); break; + case 13: /* ^M - carriage return */ + goto_rc_abs (Cursor_Row, 0); break; + default: /* write character to screen */ + p = (Attribute_Byte << 8) | (unsigned char) ch; + pp = MK_SCREEN_POINTER (Cursor_Row, Cursor_Col); + *pp = p; + goto_rc_abs (Cursor_Row, Cursor_Col + 1); + } +} + +void SLtt_get_screen_size (void) +{ + struct videoconfig vc; + _getvideoconfig(&vc); + + SLtt_Screen_Rows = vc.numtextrows; + SLtt_Screen_Cols = vc.numtextcols; +} + +void SLtt_get_terminfo (void) +{ + SLtt_get_screen_size (); +} + +int SLtt_init_video (void) +{ +#ifdef HAS_SAVE_SCREEN + save_screen (); +#endif + + Cursor_Row = Cursor_Col = 0; + Video_Base = (unsigned char *) ScreenPrimary; + if (!Attribute_Byte) Attribute_Byte = 0x17; + IsColor = 1; /* is it really? */ + + if (IsColor) + { + union REGS r; + r.x.eax = 0x1003; r.x.ebx = 0; + int86 (0x10, &r, &r); + Blink_Killed = 1; + } + + SLtt_Use_Ansi_Colors = IsColor; + SLtt_get_screen_size (); + SLtt_reset_scroll_region (); + fixup_colors (); + + return 0; +} + +#endif /* WATCOM_VIDEO */ + +/*}}}*/ + +/* -------------------------------------------------------------------------*\ + * The rest of the functions are, for the most part, independent of a specific + * video system. +\* ------------------------------------------------------------------------ */ + +/*----------------------------------------------------------------------*\ + * Function: void SLtt_set_scroll_region (int r1, int r2); + * + * define a scroll region of top_row to bottom_row +\*----------------------------------------------------------------------*/ +void SLtt_set_scroll_region (int top_row, int bottom_row) +{ + Scroll_r1 = top_row; + Scroll_r2 = bottom_row; +} + +/*----------------------------------------------------------------------*\ + * Function: void SLtt_reset_scroll_region (void); + * + * reset the scrol region to be the entire screen, + * ie, SLtt_set_scroll_region (0, SLtt_Screen_Rows); +\*----------------------------------------------------------------------*/ +void SLtt_reset_scroll_region (void) +{ + Scroll_r1 = 0; + Scroll_r2 = SLtt_Screen_Rows - 1; +} + +/*----------------------------------------------------------------------*\ + * Function: int SLtt_flush_output (void); +\*----------------------------------------------------------------------*/ +int SLtt_flush_output (void) +{ +#if defined(WIN32_VIDEO) + return 0; +#else + /* FIXME: Priority=medium + * This should not go to stdout. */ + fflush (stdout); + return 0; +#endif +} + +int SLtt_set_cursor_visibility (int show) +{ +#if defined(WIN32_VIDEO) + CONSOLE_CURSOR_INFO c; + + if (0 == GetConsoleCursorInfo (hStdout, &c)) + return -1; + c.bVisible = (show ? TRUE: FALSE); + if (0 == SetConsoleCursorInfo (hStdout, &c)) + return -1; + return 0; +#else + (void) show; + return -1; +#endif +} + +/*----------------------------------------------------------------------*\ + * Function: void SLtt_reverse_video (int color); + * + * set Attribute_Byte corresponding to COLOR. + * Use Current_Color to remember the color which was set. + * convert from the COLOR number to the attribute value. +\*----------------------------------------------------------------------*/ +void SLtt_reverse_video (int color) +{ + if ((color >= JMAX_COLORS) || (color < 0)) + return; + + Attribute_Byte = Color_Map [color]; + Current_Color = color; +} + +/*----------------------------------------------------------------------*\ + * Function: void SLtt_normal_video (void); + * + * reset the attributes for normal video +\*----------------------------------------------------------------------*/ +void SLtt_normal_video (void) +{ + SLtt_reverse_video (JNORMAL_COLOR); +} + +/*----------------------------------------------------------------------*\ + * Function: void SLtt_smart_puts (SLsmg_Char_Type *new_string, + * SLsmg_Char_Type *old_string, + * int len, int row); + * + * puts NEW_STRING, which has length LEN, at row ROW. NEW_STRING contains + * characters/colors packed in the form value = ((color << 8) | (ch)); + * + * the puts tries to avoid overwriting the same characters/colors + * + * OLD_STRING is not used, maintained for compatibility with other systems +\*----------------------------------------------------------------------*/ +void SLtt_smart_puts (SLsmg_Char_Type *new_string, + SLsmg_Char_Type *old_string, + int len, int row) +{ + (void) old_string; + Cursor_Row = row; + Cursor_Col = 0; + write_attributes (new_string, len); +} + +/*----------------------------------------------------------------------*\ + * Function: int SLtt_reset_video (void); +\*----------------------------------------------------------------------*/ +#ifndef WIN32_VIDEO +int SLtt_reset_video (void) +{ + SLtt_reset_scroll_region (); + SLtt_goto_rc (SLtt_Screen_Rows - 1, 0); +#ifdef HAS_SAVE_SCREEN + restore_screen (); +#endif + Attribute_Byte = 0x07; + Current_Color = JNO_COLOR; + SLtt_del_eol (); + return 0; +} +#endif + +/*----------------------------------------------------------------------*\ + * Function: void SLtt_set_color (int obj, char *what, char *fg, char *bg); + * + * set foreground and background colors of OBJ to the attributes which + * correspond to the names FG and BG, respectively. + * + * WHAT is the name corresponding to the object OBJ, but is not used in + * this routine. +\*----------------------------------------------------------------------*/ +void SLtt_set_color (int obj, char *what, char *fg, char *bg) +{ + int i, b = 0, f = 7; + + (void) what; + + if ((obj < 0) || (obj >= JMAX_COLORS)) + return; + + for (i = 0; i < JMAX_COLOR_NAMES; i++ ) + { + if (!strcmp (fg, Color_Names [i])) + { + f = i; + break; + } + } + + for (i = 0; i < JMAX_COLOR_NAMES; i++) + { + if (!strcmp (bg, Color_Names [i])) + { + if (Blink_Killed) b = i; else b = i & 0x7; + break; + } + } + if (f == b) return; + + Color_Map [obj] = (b << 4) | f; + + /* if we're setting the normal color, and the attribute byte hasn't + been set yet, set it to the new color */ + if ((obj == 0) && (Attribute_Byte == 0)) + SLtt_reverse_video (0); + + if (_SLtt_color_changed_hook != NULL) + (*_SLtt_color_changed_hook)(); +} + +static void fixup_colors (void) +{ + unsigned int i; + + if (Blink_Killed) + return; + + for (i = 0; i < JMAX_COLORS; i++) + Color_Map[i] &= 0x7F; + + SLtt_normal_video (); +} + + +/* FIXME!!! Add mono support. + * The following functions have not been fully implemented. + */ +void SLtt_set_mono (int obj_unused, char *unused, SLtt_Char_Type c_unused) +{ + (void) obj_unused; + (void) unused; + (void) c_unused; +} + +#if 0 +void SLtt_add_color_attribute (int obj, SLtt_Char_Type attr) +{ + (void) obj; + (void) attr; +} +#endif diff --git a/libslang/src/slvmstty.c b/libslang/src/slvmstty.c new file mode 100644 index 0000000..e22d1ad --- /dev/null +++ b/libslang/src/slvmstty.c @@ -0,0 +1,382 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef __DECC +#include +#include +#endif + +#include "slang.h" +#include "_slang.h" + +/* If this function returns -1, ^Y will be added to input buffer. */ +int (*SLtty_VMS_Ctrl_Y_Hook) (void); + +typedef struct { /* I/O status block */ + short i_cond; /* Condition value */ + short i_xfer; /* Transfer count */ + long i_info; /* Device information */ +} Iosb_Type; + +typedef struct { /* Terminal characteristics */ + char t_class; /* Terminal class */ + char t_type; /* Terminal type */ + short t_width; /* Terminal width in characters */ + long t_mandl; /* Terminal's mode and length */ + long t_extend; /* Extended terminal characteristics */ +} TermChar_Type; + +static TermChar_Type Old_Term_Char, New_Term_Char; + +/* This serves to identify the channel we are reading input from. */ +static short This_Term; + +typedef struct +{ + short buflen; + short item_code; + int *buf_addr; + int *len_addr; +} item_list_3; + +static int TTY_Inited; + +/* + * Exit Handler Control Block + */ +static struct argument_block + { + int forward_link; + int (*exit_routine)(); + int arg_count; + int *status_address; + int exit_status; + } +exit_block = + { + 0, + NULL, + 1, + &exit_block.exit_status, + 0 + }; + +static void vms_cancel_exithandler() +{ + sys$canexh(exit_block); +} + +static int vms_exit_handler () +{ + if (TTY_Inited == 0) return 0; + SLang_reset_tty (); + return 0; +} + +static int vms_input_buffer; + +static struct vms_ast_iosb +{ + short status; + short offset; + short termlen; + short term; +} vms_ast_iosb; + +static void vms_que_key_ast(); +static int Ast_Fired_Event_Flag; +static int Timer_Event_Flag; +static int Event_Flag_Mask; +static int Ast_Stop_Input; +static int Waiting_For_Ast; + +static int getkey_ast(int not_used) +{ + unsigned int c = 1000; + + if (vms_ast_iosb.offset) + { + c = (unsigned int) vms_input_buffer; + } + + if (c <= 255) + { + if (c == SLang_Abort_Char) + { + if (SLang_Ignore_User_Abort == 0) SLang_Error = SL_USER_BREAK; + SLKeyBoard_Quit = 1; + } + + if ((c != 0x19) /* ^Y */ + || (SLtty_VMS_Ctrl_Y_Hook == NULL) + || (-1 == (*SLtty_VMS_Ctrl_Y_Hook) ())) + { + if (SLang_Input_Buffer_Len < SL_MAX_INPUT_BUFFER_LEN - 3) + SLang_Input_Buffer[SLang_Input_Buffer_Len++] = c; + } + } + + if (Waiting_For_Ast) sys$setef (Ast_Fired_Event_Flag); + Waiting_For_Ast = 0; + vms_que_key_ast(); + return (1); +} + +static void vms_que_key_ast() +{ + static int trmmsk [2] = { 0, 0 }; + int status; + + if (Ast_Stop_Input) return; + status = sys$qio (0, This_Term, + IO$_READVBLK | IO$M_NOECHO | IO$_TTYREADALL, + &vms_ast_iosb, getkey_ast, 1, + &vms_input_buffer, 1, 0, trmmsk, 0, 0); +} + +static char TTY_Name[8]; +static int This_Process_Pid; + +/* FIXME: priority=medium + * The keypad state may have been tampered with by the application. So, I + * need to get the keypad status at initialization time and then reset it + * in the call to SLang_reset_tty. Unfortunately, this will most likely + * involve interaction with the sldisply interface. + */ +int SLang_init_tty (int a, int flow, int out) +{ + Iosb_Type iostatus; + int tmp, name_len, status, lastppid, ppid; + item_list_3 itmlst[3]; + $DESCRIPTOR ( term, TTY_Name); + + itmlst[0].buflen = sizeof(int); + itmlst[0].item_code = JPI$_PID; + itmlst[0].buf_addr = &This_Process_Pid; + itmlst[0].len_addr = &tmp; + + itmlst[1].buflen = 7; + itmlst[1].item_code = JPI$_TERMINAL; + itmlst[1].buf_addr = (int *) TTY_Name; + itmlst[1].len_addr = &name_len; + + itmlst[2].buflen = 0; + itmlst[2].item_code = 0; + itmlst[2].buf_addr = 0; + itmlst[2].len_addr = 0; + + if (a == -1) a = 3; /* ^C */ + SLang_Abort_Char = a; + TTY_Inited = 1; + ppid = 0, lastppid = -1; + + /* Here I get this process pid then I get the master process pid + and use the controlling terminal of that process. */ + while (1) + { + status = sys$getjpiw(0, /* event flag */ + &ppid, /* pid address */ + 0, /* proc name address */ + itmlst, + 0, 0, 0); + + if (status != SS$_NORMAL) + { + fprintf(stderr, "PID: %X, status: %X\n", This_Process_Pid, status); + exit(1); + } + + if (lastppid == ppid) break; + lastppid = ppid; + + itmlst[0].item_code = JPI$_MASTER_PID; + itmlst[0].buf_addr = &ppid; + } + + term.dsc$w_length = name_len; + status = sys$assign ( &term, &This_Term, 0, 0 ); + if (status != SS$_NORMAL) + { + fprintf(stderr,"Unable to assign input channel\n"); + fprintf(stderr,"PID: %X, DEV %s, status: %d\n", This_Process_Pid, TTY_Name, status); + exit(0); + } + + if (NULL == exit_block.exit_routine) + { + exit_block.exit_routine = (int (*)()) vms_exit_handler; + sys$dclexh(&exit_block); + } + + /* allocate an event flag and clear it--- used by ast routines. Since + * I am only using a few local event flags, there is really no need to + * worry about freeing these. + * + * The event flags are used to avoid timing problems with the getkey AST + * as well as for a form of time out. + */ + if (!Ast_Fired_Event_Flag) lib$get_ef (&Ast_Fired_Event_Flag); + sys$clref (Ast_Fired_Event_Flag); + + if (!Timer_Event_Flag) lib$get_ef (&Timer_Event_Flag); + sys$clref (Timer_Event_Flag); + + /* The working assumption here is that the event flags are in the same + * cluster. They need not be but it is very likely that they are. + */ + Event_Flag_Mask = ((unsigned) 1 << (Ast_Fired_Event_Flag % 32)); + Event_Flag_Mask |= ((unsigned) 1 << (Timer_Event_Flag % 32)); + + Waiting_For_Ast = 0; + Ast_Stop_Input = 0; + + /* Get the startup terminal characteristics */ + status = sys$qiow(0, /* Wait on event flag zero */ + This_Term, /* Channel to input terminal */ + IO$_SENSEMODE, /* Get current characteristic */ + &iostatus, /* Status after operation */ + 0, 0, /* No AST service */ + &Old_Term_Char, /* Terminal characteristics buf */ + sizeof(Old_Term_Char),/* Size of the buffer */ + 0, 0, 0, 0); + + New_Term_Char = Old_Term_Char; + New_Term_Char.t_mandl |= TT$M_EIGHTBIT | TT$M_NOECHO; + New_Term_Char.t_extend |= TT2$M_PASTHRU | TT2$M_XON; + + status = sys$qiow(0, /* Wait on event flag zero */ + This_Term, /* Channel to input terminal */ + IO$_SETMODE, /* Set current characteristic */ + &iostatus, /* Status after operation */ + 0, 0, /* No AST service */ + &New_Term_Char, /* Terminal characteristics buf */ + sizeof(New_Term_Char),/* Size of the buffer */ + 0, 0, 0, 0); + + vms_que_key_ast(); /* set up the key ast */ + return 0; +} + +static void cancel_ast (void) +{ + if (TTY_Inited == 0) return; + + /* stop the keyboard ast */ + sys$setast (0); /* disable AST delivery */ + sys$clref (Ast_Fired_Event_Flag); + Waiting_For_Ast = 1; + Ast_Stop_Input = 1; + + /* cancel all i/o on this channel. This canels pending, as well as those + * already in progress and queued. In particular, according to the + * manuals, cancelling I/O on the channel will cause the getkey AST + * to fire even though the sys$qio call was aborted. This is crucial + * because below we wait for the AST to set the event flag. + */ + sys$cancel (This_Term); + sys$setast (1); /* enable ASTs again */ + sys$waitfr (Ast_Fired_Event_Flag); /* sleep until it fires */ + Waiting_For_Ast = 0; +} + +void SLang_reset_tty (void) +{ + Iosb_Type iostatus; + + if (!TTY_Inited) return; + + cancel_ast (); + TTY_Inited = 0; + + /* reset the terminal characteristics */ + + sys$qiow(0, /* event flag 0 */ + This_Term, /* Channel to input terminal */ + IO$_SETMODE, /* Set current characteristic */ + &iostatus, /* Status after operation */ + 0, 0, /* No AST service */ + &Old_Term_Char, /* Terminal characteristics buf */ + sizeof(Old_Term_Char), /* Size of the buffer */ + 0, 0, 0, 0); /* unused */ + +} + +unsigned int _SLsys_getkey() +{ + unsigned int c; + + if (SLKeyBoard_Quit) return((unsigned int) SLang_Abort_Char); + + /* On VMS, the keyboard ast routine should be stuffing the buffer, so + do nothing except sleep */ + + /* clear the flag which ast will set */ + Waiting_For_Ast = 0; + + if (SLang_Input_Buffer_Len) return(SLang_getkey()); + while (!_SLsys_input_pending(450)); + c = SLang_getkey(); + return(c); +} + +/* waits *secs tenth of seconds for input */ +int _SLsys_input_pending(int tsecs) +{ + unsigned long daytim[2]; + + if (SLang_Input_Buffer_Len) return(SLang_Input_Buffer_Len); + + if (tsecs < 0) + tsecs = -tsecs/100; /* tsecs is ms, convert to 1/10 sec */ + + if (tsecs) + { + /* takes a quad word time. If negative, use a relative time. */ + daytim[1] = 0xFFFFFFFF; + daytim[0] = -(tsecs * 1000 * 1000); + /* 1000 * 1000 is a tenth of a sec */ + + sys$clref (Ast_Fired_Event_Flag); + /* sys$clref (Timer_Event_Flag); sys$setimr call clears this */ + + /* set up a flag for the ast so it knows to set the event flag */ + Waiting_For_Ast = 1; + + sys$setimr(Timer_Event_Flag, daytim, 0, 1); + + /* this will return when ast does its job or timer expires. + * The first argument simply serves to identify the cluster for + * the event flag and that is all. The second argument serves + * to identify the event flags to wait for. + */ + sys$wflor (Ast_Fired_Event_Flag, Event_Flag_Mask); + + Waiting_For_Ast = 0; + + /* cancel the timer */ + sys$cantim(1, 3); /* 3 is user mode */ + } + return (SLang_Input_Buffer_Len); +} + +int SLang_set_abort_signal (void (*f)(int)) +{ + return 0; +} + diff --git a/libslang/src/slw32tty.c b/libslang/src/slw32tty.c new file mode 100644 index 0000000..3d758ce --- /dev/null +++ b/libslang/src/slw32tty.c @@ -0,0 +1,354 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include +#include + +#include "slang.h" +#include "_slang.h" + +#ifdef __cplusplus +# define _DOTS_ ... +#else +# define _DOTS_ void +#endif + +static int Process_Mouse_Events; + +/*----------------------------------------------------------------------*\ + * Function: static void set_ctrl_break (int state); + * + * set the control-break setting +\*----------------------------------------------------------------------*/ +static void set_ctrl_break (int state) +{ +} + +/*----------------------------------------------------------------------*\ + * Function: int SLang_init_tty (int abort_char, int no_flow_control, + * int opost); + * + * initialize the keyboard interface and attempt to set-up the interrupt 9 + * handler if ABORT_CHAR is non-zero. + * NO_FLOW_CONTROL and OPOST are only for compatiblity and are ignored. +\*----------------------------------------------------------------------*/ + +HANDLE _SLw32_Hstdin = INVALID_HANDLE_VALUE; + +int SLang_init_tty (int abort_char, int no_flow_control, int opost) +{ + (void) opost; + (void) no_flow_control; + + if (_SLw32_Hstdin != INVALID_HANDLE_VALUE) + return 0; + +#if 1 + /* stdin may have been redirected. So try this */ + _SLw32_Hstdin = CreateFile ("CONIN$", GENERIC_READ|GENERIC_WRITE, + FILE_SHARE_READ|FILE_SHARE_WRITE, NULL, + OPEN_EXISTING, 0, NULL); + if (_SLw32_Hstdin == INVALID_HANDLE_VALUE) + return -1; +#else + if (INVALID_HANDLE_VALUE == (_SLw32_Hstdin = GetStdHandle(STD_INPUT_HANDLE))) + return -1; +#endif + + if (FALSE == SetConsoleMode(_SLw32_Hstdin, ENABLE_WINDOW_INPUT|ENABLE_MOUSE_INPUT)) + { + _SLw32_Hstdin = INVALID_HANDLE_VALUE; + return -1; + } + + if (abort_char > 0) + SLang_Abort_Char = abort_char; + + return 0; +} +/* SLang_init_tty */ + +/*----------------------------------------------------------------------*\ + * Function: void SLang_reset_tty (void); + * + * reset the tty before exiting +\*----------------------------------------------------------------------*/ +void SLang_reset_tty (void) +{ + _SLw32_Hstdin = INVALID_HANDLE_VALUE; + set_ctrl_break (1); +} + +static int process_mouse_event (MOUSE_EVENT_RECORD *m) +{ + char buf [8]; + + if (Process_Mouse_Events == 0) + return -1; + + if (m->dwEventFlags) + return -1; /* double click or movement event */ + + /* A button was either pressed or released. Now make sure that + * the shift keys were not also pressed. + */ + if (m->dwControlKeyState + & (LEFT_ALT_PRESSED|RIGHT_ALT_PRESSED + |LEFT_CTRL_PRESSED|RIGHT_CTRL_PRESSED + |SHIFT_PRESSED)) + return -1; + + /* We have a simple press or release. Encode it as an escape sequence + * and buffer the result. The encoding is: + * 'ESC [ M b x y' + * where b represents the button state, and x,y represent the coordinates. + * The ESC is handled by the calling routine. + */ + if (m->dwButtonState & 1) buf[3] = ' '; + else if (m->dwButtonState & 2) buf[3] = ' ' + 2; + else if (m->dwButtonState & 4) buf[3] = ' ' + 1; + else return -1; + + buf[0] = 27; + buf[1] = '['; + buf[2] = 'M'; + + + buf[4] = 1 + ' ' + m->dwMousePosition.X; + buf[5] = 1 + ' ' + m->dwMousePosition.Y; + + return SLang_buffer_keystring ((unsigned char *)buf, 6); +} + +static int process_key_event (KEY_EVENT_RECORD *key) +{ + unsigned int key_state = 0; + unsigned int scan; + char c1; + DWORD d = key->dwControlKeyState; + unsigned char buf[4]; + + if (!key->bKeyDown) return 0; + if (d & (LEFT_ALT_PRESSED | RIGHT_ALT_PRESSED)) + key_state |= _SLTT_KEY_ALT; + if (d & (LEFT_CTRL_PRESSED | RIGHT_CTRL_PRESSED)) + key_state |= _SLTT_KEY_CTRL; + if (d & SHIFT_PRESSED) + key_state |= _SLTT_KEY_SHIFT; + + scan = key->wVirtualScanCode; + + switch (scan) + { + case 0x00E: /* backspace */ + return SLang_buffer_keystring ((unsigned char *)"\x7F", 1); + + case 0x003: /* 2 key */ + if (key_state & _SLTT_KEY_ALT) + break; + /* Drop */ + case 0x039: /* space */ + if (key_state & _SLTT_KEY_CTRL) + return SLang_buffer_keystring ((unsigned char *)"\x00\x03", 2); + break; + + case 0x007: /* 6 key */ + if (_SLTT_KEY_CTRL == (key_state & (_SLTT_KEY_ALT|_SLTT_KEY_CTRL))) + return SLang_buffer_keystring ((unsigned char *)"\x1E", 1); /* Ctrl-^ */ + break; + + case 0x00C: /* -/_ key */ + if (_SLTT_KEY_CTRL == (key_state & (_SLTT_KEY_ALT|_SLTT_KEY_CTRL))) + return SLang_buffer_keystring ((unsigned char *)"\x1F", 1); + break; + + case 0x00F: /* TAB */ + if (_SLTT_KEY_SHIFT == key_state) + return SLang_buffer_keystring ((unsigned char *)"\x00\x09", 2); + break; + + case 0xE02F: /* KEYPAD SLASH */ + case 0x037: /* KEYPAD STAR */ + case 0x04A: /* KEYPAD MINUS */ + case 0x04E: /* KEYPAD PLUS */ + if (d & NUMLOCK_ON) + break; + case 0x047: /* KEYPAD HOME */ + case 0x048: /* KEYPAD UP */ + case 0x049: /* KEYPAD PGUP */ + case 0x04B: /* KEYPAD LEFT */ + case 0x04C: /* KEYPAD 5 */ + case 0x04D: /* KEYPAD RIGHT */ + case 0x04F: /* KEYPAD END */ + case 0x050: /* KEYPAD DOWN */ + case 0x051: /* KEYPAD PGDN */ + case 0x052: /* KEYPAD INSERT */ + case 0x053: /* KEYPAD DEL */ + if (d & ENHANCED_KEY) + scan |= 0xE000; + else + { + if (d & NUMLOCK_ON) + break; + } + (void) _SLpc_convert_scancode (scan, key_state, 0); + return 0; + + case 0x3b: /* F1 */ + case 0x3c: + case 0x3d: + case 0x3e: + case 0x3f: + case 0x40: + case 0x41: + case 0x42: + case 0x43: + case 0x44: + case 0x57: + case 0x58: /* F12 */ + (void) _SLpc_convert_scancode (scan, key_state, 0); + } + + c1 = key->uChar.AsciiChar; + if (c1 != 0) + { + if (_SLTT_KEY_ALT == (key_state & (_SLTT_KEY_ALT|_SLTT_KEY_CTRL))) + { + buf[0] = 27; + buf[1] = c1; + return SLang_buffer_keystring (buf, 2); + } + if (c1 == SLang_Abort_Char) + { + if (SLang_Ignore_User_Abort == 0) SLang_Error = USER_BREAK; + SLKeyBoard_Quit = 1; + } + buf[0] = c1; + return SLang_buffer_keystring (buf, 1); + } + return 0; +} + + +static void process_console_records(void) +{ + INPUT_RECORD record; + DWORD bytesRead; + DWORD n = 0; + + if (FALSE == GetNumberOfConsoleInputEvents(_SLw32_Hstdin, &n)) + return; + + while (n > 0) + { + ReadConsoleInput(_SLw32_Hstdin, &record, 1, &bytesRead); + switch (record.EventType) + { + case KEY_EVENT: + (void) process_key_event(&record.Event.KeyEvent); + break; + + case MOUSE_EVENT: + process_mouse_event(&record.Event.MouseEvent); + break; + + case WINDOW_BUFFER_SIZE_EVENT: + /* process_resize_records(&record.Event.WindowBufferSizeEvent); */ + break; + } + n--; + } +} + +/*----------------------------------------------------------------------*\ + * Function: int _SLsys_input_pending (int tsecs); + * + * sleep for *tsecs tenths of a sec waiting for input +\*----------------------------------------------------------------------*/ +int _SLsys_input_pending (int tsecs) +{ + long ms; + + if (_SLw32_Hstdin == INVALID_HANDLE_VALUE) + return -1; + + if (tsecs < 0) ms = -tsecs; /* specifies 1/1000 */ + else ms = tsecs * 100L; /* convert 1/10 to 1/1000 secs */ + + process_console_records (); + while ((ms > 0) + && (SLang_Input_Buffer_Len == 0)) + { + long t; + + t = GetTickCount (); + + (void) WaitForSingleObject (_SLw32_Hstdin, ms); + process_console_records (); + ms -= GetTickCount () - t; + } + + return SLang_Input_Buffer_Len; +} + +/*----------------------------------------------------------------------*\ + * Function: unsigned int _SLsys_getkey (void); + * + * wait for and get the next available keystroke. + * Also re-maps some useful keystrokes. + * + * Backspace (^H) => Del (127) + * Ctrl-Space => ^@ (^@^3 - a pc NUL char) + * extended keys are prefixed by a null character +\*----------------------------------------------------------------------*/ +unsigned int _SLsys_getkey (void) +{ + /* Check the input buffer because _SLsys_input_pending may have been + * called prior to this to stuff the input buffer. + */ + if (SLang_Input_Buffer_Len) + return SLang_getkey (); + + if (_SLw32_Hstdin == INVALID_HANDLE_VALUE) + return SLANG_GETKEY_ERROR; + + while (1) + { + int status; + + if (SLKeyBoard_Quit) + return SLang_Abort_Char; + + status = _SLsys_input_pending (600); + if (status == -1) + return SLANG_GETKEY_ERROR; + + if (status > 0) + return SLang_getkey (); + } +} + +/*----------------------------------------------------------------------*\ + * Function: int SLang_set_abort_signal (void (*handler)(int)); +\*----------------------------------------------------------------------*/ +int SLang_set_abort_signal (void (*handler)(int)) +{ + if (_SLw32_Hstdin == INVALID_HANDLE_VALUE) + return -1; + + return 0; +} + +int SLtt_set_mouse_mode (int mode, int force) +{ + (void) force; + + Process_Mouse_Events = mode; + return 0; +} diff --git a/libslang/src/slxstrng.c b/libslang/src/slxstrng.c new file mode 100644 index 0000000..816eb60 --- /dev/null +++ b/libslang/src/slxstrng.c @@ -0,0 +1,43 @@ +/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are simple and inefficient. They were designed to work on + * SunOS when using Electric Fence. + */ + +#include "slang.h" +#include "_slang.h" +char *SLstrcpy(register char *aa, register char *b) +{ + char *a = aa; + while ((*a++ = *b++) != 0); + return aa; +} + +int SLstrcmp(register char *a, register char *b) +{ + while (*a && (*a == *b)) + { + a++; + b++; + } + if (*a) return((unsigned char) *a - (unsigned char) *b); + else if (*b) return ((unsigned char) *a - (unsigned char) *b); + else return 0; +} + +char *SLstrncpy(char *a, register char *b,register int n) +{ + register char *aa = a; + while ((n > 0) && *b) + { + *aa++ = *b++; + n--; + } + while (n-- > 0) *aa++ = 0; + return (a); +} diff --git a/libslang/src/test/Makefile b/libslang/src/test/Makefile new file mode 100644 index 0000000..85f64dd --- /dev/null +++ b/libslang/src/test/Makefile @@ -0,0 +1,22 @@ +TEST_SCRIPTS = syntax sscanf loops arith array strops bstring \ + pack stdio assoc selfload struct nspace ospath ifeval anytype arrmult \ + nspace2 prep +TEST_PGM = sltest +RUN_TEST_PGM = ./$(TEST_PGM) +SLANGINC = .. +SLANGLIB = ../$(ARCH)objs + +run_tests: $(TEST_PGM) + @echo "" + @echo "Running tests:" + @echo "" + @for X in $(TEST_SCRIPTS); \ + do \ + $(RUN_TEST_PGM) $$X.sl; \ + done + touch sltest.c + +sltest: sltest.c $(SLANGLIB)/libslang.a + $(CC) $(CFLAGS) $(LDFLAGS) sltest.c -o sltest -I$(SLANGINC) -L$(SLANGLIB) -lslang $(TCAPLIB) -lm +clean: + -/bin/rm -f *~ sltest *.o *.log diff --git a/libslang/src/test/README b/libslang/src/test/README new file mode 100644 index 0000000..57c1cad --- /dev/null +++ b/libslang/src/test/README @@ -0,0 +1,2 @@ +These are a set of tests designed to test the interpreter. The tests +should be run from this directory using, e.g., the calc program or slsh. diff --git a/libslang/src/test/anytype.sl b/libslang/src/test/anytype.sl new file mode 100644 index 0000000..80af7dc --- /dev/null +++ b/libslang/src/test/anytype.sl @@ -0,0 +1,63 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing Any_Type ..."); + +% Tests go here.... + +variable A = Any_Type[10]; +if ((_typeof(A)) != Any_Type) failed ("_typeof"); + +static define eqs (a, b) +{ + variable len; + len = length (a); + if (len != length (b)) + return 0; + + len == length (where (a == b)); +} + +static define neqs (a, b) +{ + not (eqs (a, b)); +} + +static define check (a, i, value) +{ + a[i] = value; + if (typeof (a[i]) != Any_Type) + failed ("check typeof"); + % Because value can be an array, use neqs + if (neqs(@a[i], value)) + failed ("a[i] = value for %S, computed: %S", value, @a[i]); +} + +check (A, 0, "hello"); +check (A, 0, 14); +#ifexists Double_Type +check (A, 0, 2.3); +#endif +check (A, 0, &A); +check (A, 0, [1:10]); +#ifexists Complex_Type +check (A, 0, 1+2i); +#endif +check (A, 0, String_Type); + +A = ["a", "ab", "abc"]; +static variable B = typecast (A, Any_Type); +if ((typeof (B) != Array_Type) + or (_typeof(B) != Any_Type)) + failed ("typecast to Any_Type"); +_for (0, length(B)-1, 1) +{ + $1 = (); + if (A[$1] != @B[$1]) + failed ("@typecast(A,Any_Type)"); +} + + +print ("Ok\n"); + +exit (0); + diff --git a/libslang/src/test/arith.sl b/libslang/src/test/arith.sl new file mode 100644 index 0000000..d62fb3a --- /dev/null +++ b/libslang/src/test/arith.sl @@ -0,0 +1,201 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing Arithmetic ..."); + +static variable G = 11; +define check_global_local () +{ + variable x = 1; + if (G + 1 != 12) + failed ("global + int"); + if (1 + G != 12) + failed ("int + global"); + if (x + 11 != 12) + failed ("local + int"); + if (11 + x != 12) + failed ("int + local"); + if (x + x != 2) + failed ("local + local"); + if (x + G != 12) + failed ("local + global"); + if (G + x != 12) + failed ("global + local"); + if (1 + 11 != 12) + failed ("int + int"); +} +check_global_local (); + +define check_typeof (expr, type) +{ + if (typeof (expr) != type) + failed ("typeof " + string (type) + " found " + string (typeof(expr))); +} + +define check_bool (i) +{ + check_typeof (i == i, Char_Type); +} + +define check_sum_result (i, j, k) +{ + if (k != i + j) + failed (sprintf("%S + %S != %S", typeof (i), typeof(j), typeof(k))); +} + +check_typeof('a', UChar_Type); +check_typeof(1h, Short_Type); +check_typeof(1hu, UShort_Type); +check_typeof(0x20hu, UShort_Type); +check_typeof(1, Integer_Type); +check_typeof(0x20, Integer_Type); +check_typeof(1u, UInteger_Type); +check_typeof(1LU, ULong_Type); +#ifexists Double_Type +check_typeof(1f, Float_Type); +check_typeof(1e10f, Float_Type); +check_typeof(.1e10f, Float_Type); +check_typeof(.1e10, Double_Type); +#endif +check_typeof(~'a', UChar_Type); +check_typeof(~1h, Short_Type); +check_typeof(~1hu, UShort_Type); +check_typeof(~0x20hu, UShort_Type); +check_typeof(~1, Integer_Type); +check_typeof(~0x20, Integer_Type); +check_typeof(~1u, UInteger_Type); +check_typeof(~1LU, ULong_Type); + +check_typeof ('a' + 'b', Integer_Type); +check_typeof (1h + 'b', Integer_Type); + +if (Integer_Type == Short_Type) check_typeof (1hu + 'b', UInteger_Type); +else check_typeof (1hu + 'b', Integer_Type); + +check_typeof (1u + 1, UInteger_Type); + +if (Integer_Type == Long_Type) check_typeof (1u + 1L, ULong_Type); +else check_typeof (1u + 1L, Long_Type); + +check_typeof (1u + 1UL, ULong_Type); +#ifexists Double_Type +check_typeof (1u + 1.0f, Float_Type); +check_typeof (1u + 1.0, Double_Type); +#endif +#ifexists Complex_Type +check_typeof ('c' * 1i, Complex_Type); +check_typeof (1h * 1i, Complex_Type); +check_typeof (1.0 * 1i, Complex_Type); +check_typeof (1i * 1i, Complex_Type); +#endif + +check_bool ('a'); +check_bool (1h); +check_bool (1hu); +check_bool (1); +check_bool (1u); +check_bool (1L); +check_bool (1LU); +#ifexists Double_Type +check_bool (1f); +check_bool (1.0); +#endif +#ifexists Complex_Type +check_bool (1.0i); +#endif + +#ifexists Complex_Type +check_typeof (Real(1), Double_Type); +check_typeof (Real('a'), Double_Type); +check_typeof (Real(1L), Double_Type); +check_typeof (Real(1f), Float_Type); +check_typeof (Real(1.0), Double_Type); +#endif + +check_sum_result (1, 1, 2); +check_sum_result (1, 0x31, 50); +check_sum_result (1, '1', 50); +check_sum_result (1L, '1', 50L); +check_sum_result (1L, 1h, 2L); +check_sum_result (1, 1h, 2); +check_sum_result (1h, '1', 50); +check_sum_result (1u, 3, 4); +check_sum_result (1UL, '\x3', 4UL); + +#ifexists Complex_Type +static define check_complex_fun (fun, x) +{ + variable z = x + 0i; + variable diff = abs (@fun(z) - @fun(x)); + if (diff > 1e-13) + failed ("%S %S", fun, z); +} + +check_complex_fun (&sin, 1); +check_complex_fun (&cos, 1); +check_complex_fun (&tan, 1); +check_complex_fun (&acos, 0.5); +check_complex_fun (&asin, 0.5); +check_complex_fun (&atan, 0.5); +check_complex_fun (&cosh, 1); +check_complex_fun (&sinh, 1); +check_complex_fun (&tanh, 1); +check_complex_fun (&asinh, 0.5); +check_complex_fun (&acosh, 2.0); +check_complex_fun (&atanh, 0.5); +check_complex_fun (&sqrt, 0.5); +check_complex_fun (&exp, 0.5); +#endif + +define test_eqs (a, b, r) +{ + if (r != __eqs (a,b)) + failed ("__eqs (%S,%S)", a, b); +} + +test_eqs (1,1,1); +test_eqs (1,'\001', 0); +#ifexists Double_Type +test_eqs (1, 1.0, 0); +#endif +test_eqs ("xyz", "xyz", 1); +test_eqs ([1:3],[1:3],0); +test_eqs (stdout, stderr, 0); +test_eqs (stderr, 1, 0); +#ifexists Complex_Type +test_eqs (1+2i, 1+2i, 1); +test_eqs (1.0+0.0i, 1.0, 0); +#endif + +#ifexists Double_Type +define another_test () +{ + variable x = 1.0; + variable y; + + if (18 != 1.0+1+x + + 1.0+x+1 + + x+1.0+1 + + x+1+1.0 + + 1+1.0+x + + 1+x+1.0) + failed ("sum combinations"); +} + +another_test(); +#endif + +define test_typecast () +{ + variable args = __pop_args (_NARGS-1); + variable y = (); + + if (y != typecast (__push_args (args))) + failed ("typecast"); +} + +#ifexists Double_Type +test_typecast (0.0f, 0, Float_Type); +#endif + +print ("Ok\n"); +exit (0); diff --git a/libslang/src/test/array.sl b/libslang/src/test/array.sl new file mode 100644 index 0000000..2bd68c6 --- /dev/null +++ b/libslang/src/test/array.sl @@ -0,0 +1,704 @@ + +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing array functions ..."); + +static variable A = [0:23]; + +static variable B = transpose(A); +static variable dims; + +(dims,,) = array_info (B); +if ((dims[0] != 1) + or (dims[1] != 24)) + failed ("transpose ([0:23])"); + + +reshape (A, [2,3,4]); + +static define eqs (a, b) +{ + variable len; + len = length (a); + if (len != length (b)) + return 0; + + len == length (where (a == b)); +} + +static define neqs (a, b) +{ + not (eqs (a, b)); +} + + +if ((A[0,0,0] != 0) + or (A[0,0,1] != 1) + or (neqs (A[0,0,[:]], [0:3])) + or (neqs (A[0,1,[:]], [4:7])) + or (neqs (A[0,2,[:]], [8:11])) + or (neqs (A[1,0,[:]], [12:15])) + or (neqs (A[1,1,[:]], [16:19])) + or (neqs (A[1,2,[:]], [20:23]))) failed ("reshape"); + +B = transpose (A); + +if ((B[0,0,0] != 0) + or (B[1,0,0] != 1) + or (neqs (B[[:],0,0], [0:3])) + or (neqs (B[[:],1,0], [4:7])) + or (neqs (B[[:],2,0], [8:11])) + or (neqs (B[[:],0,1], [12:15])) + or (neqs (B[[:],1,1], [16:19])) + or (neqs (B[[:],2,1], [20:23]))) failed ("transpose int array"); + +% Test for memory leak +loop (100) B = transpose (B); +B = 0; + +% Try on a string array +variable S = String_Type[length (A)]; +foreach (A) +{ + variable i = (); + S[i] = string (i); +} + +variable T = @S; +reshape (S, [2,3,4]); + +if ((S[0,0,0] != T[0]) + or (S[0,0,1] != T[1]) + or (neqs (S[0,0,*], T[[0:3]])) + or (neqs (S[0,1,*], T[[4:7]])) + or (neqs (S[0,2,*], T[[8:11]])) + or (neqs (S[1,0,*], T[[12:15]])) + or (neqs (S[1,1,*], T[[16:19]])) + or (neqs (S[1,2,*], T[[20:23]]))) failed ("reshape string array"); + +S = transpose (S); + +if ((S[0,0,0] != T[0]) + or (S[1,0,0] != T[1]) + or (neqs (S[*,0,0], T[[0:3]])) + or (neqs (S[*,1,0], T[[4:7]])) + or (neqs (S[*,2,0], T[[8:11]])) + or (neqs (S[*,0,1], T[[12:15]])) + or (neqs (S[*,1,1], T[[16:19]])) + or (neqs (S[*,2,1], T[[20:23]]))) failed ("transpose string array"); + + +S = ["", "1", "12", "123", "1234", "12345"]; +S = array_map (Int_Type, &strlen, S); +if (neqs (S, [0:5])) failed ("array_map 1"); + +S = ["", "1", "12", "123", "1234", "12345"]; +variable SS = S + S; +if (neqs (SS, array_map (String_Type, &strcat, S, S))) failed ("array_map 2"); + +SS = S + "--end"; +if (neqs (SS, array_map (String_Type, &strcat, S, "--end"))) failed ("array_map 3"); + +#ifexists Double_Type +S = [1:20:0.1]; +if (neqs (sin(S), array_map (Double_Type, &sin, S))) failed ("array_map 3"); + +S = [1:20:0.1]; +variable Sin_S = Double_Type[length(S)]; +static define void_sin (x, i) +{ + Sin_S[i] = sin (x); +} +array_map (Void_Type, &void_sin, S, [0:length(S)-1]); +if (neqs (sin(S), Sin_S)) + failed ("array_map Void_Type"); +#endif + +% Check indexing with negative subscripts +S = [0:10]; + +if (S[-1] != 10) failed ("[-1]"); +if (length (S[[-1:3]])) failed ("[-1:3]"); +if (neqs(S[[-1:0:-1]], [10:0:-1])) failed ("[-1:0:-1]"); +if (neqs(S[[0:-1]], S)) failed ("[0:-1]"); +if (neqs(S[[3:-1]], [3:10])) failed ([3:-1]); +if (length (S[[0:-1:-1]])) failed ("[0:-1:-1]"); % first to last by -1 +if (neqs(S[[0:]], S)) failed ("[0:]"); +if (neqs(S[[:-1]], S)) failed ("[:-1]"); + +S = Int_Type[0]; +if (length (S) != 0) failed ("Int_Type[0]"); +if (neqs (S, S[[0:-1]])) failed ("Int_Type[0][[0:-1]]"); + + +S = bstring_to_array ("hello"); +if ((length (S) != 5) + or (typeof (S) != Array_Type)) failed ("bstring_to_array"); +if ("hello" != array_to_bstring (S)) failed ("array_to_bstring"); + +A = ['a':'z']; +foreach (A) +{ + $1 = (); + if (A[$1 - 'a'] != $1) + failed ("['a':'z']"); +} + +define check_result (result, answer, op) +{ + if (neqs (answer, result)) + failed ("Binary operation `%s' failed", op); +} + +check_result ([1,2] + [3,4], [4,6],"+"); +check_result (1 + [3,4], [4,5],"+"); +check_result ([3,4] + 1, [4,5],"+"); + +check_result ([1,2] - [3,4], [-2,-2],"-"); +check_result (1 - [3,4], [-2,-3],"-"); +check_result ([3,4] - 1, [2,3],"-"); + +check_result ([1,2] * [3,4], [3,8], "*"); +check_result (1 * [3,4], [3,4], "*"); +check_result ([3,4] * 1, [3,4], "*"); + +check_result ([12,24] / [3,4], [4,6],"/"); +check_result (12 / [3,4], [4,3],"/"); +check_result ([3,4] / 1, [3,4],"/"); + +check_result ([1,2] mod [3,4], [1,2],"mod"); +check_result (3 mod [3,2], [0,1],"mod"); +check_result ([3,4] mod 4, [3,0],"mod"); + +check_result ([1,2] == [3,2], [0,1],"=="); +check_result (3 == [3,4], [1,0],"=="); +check_result ([3,4] == 1, [0,0],"=="); + +check_result ([1,2] != [3,2], [1,0],"!="); +check_result (3 != [3,4], [0,1],"!="); +check_result ([3,4] != 1, [1,1],"!="); + +check_result ([1,2] > [3,2], [0,0],">"); +check_result (1 > [3,4], [0,0],">"); +check_result ([3,4] > 1, [1,1],">"); + +check_result ([1,2] >= [3,2], [0,1],">="); +check_result (1 >= [3,4], [0,0],">="); +check_result ([3,4] >= 1, [1,1],">="); + +check_result ([1,2] >= [3,2], [0,1],">="); +check_result (1 >= [3,4], [0,0],">="); +check_result ([3,4] >= 1, [1,1],">="); + +check_result ([1,2] < [3,2], [1,0],"<"); +check_result (1 < [3,4], [1,1],"<"); +check_result ([3,4] < 1, [0,0],"<"); + +check_result ([1,2] <= [3,2], [1,1],"<="); +check_result (1 <= [3,4], [1,1],"<="); +check_result ([3,4] <= 1, [0,0],"<="); +#ifexists Double_Type +check_result ([1,2] ^ [3,2], [1,4],"^"); +check_result (1 ^ [3,4], [1,1],"^"); +check_result ([3,4] ^ 1, [3,4],"^"); +check_result ([3,4] ^ 0, [1,1],"^"); +#endif +check_result ([1,2] or [3,2], [1,1],"or"); +check_result (1 or [3,4], [1,1],"or"); +check_result ([0,1] or 1, [1,1],"or"); + +check_result ([1,2] and [3,2], [1,1],"and"); +check_result (1 and [0,4], [0,1],"and"); +check_result ([3,4] and 0, [0,0],"and"); + +check_result ([1,2] & [3,2], [1,2],"&"); +check_result (1 & [3,4], [1,0],"&"); +check_result ([3,4] & 1, [1,0],"&"); + +check_result ([1,2] | [3,2], [3,2],"|"); +check_result (1 | [3,4], [3,5],"|"); +check_result ([3,4] | 1, [3,5],"|"); + +check_result ([1,2] xor [3,2], [2,0],"xor"); +check_result (1 xor [3,4], [2,5],"xor"); +check_result ([3,4] xor 1, [2,5],"xor"); + +check_result ([1,2] shl [3,2], [8,8],"shl"); +check_result (1 shl [3,4], [8,16],"shl"); +check_result ([3,4] shl 1, [6,8],"shl"); + +check_result ([1,4] shr [3,1], [0,2],"shr"); +check_result (8 shr [3,4], [1,0],"shr"); +check_result ([3,4] shr 1, [1,2],"shr"); + +% Test __tmp optimizations +static define test_tmp () +{ + variable x = [1:100]; + x = 1*__tmp(x)*1 + 1; + if (neqs (x), [2:101]) + failed ("__tmp optimizations"); +} + +static define ones () +{ + variable a; + + a = __pop_args (_NARGS); + return @Array_Type (Integer_Type, [__push_args (a)]) + 1; +} + +variable X = ones (5, 10); + +(dims,,) = array_info (X); +if ((dims[0] != 5) or (dims[1] != 10)) + failed ("ones dims"); +if (length (where (X != 1))) + failed ("ones 1"); + + +define test_assignments (x, i, a) +{ + variable y, z; + + y = @x; z = @x; y[i] += a; z[i] = z[i] + a; check_result (y, z, "[]+="); + y = @x; z = @x; y[i] -= a; z[i] = z[i] - a; check_result (y, z, "[]-="); + y = @x; z = @x; y[i] /= a; z[i] = z[i] / a; check_result (y, z, "[]/="); + y = @x; z = @x; y[i] *= a; z[i] = z[i] * a; check_result (y, z, "[]*="); + + y = @x; z = @x; y[i]++; z[i] = z[i] + 1; check_result (y, z, "[]++"); + y = @x; z = @x; y[i]--; z[i] = z[i] - 1; check_result (y, z, "[]--"); +} + +test_assignments ([1:10], 3, 5); +test_assignments ([1:10], [3], 5); +test_assignments ([1:10], [1,3,5], 5); + +% Test semi-open intervals +define test_semiopen (a, b, dx, n) +{ + variable last, first; + variable aa = [a:b:dx]; + + if (length (aa) != n) + failed ("test_semiopen (%S,%S,%S,%S): length==>%d", a, b, dx, n, length(aa)); + + if (n == 0) + return; + + first = aa[0]; + if (first != a) + failed ("test_semiopen (%S,%S,%S,%S): first", a, b, dx, n); + + last = a[-1]; + if (dx > 0) + { + if (last >= b) + failed ("test_semiopen (%S,%S,%S,%S): last", a, b, dx, n); + } + else if (last <= b) + failed ("test_semiopen (%S,%S,%S,%S): last", a, b, dx, n); +} +#ifexists Double_Type +test_semiopen (1.0, 10.0, 1.0, 9); +test_semiopen (1.0, 1.0, 12.0, 0); +test_semiopen (1.0, 1.2, -1.0, 0); +test_semiopen (1.0, 0.0, -1.0, 1); +test_semiopen (1.0, -0.0001, -1.0, 2); +#endif + +A = 3; if (typeof (A[*]) != Array_Type) failed ("A[*]"); + +static define test_inline_array (a, type) +{ + if (_typeof (a) != type) + failed ("test_inline_array: %S is not %S type", a, type); +} + +test_inline_array ([1,2,3], Int_Type); +test_inline_array ([1L,2L,3L], Long_Type); +test_inline_array ([1h,2h,3h], Short_Type); +#ifexists Double_Type +test_inline_array ([1f, 0, 0], Float_Type); +test_inline_array ([1f, 0.0, 0h], Double_Type); +#endif +#ifexists Complex_Type +test_inline_array ([1f, 0.0, 0i], Complex_Type); +test_inline_array ([1i, 0h, 0i], Complex_Type); +test_inline_array ([0h, 0i], Complex_Type); +test_inline_array ([0i, 0i], Complex_Type); +#endif +test_inline_array (["a", "b"], String_Type); + +A = String_Type[10]; +A[*] = "a"; +if ("aaaaaaaaaa" != strjoin (A, "")) + failed ("A[*]"); +A[5] = NULL; +if ((A[5] != NULL) + or ("aaaaaaaaa" != strjoin (A[[0,1,2,3,4,6,7,8,9]], ""))) + failed ("A[5] != NULL"); + +A[1] = NULL; +if ((length(where(_isnull(A))) != 2) + or (where (_isnull(A))[0] != 1) + or (where (_isnull(A))[1] != 5)) + failed ("_isnull: %S", where(_isnull(A))[1] != 5); + +A[*] = "a"; +if ("aaaaaaaaaa" != strjoin (A, "")) + failed ("A[5]=a"); +A[[3,7]] = NULL; +if ((A[3] != NULL) or (A[7] != NULL) + or ("aaaaaaaa" != strjoin (A[[0,1,2,4,5,6,8,9]], ""))) + failed ("A[3,7]=NULL"); + +A = String_Type[10]; +A[*] = "a"; +A[1] = NULL; +if (length (where (A != String_Type[10])) != 9) + failed ("A != String_Type[10]"); + + +% Test array summing operations +#ifexists Double_Type +static define compute_sum (a, n) +{ + variable s = 0; + variable b; + variable i, j, k; + variable dims; + + (dims,,) = array_info (a); + if (n == 0) + { + b = Double_Type[dims[1],dims[2]]; + for (i = 0; i < dims[1]; i++) + { + for (j = 0; j < dims[2]; j++) + { + for (k = 0; k < dims[n]; k++) + b[i,j] += a[k,i,j]; + } + } + return b; + } + if (n == 1) + { + b = Double_Type[dims[0],dims[2]]; + for (i = 0; i < dims[0]; i++) + { + for (j = 0; j < dims[2]; j++) + { + for (k = 0; k < dims[n]; k++) + b[i,j] += a[i,k,j]; + } + } + return b; + } + if (n == 2) + { + b = Double_Type[dims[0],dims[1]]; + for (i = 0; i < dims[0]; i++) + { + for (j = 0; j < dims[1]; j++) + { + for (k = 0; k < dims[n]; k++) + b[i,j] += a[i,j,k]; + } + } + return b; + } + + b = 0.0; + for (i = 0; i < dims[0]; i++) + { + for (j = 0; j < dims[1]; j++) + { + for (k = 0; k < dims[2]; k++) + b += a[i,j,k]; + } + } + return b; +} + +A = [1:3*4*5]; +reshape (A, [3,4,5]); + +define test_sum (a, n) +{ + variable s1, s2; + + if (n == -1) + s1 = sum(A); + else + s1 = sum(A,n); + + s2 = compute_sum (A, n); + + if (neqs (s1, s2)) + { + failed ("sum(A,%d): %S != %S: %g != %g", n, s1, s2, s1[0,0], s2[0,0]); + } +} + +test_sum (A,-1); +test_sum (A,2); +test_sum (A,1); +test_sum (A,0); + +A = [1+2i, 2+3i, 3+4i]; +if (sum(A) != A[0] + A[1] + A[2]) + failed ("sum(Complex)"); +#endif % Double_Type + +define find_min (a) +{ + variable m = a[0]; + _for (1, length(a)-1, 1) + { + variable i = (); + if (a[i] < m) + m = a[i]; + } + return m; +} + +define find_max (a) +{ + variable m = a[0]; + _for (1, length(a)-1, 1) + { + variable i = (); + if (a[i] > m) + m = a[i]; + } + return m; +} + +define test_eqs (what, a, b) +{ + if (_typeof(a) != _typeof(b)) + failed ("%s: %S != %S", what, a, b); + + if (neqs (a, b)) + failed ("%s: %S != %S", what, a, b); +} + +A = [1:10]; +test_eqs ("min", min(A), find_min(A)); +test_eqs ("max", max(A), find_max(A)); +#ifexists Double_Type +A *= 1.0f; +test_eqs ("min", min(A), find_min(A)); +test_eqs ("max", max(A), find_max(A)); +A *= 1.0; +test_eqs ("min", min(A), find_min(A)); +test_eqs ("max", max(A), find_max(A)); +#endif +A = [1h:10h]; +test_eqs ("min", min(A), find_min(A)); +test_eqs ("max", max(A), find_max(A)); +A = ['0':'9']; +test_eqs ("min", min(A), find_min(A)); +test_eqs ("max", max(A), find_max(A)); + +A=Int_Type[10,10]; +A[*,*] = [0:99]; +if (length (A[[0:99:11]]) != 10) + failed ("A[[0:99:11]"); + +#ifexists cumsum +static define do_cumsum (a) +{ + variable b = 1.0 * a; + variable i, s; + + s = 0; + _for (0, length(a)-1, 1) + { + i = (); + s += a[i]; + b[i] = s; + } + return b; +} + +static define test_cumsum (a, k, result_type) +{ + variable b = 1.0 * a; + variable bb; + + variable dims, ndims; + variable i, j; + (dims, ndims, ) = array_info (a); + + if (k != -1) + bb = cumsum (a, k); + else + bb = cumsum (a); + + if (_typeof (bb) != result_type) + { + failed ("cumsum(%S) has wrong return type (%S)", a, b); + } +#ifexists Complex_Type + if ((_typeof (a) != Complex_Type) and (_typeof (a) != Float_Type)) +#endif + a = typecast (a, Double_Type); + + if (k == -1) + { + b = do_cumsum (_reshape (a, [length(a)])); + } + else switch (ndims) + { + case 1: + b = cumsum (a); + } + { + case 2: + if (k == 0) + { + %a_j = cumsum_i a_ij + _for (0, dims[1]-1, 1) + { + j = (); + b[*, j] = do_cumsum (a[*, j]); + } + } + else + { + _for (0, dims[1]-1, 1) + { + i = (); + b[i, *] = do_cumsum (a[i, *]); + } + } + } + { + case 3: + if (k == 0) + { + %a_j = cumsum_i a_ij + _for (0, dims[1]-1, 1) + { + i = (); + _for (0, dims[2]-1, 1) + { + j = (); + b[*, i, j] = do_cumsum (a[*, i, j]); + } + } + } + else if (k == 1) + { + _for (0, dims[0]-1, 1) + { + i = (); + _for (0, dims[2]-1, 1) + { + j = (); + b[i, *, j] = do_cumsum (a[i, *, j]); + } + } + } + else + { + _for (0, dims[0]-1, 1) + { + i = (); + _for (0, dims[1]-1, 1) + { + j = (); + b[i, j, *] = do_cumsum (a[i, j, *]); + } + } + } + } + + if (neqs (b, bb)) + { + failed ("cumsum (%S, %d), expected %S, got %S", a, k, b, bb); + } +} + + +A = Int_Type[10]; A[*] = 1; +test_cumsum (A, -1, Double_Type); +test_cumsum (A, 0, Double_Type); +A = [1:3*4*5]; +reshape (A, [3,4,5]); +test_cumsum (A, -1, Double_Type); +test_cumsum (A, 0, Double_Type); +test_cumsum (A, 1, Double_Type); +test_cumsum (A, 2, Double_Type); + +A = Char_Type[10]; A[*] = 1; +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +A = [1:3*4*5]; A = typecast (A, Char_Type); +reshape (A, [3,4,5]); +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +test_cumsum (A, 1, Float_Type); +test_cumsum (A, 2, Float_Type); + +A = UChar_Type[10]; A[*] = 1; +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +A = [1:3*4*5]; A = typecast (A, UChar_Type); +reshape (A, [3,4,5]); +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +test_cumsum (A, 1, Float_Type); +test_cumsum (A, 2, Float_Type); + +A = Short_Type[10]; A[*] = 1; +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +A = [1:3*4*5]; A = typecast (A, Short_Type); +reshape (A, [3,4,5]); +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +test_cumsum (A, 1, Float_Type); +test_cumsum (A, 2, Float_Type); + +A = UShort_Type[10]; A[*] = 1; +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +A = [1:3*4*5]; A = typecast (A, UShort_Type); +reshape (A, [3,4,5]); +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +test_cumsum (A, 1, Float_Type); +test_cumsum (A, 2, Float_Type); + +A = Float_Type[10]; A[*] = 1; +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +A = [1:3*4*5]*1.0f; +reshape (A, [3,4,5]); +test_cumsum (A, -1, Float_Type); +test_cumsum (A, 0, Float_Type); +test_cumsum (A, 1, Float_Type); +test_cumsum (A, 2, Float_Type); + +#ifexists Complex_Type +A = Complex_Type[10]; A[*] = 1; +test_cumsum (A, -1, Complex_Type); +test_cumsum (A, 0, Complex_Type); +A = [1:3*4*5] + 2i*[1:3*4*5]; +reshape (A, [3,4,5]); +test_cumsum (A, -1, Complex_Type); +test_cumsum (A, 0, Complex_Type); +test_cumsum (A, 1, Complex_Type); +test_cumsum (A, 2, Complex_Type); +#endif + +#endif + +print ("Ok\n"); + +exit (0); + diff --git a/libslang/src/test/arrmult.sl b/libslang/src/test/arrmult.sl new file mode 100644 index 0000000..cd0cca8 --- /dev/null +++ b/libslang/src/test/arrmult.sl @@ -0,0 +1,163 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing Matrix Multiplications ..."); +#ifexists Double_Type + +static define dot_prod (a, b) +{ + (a # b)[0]; % transpose not needed for 1-d arrays +} + +static define sum (a) +{ + variable ones = Double_Type [length (a)] + 1; + dot_prod (a, ones); +} + + +if (1+2+3+4+5 != sum([1,2,3,4,5])) + failed ("sum"); + +#ifexists Complex_Type +if (1+2i != sum ([1,2i])) + failed ("sum complex"); +#endif + +define mult (a, b) +{ + variable dims_a, dims_b; + variable nr_a, nr_b, nc_a, nc_b; + variable i, j; + variable c; + + (dims_a,,) = array_info (a); + (dims_b,,) = array_info (b); + nr_a = dims_a[0]; + nc_a = dims_a[1]; + nr_b = dims_b[0]; + nc_b = dims_b[1]; + + c = _typeof ([a[0,0]]#[b[0,0]])[nr_a, nc_b]; + + for (i = 0; i < nr_a; i++) + { + for (j = 0; j < nc_b; j++) + c[i,j] = dot_prod (a[i,*], b[*,j]); + } + return c; +} + +static define arr_cmp (a, b) +{ + variable i = length (where (b != a)); + if (i == 0) + return 0; + + i = where (b != a); + a = a[i]; + b = b[i]; + reshape (a, [length(a)]); + reshape (b, [length(b)]); + vmessage ("%S != %S\n", a[0], b[0]); + return 1; +} + +static define test (a, b) +{ + if (0 != arr_cmp (mult (a,b), a#b)) + failed ("%S # %S", a, b); +} + +variable A, B; + +#ifexists Complex_Type +A = [1+2i]; +B = [3+4i]; +reshape (A, [1, 1]); +reshape (B, [1, 1]); +test (A,B); +#endif + +% Test intgers +A = _reshape ([[1, 2, 3], [4, 5, 6]], [2,3]); +B = _reshape ([[7,8,9],[1,2,4]], [2,3]); +B = transpose (B); + +test (A, B); + +B *= 1f; +test (A, B); + +B *= 1.0; +test (A,B); + +A *= 1f; +test (A,B); + +#ifexists Complex_Type +B += 2i; +test (A,B); + +A += 3i; +test (A,B); + +B = Real(B); +test (A,B); + +% Now try an empty array + +if (Complex_Type != _typeof (Complex_Type[0,0,0] # Complex_Type[0])) + failed ("[]#[]"); +#endif +% And finally, do a 3-d array: + +A = _reshape ([1:2*3*4], [2,3,4]); +B = _reshape ([1:4*5*6], [4,5,6]); +static variable C = A#B; + +% C should be a [2,3,5,6] matrix. Let's check via brute force + +static define multiply_3d (a, b, c) +{ + variable i, j, k, l, m; + variable dims_a, dims_b; + + (dims_a,,) = array_info(a); + (dims_b,,) = array_info(b); + + _for (0, dims_a[0]-1, 1) + { + i = (); + _for (0, dims_a[1]-1, 1) + { + j = (); + _for (0, dims_b[1]-1, 1) + { + l = (); + _for (0, dims_b[2]-1, 1) + { + m = (); + + variable sum = 0; + _for (0, dims_b[0]-1, 1) + { + k = (); + sum += a[i,j,k] * b[k, l, m]; + } + if (sum != c[i,j,l,m]) + failed ("multiply_3d"); + } + } + } + } +} + +multiply_3d (A, B, C); + + +print ("Ok\n"); +#else +print ("Not available\n"); +#endif +exit (0); + diff --git a/libslang/src/test/assoc.sl b/libslang/src/test/assoc.sl new file mode 100644 index 0000000..2576f46 --- /dev/null +++ b/libslang/src/test/assoc.sl @@ -0,0 +1,135 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing Associative Arrays ..."); + +static define key_to_value (k) +{ + return "<<<" + k + ">>>"; +} + +static define value_to_key (v) +{ + strcompress (v, "<>"); +} + +static define add_to_x (x, k) +{ + x[k] = key_to_value(k); +} + +static variable Default_Value = "****Default-Value****"; + +define setup (type) +{ + variable x = Assoc_Type [type, Default_Value]; + + add_to_x (x, "foo"); + add_to_x (x, "bar"); + add_to_x (x, "silly"); + add_to_x (x, "cow"); + add_to_x (x, "dog"); + add_to_x (x, "chicken"); + + return x; +} + +static variable X; + +% Test create/destuction of arrays +loop (20) X = setup (Any_Type); + +loop (20) X = setup (String_Type); + +static variable k, v; + +foreach (X) +{ + (k, v) = (); + if ((k != value_to_key(v)) or (v != key_to_value (k)) + or (X[k] != v)) + failed ("foreach"); +} + +foreach (X) using ("keys") +{ + k = (); + if (X[k] != key_to_value (k)) + failed ("foreach using keys"); +} + +foreach (X) using ("keys", "values") +{ + (k, v) = (); + if ((k != value_to_key(v)) or (v != key_to_value (k)) + or (X[k] != v)) + failed ("foreach using keys, values"); +} + +k = assoc_get_keys (X); +v = assoc_get_values (X); + +static variable i; +_for (0, length(k)-1, 1) +{ + i = (); + if (v[i] != X[k[i]]) + failed ("assoc_get_keys/values"); + assoc_delete_key (X, k[i]); +} + +if (length (X) != 0) + error ("assoc_delete_key failed"); + +if (X["*******************"] != Default_Value) + failed ("default value"); + +static define eqs (a, b) +{ + variable len; + len = length (a); + if (len != length (b)) + return 0; + + len == length (where (a == b)); +} + +static define neqs (a, b) +{ + not (eqs (a, b)); +} + + +static define store_and_test (a, indx, value) +{ + a[indx] = value; + if (typeof (value) != typeof(a[indx])) + failed ("typeof (value)"); + if (neqs (a[indx], value)) + failed ("a[indx] != value"); +} + +X = Assoc_Type[]; + +store_and_test (X, "string", "string"); +store_and_test (X, "array", ["a", "b", "c"]); +store_and_test (X, "int", 3); +#ifexists Complex_Type +store_and_test (X, "z", 3+2i); +#endif + +static variable V = assoc_get_values (X); +static variable K = assoc_get_keys (X); + +static variable i; + +_for (0, length(X)-1, 1) +{ + i=(); + if (neqs(X[K[i]], @V[i])) + failed ("assoc_get_values"); +} + +print ("Ok\n"); + +exit (0); + diff --git a/libslang/src/test/bstring.sl b/libslang/src/test/bstring.sl new file mode 100644 index 0000000..3ac8a3d --- /dev/null +++ b/libslang/src/test/bstring.sl @@ -0,0 +1,32 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing Binary Strings..."); + +variable a = "\000A\000B\000C\000D"; + +if (typeof (a) != BString_Type) failed ("typeof"); + +if (bstrlen (a) != 8) failed ("bstrlen"); + +if ((a[[0:7:2]] != "\000\000\000\000") + or (a[[1:7:2]] != "ABCD")) failed ("array indexing"); + +if (strlen (a) != 0) failed ("typecast"); + +a += "XYZ"; + +if (a[[8:]] != "XYZ") failed ("+= op"); + +a = "XYZ" + a; +if (a == "XYZ") failed ("== op"); + +if (strcmp (a, "XYZ")) failed ("failed strcmp"); + +loop (1000) +{ + a = "\000A\000B\000C\000D"; + a = "A\000B\000C\000"; +} + +print ("Ok\n"); +exit (0); diff --git a/libslang/src/test/ifeval.sl b/libslang/src/test/ifeval.sl new file mode 100644 index 0000000..e0d382f --- /dev/null +++ b/libslang/src/test/ifeval.sl @@ -0,0 +1,404 @@ + +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +_debug_info = 1; () = evalfile ("inc.sl"); +#else +failed("#else"); +#endif + + +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +print ("Testing #ifeval ..."); +#else +failed("#else"); +#endif + +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +define +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +check_typeof +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +(expr, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + type) +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +{ +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + if +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + (typeof ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + expr) +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + != type) +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + failed ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +"typeof " + string ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +type) + " found " + string ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +typeof( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +expr))); +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +} +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +static variable +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +Silly = [ +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +1, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +2, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +3, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +4, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +5, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +6]; +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +if (length (Silly) != 6) +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + failed ("Silly Array"); +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +Silly = [1: +#else +failed("#else"); +#endif +#ifeval variable XXX = [1:3]; XXX = [1,2,3]; length(XXX); +10]; +#else +failed("#else"); +#endif +#ifeval variable XXX = [1:3]; XXX = [1,2,3]; length(XXX); +if (length (Silly) != 10) failed ("[1:10]"); +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +Silly = struct +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +{ +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + a, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {x = struct { c, d, a}; return 1;} crazy (0,0,0,0); + b, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + c +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +}; +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +Silly.a = "hello"; +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +define check_bool ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +i) +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +{ +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + check_typeof ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +i == i, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + Char_Type); +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +} +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +define check_result ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +i, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + j, +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + k) +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +{ +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + if ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +k != i + j) +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + failed ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +sprintf( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +"%S + %S != %S", +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + typeof ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +i), +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + typeof( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +j), +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + typeof( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +k))); +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +} +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +check_typeof( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +'a', +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + UChar_Type); +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +check_typeof ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +'a' + 'b', +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + Integer_Type); +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +check_typeof ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +1h + 'b', +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + Integer_Type); +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +if ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +Integer_Type == Short_Type) check_typeof ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +1hu + 'b', +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + UInteger_Type); +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +else check_typeof ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +1hu + 'b', +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + Integer_Type); +#else +failed("#else"); +#endif + +print ( +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); + "Ok\n"); +exit ( +#else +failed("#else"); +#endif +#ifeval define crazy (x,y,z,w) {return 1;} crazy (0,0,0,0); +0); +#else +failed("#else"); +#endif + +failed ("Should not see this!!!"); diff --git a/libslang/src/test/inc.sl b/libslang/src/test/inc.sl new file mode 100644 index 0000000..54e3d06 --- /dev/null +++ b/libslang/src/test/inc.sl @@ -0,0 +1,15 @@ +define print (x) +{ + x = string (x); + () = fputs (x, stdout); + () = fflush (stdout); +} + +define failed () +{ + variable s = __pop_args (_NARGS); + s = sprintf (__push_args(s)); + () = fprintf (stderr, "Failed: %s\n", s); + exit (1); +} + diff --git a/libslang/src/test/loops.sl b/libslang/src/test/loops.sl new file mode 100644 index 0000000..ac22611 --- /dev/null +++ b/libslang/src/test/loops.sl @@ -0,0 +1,130 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing looping constructs ..."); + +define identity (x) +{ + return x; +} + +define test_do_while (count_fun) +{ + variable i = 0; + variable count = 0; + do + { + if (i == 3) + continue; + i++; + } + while (@count_fun (&count) < 6); + if ((count != 6) or (i != 3)) + failed ("do_while 1: %S", count_fun); + + i = 0; + count = 0; + do + { + if (i == 3) + break; + i++; + } + while (@count_fun (&count) < 6); + if ((count != 3) or (i != 3)) + failed ("do_while 2: %S", count_fun); +} + +define test_while (count_fun) +{ + variable i = 0; + variable count = 0; + + while (@count_fun (&count) < 6) + { + if (i == 3) + continue; + i++; + } + if ((count != 6) or (i != 3)) + failed ("while 1: %S", count_fun); + + i = 0; + count = 0; + while (@count_fun (&count) < 6) + { + if (i == 3) + break; + i++; + } + if ((count != 4) or (i != 3)) + failed ("while 2: %S", count_fun); +} + +define test_for (count_fun) +{ + variable i = 0; + variable count = 0; + + for (count = 0; @count_fun (&count) < 6; ) + { + if (i == 3) + continue; + i++; + } + if ((count != 6) or (i != 3)) + failed ("while 1: %S", count_fun); + + i = 0; + for (count = 0; @count_fun (&count) < 6; ) + { + if (i == 3) + break; + i++; + } + if ((count != 4) or (i != 3)) + failed ("while 2: %S", count_fun); +} + +define add_one (x) +{ + @x = @x + 1; + return @x; +} + +define add_one_with_call (x) +{ + @x = @x+1; + return identity (@x); +} + +define add_one_with_loop (x) +{ + variable i = 0; + while (1) + { + @x = @x + 1; + i++; + if (i == 3) + break; + } + @x = @x - 2; + return @x; +} + + +test_do_while (&add_one); +test_do_while (&add_one_with_call); +test_do_while (&add_one_with_loop); + +test_while (&add_one); +test_while (&add_one_with_call); +test_while (&add_one_with_loop); + +test_for (&add_one); +test_for (&add_one_with_call); +test_for (&add_one_with_loop); + +print ("Ok\n"); + +exit (0); + diff --git a/libslang/src/test/ns1.inc b/libslang/src/test/ns1.inc new file mode 100644 index 0000000..3ae6c68 --- /dev/null +++ b/libslang/src/test/ns1.inc @@ -0,0 +1,6 @@ +implements (This_Namespace); +private variable NS = This_Namespace; +define func () +{ + return NS; +} diff --git a/libslang/src/test/ns2.inc b/libslang/src/test/ns2.inc new file mode 100644 index 0000000..3ae6c68 --- /dev/null +++ b/libslang/src/test/ns2.inc @@ -0,0 +1,6 @@ +implements (This_Namespace); +private variable NS = This_Namespace; +define func () +{ + return NS; +} diff --git a/libslang/src/test/nspace.sl b/libslang/src/test/nspace.sl new file mode 100644 index 0000000..0b961c7 --- /dev/null +++ b/libslang/src/test/nspace.sl @@ -0,0 +1,93 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing NameSpace routines ..."); + +if (current_namespace () != "") + failed ("current_namespace - 1"); + +implements ("NSpace"); +% From this point on, define and variable defaults to static + +if (current_namespace () != "NSpace") + failed ("current_namespace - 2"); + +define static_function () +{ + "static_function"; +} +variable static_variable = "static_variable"; + +public define public_function () +{ + "public_function"; +} +public variable public_variable = "public_variable"; + +private define private_function () +{ + "private_function"; +} +private variable private_variable = "private_variable"; + +!if (is_defined ("Global->public_function")) failed ("public_function"); +!if (is_defined ("Global->public_variable")) failed ("public_variable"); +!if (is_defined ("public_function")) failed ("public_function"); +!if (is_defined ("public_variable")) failed ("public_variable"); +!if (is_defined ("NSpace->static_function")) failed ("static_function"); +!if (is_defined ("NSpace->static_variable")) failed ("static_variable"); +if (is_defined ("NSpace->private_function")) failed ("private_function"); +if (is_defined ("NSpace->private_variable")) failed ("private_variable"); + +if (static_variable != NSpace->static_variable) failed ("static_variable test"); +if (public_variable != Global->public_variable) failed ("public_variable test"); +if (private_variable != "private_variable") failed ("private_variable test"); + +public variable This_Namespace; + +This_Namespace = "NS1"; +() = evalfile ("ns1.inc"); +This_Namespace = "NS2"; +() = evalfile ("ns2.inc"); + +use_namespace ("NS1"); +if (func () != "NS1") + failed ("use_namespace 1"); +define func1 () +{ + return "1"; +} +use_namespace ("NS2"); +if (func () != "NS2") + failed ("use_namespace 2"); +define func1 () +{ + return "2"; +} +use_namespace ("Global"); +if (is_defined ("func")) + failed ("use_namespace Global"); +define func1 () +{ + return "3"; +} +!if (is_defined ("func1")) + failed ("use_namespace Global: func1"); + +if (NS1->func () != "NS1") + failed ("NS1->func"); +if (NS2->func () != "NS2") + failed ("NS2->func"); +if (NS1->func1 () != "1") + failed ("NS1->func1"); +if (NS2->func1 () != "2") + failed ("NS2->func1"); +if (Global->func1 () != "3") + failed ("Global->func1"); + +if (length (_get_namespaces ()) != 4) % Global, NS1, NS2, NSpace + failed ("_get_namespaces: %S", _get_namespaces()); + +print ("Ok\n"); + +exit (0); + diff --git a/libslang/src/test/nspace2.sl b/libslang/src/test/nspace2.sl new file mode 100644 index 0000000..d13c15d --- /dev/null +++ b/libslang/src/test/nspace2.sl @@ -0,0 +1,70 @@ +#ifexists This_Namespace +if (This_Namespace == "NS3") + { + if (current_namespace () != "NS3") + { + failed ("evalfile in NS3"); + } + } +else + implements (This_Namespace); +%vmessage ("Loading ..."); +% From this point on, define and variable defaults to static +private variable NS = This_Namespace; +define func () +{ + return NS; +} +#else +variable This_Namespace; +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing more NameSpace routines ..."); +This_Namespace = "NS1"; +() = evalfile (__FILE__); +This_Namespace = "NS2"; +() = evalfile (__FILE__); + +This_Namespace = "NS3"; +() = evalfile (__FILE__, "NS3"); + +use_namespace ("NS1"); +if (func () != "NS1") + failed ("use_namespace 1, found %s", func()); + +use_namespace ("NS2"); +if (func () != "NS2") + failed ("use_namespace 2"); + +use_namespace ("Global"); +if (is_defined ("func")) + failed ("use_namespace Global"); + +if (NS1->func () != "NS1") + failed ("NS1->func"); +if (NS2->func () != "NS2") + failed ("NS2->func"); + +if ("NS1" != eval ("func", "NS1")) + failed ("eval in NS1"); +if ("NS2" != eval ("func", "NS2")) + failed ("eval in NS2"); +if ("NS3" != eval ("func", "NS3")) + failed ("eval in NS3"); + +if ("NS4" != eval ("current_namespace()", "NS4")) + failed ("eval in NS4"); + +implements ("foo"); +variable X = "foo"; +implements ("bar"); +variable X = "bar"; + +if (foo->X != "foo") + failed ("foo"); +if (bar->X != "bar") + failed ("bar"); + +print ("Ok\n"); +exit (0); +#endif diff --git a/libslang/src/test/ospath.sl b/libslang/src/test/ospath.sl new file mode 100644 index 0000000..caf4a5a --- /dev/null +++ b/libslang/src/test/ospath.sl @@ -0,0 +1,42 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing ospath ..."); + +static define test_path (path, dir, base, ext, dirbase) +{ + if (dir != path_dirname (path)) + failed ("path_dirname " + path); + + if (base != path_basename (path)) + failed ("path_basename " + path); + + if (ext != path_extname (path)) + failed ("path_extname " + path); + + if (dirbase != path_concat (dir, base)) + failed ("path_concat(%s,%s)", dir, base); +} + +#ifdef UNIX +test_path ("etc/rc.d", "etc", "rc.d", ".d", "etc/rc.d"); +test_path ("etc", ".", "etc", "", "./etc"); +test_path ("usr/etc/", "usr/etc", "", "", "usr/etc/"); +test_path ("/", "/", "", "", "/"); +test_path (".", ".", ".", ".", "./."); +test_path ("/a./b", "/a.", "b", "", "/a./b"); +test_path (".c", ".", ".c", ".c", "./.c"); +#elifndef VMS +test_path ("etc\\rc.d", "etc", "rc.d", ".d", "etc\\rc.d"); +test_path ("etc", ".", "etc", "", ".\\etc"); +test_path ("usr\\etc\\", "usr\\etc", "", "", "usr\\etc\\"); +test_path ("\\", "\\", "", "", "\\"); +test_path (".", ".", ".", ".", ".\\."); +test_path ("\\a.\\b", "\\a.", "b", "", "\\a.\\b"); +test_path (".c", ".", ".c", ".c", ".\\.c"); +#else +message ("**** NOT IMPLEMENTED ****"); +#endif +print ("Ok\n"); + +exit (0); + diff --git a/libslang/src/test/pack.sl b/libslang/src/test/pack.sl new file mode 100644 index 0000000..7137609 --- /dev/null +++ b/libslang/src/test/pack.sl @@ -0,0 +1,107 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing pack and unpack functions..."); + +static variable is_lil_endian = (pack ("j", 0xFF)[0] == 0xFF); + +static define test_pack () +{ + variable str; + variable fmt, val, args; + + args = __pop_args (_NARGS - 2); + (fmt, val) = (); + + str = pack (fmt, __push_args (args)); + if (typeof (str) != BString_Type) + failed ("pack did not return a bstring for format = " + fmt); + if (str != val) + failed ("pack returned wrong result for format = " + + fmt + ":" + str); +} + +variable X = 0x12345678L; +variable S = "\x12\x34\x56\x78"; +if (is_lil_endian) S = "\x78\x56\x34\x12"; + +test_pack (">k", "\x12\x34\x56\x78", X); +test_pack ("j1", "\0\0A\0\0BC\0\xD\xE", 'A', ['B', 'C'], 0x0D0E); + +test_pack ("s4", "1234", "123456"); +test_pack ("S4", "1234", "123456"); +test_pack ("s10", "1234\0\0\0\0\0\0", "1234"); +test_pack ("S10", "1234 ", "1234"); + +define test_unpack1 (fmt, str, x, type) +{ + variable xx; + + x = typecast (x, type); + + xx = unpack (fmt, str); + + if (length (where(xx != x))) + failed ("unpack returned wrong result for " + fmt + ":" + string (xx)); +} + +#ifexists Double_Type +X = 3.14; if (X != unpack ("d", pack ("d", X))) failed ("pack->unpack for d"); +X = 3.14f; if (X != unpack ("f", pack ("f", X))) failed ("pack->unpack for f"); +#endif + +test_unpack1 (">j", "\xAB\xCD", 0xABCD, Int16_Type); +test_unpack1 (">k", "\xAB\xCD\xEF\x12", 0xABCDEF12L, Int32_Type); +test_unpack1 (" +#include +#include + +#include "../sl-feat.h" + +#if SLANG_HAS_FLOAT +#if defined(__FreeBSD__) || defined(__386BSD__) +# include +# define HAVE_FPSETMASK 1 +#endif +#endif + +static int Ignore_Exit = 0; +static void c_exit (int *code) +{ + if (Ignore_Exit == 0) + exit (*code); +} + +static char test_char_return (char *x) +{ + return *x; +} +static short test_short_return (short *x) +{ + return *x; +} +static int test_int_return (int *x) +{ + return *x; +} +static long test_long_return (long *x) +{ + return *x; +} +/* static float test_float_return (float *x) */ +/* { */ +/* return *x; */ +/* } */ +#if SLANG_HAS_FLOAT +static double test_double_return (double *x) +{ + return *x; +} +#endif +typedef struct +{ + int i; + long l; + short h; + char b; +#if SLANG_HAS_FLOAT + double d; + double c[2]; +#endif + char *s; + SLang_Array_Type *a; + char *ro_str; +} +CStruct_Type; + +static SLang_CStruct_Field_Type C_Struct [] = +{ + MAKE_CSTRUCT_FIELD(CStruct_Type, i, "i", SLANG_INT_TYPE, 0), +#if SLANG_HAS_FLOAT + MAKE_CSTRUCT_FIELD(CStruct_Type, d, "d", SLANG_DOUBLE_TYPE, 0), + MAKE_CSTRUCT_FIELD(CStruct_Type, c, "z", SLANG_COMPLEX_TYPE, 0), +#endif + MAKE_CSTRUCT_FIELD(CStruct_Type, s, "s", SLANG_STRING_TYPE, 0), + MAKE_CSTRUCT_FIELD(CStruct_Type, a, "a", SLANG_ARRAY_TYPE, 0), + MAKE_CSTRUCT_FIELD(CStruct_Type, ro_str, "ro_str", SLANG_STRING_TYPE, 1), + MAKE_CSTRUCT_INT_FIELD(CStruct_Type, l, "l", 0), + MAKE_CSTRUCT_INT_FIELD(CStruct_Type, h, "h", 0), + MAKE_CSTRUCT_INT_FIELD(CStruct_Type, b, "b", 0), + SLANG_END_CSTRUCT_TABLE +}; + +static CStruct_Type C_Struct_Buf; +static void check_cstruct (void) +{ + static int first_time = 1; + if (first_time) + { + C_Struct_Buf.ro_str = "read-only"; + first_time = 0; + } +} + +static void get_c_struct (void) +{ + check_cstruct (); + (void) SLang_push_cstruct ((VOID_STAR) &C_Struct_Buf, C_Struct); +} + +static void set_c_struct (void) +{ + SLang_free_cstruct ((VOID_STAR) &C_Struct_Buf, C_Struct); + (void) SLang_pop_cstruct ((VOID_STAR) &C_Struct_Buf, C_Struct); +} + +static void get_c_struct_via_ref (SLang_Ref_Type *r) +{ + check_cstruct (); + (void) SLang_assign_cstruct_to_ref (r, (VOID_STAR) &C_Struct_Buf, C_Struct); +} + + + +static SLang_Intrin_Fun_Type Intrinsics [] = +{ + MAKE_INTRINSIC_I("exit", c_exit, VOID_TYPE), + MAKE_INTRINSIC_1("test_char_return", test_char_return, SLANG_CHAR_TYPE, SLANG_CHAR_TYPE), + MAKE_INTRINSIC_1("test_short_return", test_short_return, SLANG_SHORT_TYPE, SLANG_SHORT_TYPE), + MAKE_INTRINSIC_1("test_int_return", test_int_return, SLANG_INT_TYPE, SLANG_INT_TYPE), + MAKE_INTRINSIC_1("test_long_return", test_long_return, SLANG_LONG_TYPE, SLANG_LONG_TYPE), + /* MAKE_INTRINSIC_1("test_float_return", test_float_return, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE), */ +#if SLANG_HAS_FLOAT + MAKE_INTRINSIC_1("test_double_return", test_double_return, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE), +#endif + MAKE_INTRINSIC_0("get_c_struct", get_c_struct, VOID_TYPE), + MAKE_INTRINSIC_0("set_c_struct", set_c_struct, VOID_TYPE), + MAKE_INTRINSIC_1("get_c_struct_via_ref", get_c_struct_via_ref, VOID_TYPE, SLANG_REF_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + + +int main (int argc, char **argv) +{ + int i; + + if (argc < 2) + { + fprintf (stderr, "Usage: %s FILE...\n", argv[0]); + return 1; + } + + if ((-1 == SLang_init_all ()) + || (-1 == SLang_init_array_extra ()) + || (-1 == SLadd_intrin_fun_table (Intrinsics, NULL))) + return 1; + + SLang_Traceback = 1; + + if (-1 == SLang_set_argc_argv (argc, argv)) + return 1; + +#ifdef HAVE_FPSETMASK +# ifndef FP_X_OFL +# define FP_X_OFL 0 +# endif +# ifndef FP_X_INV +# define FP_X_INV 0 +# endif +# ifndef FP_X_DZ +# define FP_X_DZ 0 +# endif +# ifndef FP_X_DNML +# define FP_X_DNML 0 +# endif +# ifndef FP_X_UFL +# define FP_X_UFL 0 +# endif +# ifndef FP_X_IMP +# define FP_X_IMP 0 +# endif + fpsetmask (~(FP_X_OFL|FP_X_INV|FP_X_DZ|FP_X_DNML|FP_X_UFL|FP_X_IMP)); +#endif + + if (argc > 2) + Ignore_Exit = 1; + + for (i = 1; i < argc; i++) + { + if (-1 == SLang_load_file (argv[i])) + return 1; + } + + return SLang_Error; +} + + diff --git a/libslang/src/test/sscanf.sl b/libslang/src/test/sscanf.sl new file mode 100644 index 0000000..2e588af --- /dev/null +++ b/libslang/src/test/sscanf.sl @@ -0,0 +1,182 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing sscanf ..."); + +#ifexists Double_Type +static variable eps = 1.0; +while (1 + eps/2.0 != 1) + eps /= 2.0; + +static define feqs (x, y) +{ + if (x == y) + return 1; + + % (delta_diff)^2 = (delta_y)^ + (delta_x)^2 + % delta_y = eps * y + % (delta_diff)^2 = eps*eps (y^2 + x^2) + % |delta_diff| = eps * sqrt (y^2 + x^2) ~= eps * x *sqrt(2) + variable diff = y - x; + if (x < 0) x = -x; + if (y < 0) y = -y; + if (diff < 0) diff = -diff; + variable tol = ((x + y) * eps); + + if (diff <= tol) + return 1; + vmessage ("diff = %e, abs(x)*eps = %e, error=%e", + diff, tol, diff/(x+y)); + return 1; +} + +static variable Inf = 1e1000; +static define test_atof (x) +{ + variable y; + variable str = sprintf ("%.64e", x); + variable tstr; + + tstr = strup (strtrim (str)); + + if (tstr == "INF") + y = Inf; + else if (tstr == "-INF") + y = -Inf; + else + y = atof (str); + + !if (feqs (x,y)) + failed ("%e = atof(%e [%s]): diff = %e\n", y, x, tstr, y-x); +} + +static variable _Random_Seed = 123456789UL; +static define random () +{ + _Random_Seed = (_Random_Seed * 69069UL + 1013904243UL)&0xFFFFFFFFU; + return _Random_Seed/4294967296.0; +} + +static define test_atof_main (n) +{ + + loop (n) + { + variable a,b,c; + a = 500 - random () * 1000; + b = 400 - 800 * random (); + ERROR_BLOCK + { + _clear_error (); + () = fprintf (stderr, "Floating point exception occured for %g * 10^%g\n", + a, b); + } + if (1) + { + c = a * 10.0^b; + test_atof (c); + } + } + + test_atof (random ()); +} +test_atof_main (1000); +#endif % Double_Type + +define test_scanf (buf, format, xp, yp, n) +{ + variable nn, x, y; + nn = sscanf (buf, format, &x, &y); + if (n != nn) + failed ("sscanf (%s, %s, &x, &y) ==> returned %d", + buf, format, nn); + if (n >= 1) + { + if (x != xp) + { +#ifexists Double_Type + if ((typeof (x) == Double_Type) + or (typeof (x) == Float_Type)) + { + if (1) + failed ("sscanf (%s, %s, &x, &y) ==> x = %e, diff=%e", + buf, format, x, x - xp); + } + else +#endif + failed ("sscanf (%s, %s, &x, &y) ==> x = %S", + buf, format, x); + } + } + + if (n >= 2) + { + if (y != yp) + { +#ifexists Double_Type + if ((typeof (y) == Double_Type) + or (typeof (y) == Float_Type)) + failed ("sscanf (%s, %s, &x, &y) ==> y = %e, diff=%e", + buf, format, y, y - yp); + else +#endif + failed ("sscanf (%s, %s, &x, &y) ==> y = %S", + buf, format, y); + } + } +} + +test_scanf (" -30,,XX ,,2,3", "%2hd%4s", -3, "0,,X", 2); +test_scanf ("1,2,3", "%d,%2s", 1, "2,", 2); +test_scanf ("1,2 ,3", "%d,%2s", 1, "2", 2); +test_scanf ("1,2 ,3", "%d,%20s", 1, "2", 2); +test_scanf ("1,,,,2,3", "%d,%20s", 1, ",,,2,3", 2); +test_scanf ("1, ,,,2,3", "%d,%20s", 1, ",,,2,3", 2); +test_scanf ("-30.1,,,,2,3", "%d,%2s", -30, "", 1); +test_scanf (" -30,,XX ,,2,3", "%d%4s", -30, ",,XX", 2); +test_scanf (" -30,,XX ,,2,3", "%hd%4s", -30, ",,XX", 2); +test_scanf (" -30,,XX ,,2,3", "%1hd%4s", -3, "0,,X", 0); +#ifexists Double_Type +test_scanf (" +30.173e-2,,XX ,,2,3", "%lf,,%4s", 30.173e-2, "XX", 2); +test_scanf (" -30.1,,XX ,,2,3", "%lf,,%4s", -30.1, "XX", 2); +test_scanf (" +30.1,,XX ,,2,3", "%lf,,%4s", 30.1, "XX", 2); +test_scanf (" +30.,,XX ,,2,3", "%lf,,%4s", 30.0, "XX", 2); +test_scanf (" +30.173,,XX ,,2,3", "%lf,,%4s", 30.173, "XX", 2); +test_scanf (" +30.173e+2,,XX ,,2,3", "%lf,,%4s", 30.173e2, "XX", 2); +test_scanf (" +30.173e-03,,XX ,,2,3", "%lf,,%4s", 30.173e-3, "XX", 2); +test_scanf (" +30.173E-03,,XX ,,2,3", "%lf,,%4s", 30.173e-3, "XX", 2); +test_scanf ("+.E", "%lf%lf", 0, 0, 0); +test_scanf ("+0.E", "%lf%s", 0, "E", 2); +test_scanf ("-0.E", "%lf%s", 0, "E", 2); +test_scanf ("-0.E-", "%lf%s", 0, "E-", 2); +test_scanf ("-0.E+", "%lf%s", 0, "E+", 2); +test_scanf ("-0.E+X", "%lf%s", 0, "E+X", 2); +test_scanf ("-1.E+0X", "%lf%s", -1, "X", 2); +test_scanf ("-0+X", "%lf%s", 0, "+X", 2); +test_scanf ("0+X", "%lf%s", 0, "+X", 2); +test_scanf ("0.000000000000E00+X", "%lf%s", 0, "+X", 2); +test_scanf ("1.000000000000E000000001+X", "%lf%s", 10, "+X", 2); +#endif + +test_scanf (" hello world", "%s%s", "hello", "world", 2); +test_scanf (" hello world", "%s%c", "hello", ' ', 2); +test_scanf (" hello world", "%s%2c", "hello", " w", 2); +test_scanf (" hello world", "%s%5c", "hello", " worl", 2); +test_scanf (" hello world", "%s%6c", "hello", " world", 2); +test_scanf (" hello world", "%s%7c", "hello", " world", 2); +test_scanf (" hello world", "%s%1000c", "hello", " world", 2); + +test_scanf (" hello world", "%*s%c%1000c", ' ', "world", 2); + +test_scanf ("abcdefghijk", "%[a-c]%s", "abc", "defghijk", 2); +test_scanf ("abcdefghijk", "%4[a-z]%s", "abcd", "efghijk", 2); +test_scanf ("ab[-]cdefghijk", "%4[]ab]%s", "ab", "[-]cdefghijk", 2); +test_scanf ("ab[-]cdefghijk", "%40[][ab-]%s", "ab[-]", "cdefghijk", 2); +test_scanf ("ab12345cdefghijk", "ab%[^1-9]%s", "", "12345cdefghijk", 2); +test_scanf ("ab12345cdefghijk", "ab%3[^4-5]%s", "123", "45cdefghijk", 2); + +print ("Ok\n"); + +exit (0); + + + diff --git a/libslang/src/test/stdio.sl b/libslang/src/test/stdio.sl new file mode 100644 index 0000000..470bd6f --- /dev/null +++ b/libslang/src/test/stdio.sl @@ -0,0 +1,180 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + + +print ("Testing stdio routines..."); + +define fopen_tmp_file (fileptr, mode) +{ + variable n; + variable file, fp; + variable fmt; + + @fileptr = NULL; + + fmt = "tmp-xxx.%03d"; % I need something that works on an 8+3 filesystem + + n = -1; + while (n < 999) + { + n++; + file = sprintf (fmt, n); + if (NULL != stat_file (file)) + continue; + + fp = fopen (file, mode); + if (fp != NULL) + { + @fileptr = file; + return fp; + } + } + failed ("Unable to open a tmp file"); +} + +define run_tests (some_text, read_fun, write_fun, length_fun) +{ + variable file, fp; + variable new_text, nbytes, len; + variable pos; + + fp = fopen_tmp_file (&file, "wb"); + + if (-1 == @write_fun (some_text, fp)) + failed (string (write_fun)); + + if (-1 == fclose (fp)) + failed ("fclose"); + + fp = fopen (file, "rb"); + if (fp == NULL) failed ("fopen existing"); + + len = @length_fun (some_text); + nbytes = @read_fun (&new_text, len, fp); + + if ((nbytes != len) + or (some_text != new_text)) + failed (string (read_fun)); + + if (-1 != @read_fun (&new_text, 1, fp)) + failed (string (read_fun) + " at EOF"); + + if (0 == feof (fp)) failed ("feof"); + + clearerr (fp); + if (feof (fp)) failed ("clearerr"); + + if (0 != fseek (fp, 0, SEEK_SET)) failed ("fseek"); + + nbytes = @read_fun (&new_text, len, fp); + + if ((nbytes != len) + or (some_text != new_text)) + failed (string (read_fun) + " after fseek"); + + + pos = ftell (fp); + if (pos == -1) failed ("ftell at EOF"); + + if (0 != fseek (fp, 0, SEEK_SET)) failed ("fseek"); + if (0 != ftell (fp)) failed ("ftell at BOF"); + if (0 != fseek (fp, pos, SEEK_CUR)) failed ("fseek to pos"); + + if (pos != ftell (fp)) failed ("ftell after fseek to pos"); + + if (feof (fp) != 0) failed ("feof after fseek to EOF"); + + () = fseek (fp, 0, SEEK_SET); + nbytes = fread (&new_text, Char_Type, 0, fp); + if (nbytes != 0) + failed ("fread for 0 bytes"); + + nbytes = fread (&new_text, Char_Type, len + 100, fp); + if (nbytes != len) + failed ("fread for 100 extra bytes"); + + if (-1 == fclose (fp)) failed ("fclose after tests"); + () = remove (file); + if (stat_file (file) != NULL) failed ("remove"); +} + +static define do_fgets (addr, nbytes, fp) +{ + return fgets (addr, fp); +} + +static define do_fread (addr, nbytes, fp) +{ + return fread (addr, UChar_Type, nbytes, fp); +} + +run_tests ("ABCDEFG", &do_fgets, &fputs, &strlen); +run_tests ("A\000BC\000\n\n\n", &do_fread, &fwrite, &bstrlen); + +define test_fread_fwrite (x) +{ + variable fp, file, str, n, m, y, type, ch; + + fp = fopen_tmp_file (&file, "w+b"); + + type = _typeof(x); + n = length (x); + if ((type == String_Type) or (type == BString_Type)) + { + type = UChar_Type; + n = bstrlen (x); + } + + if (n != fwrite (x, fp)) + failed ("test_fread_fwrite: fwrite"); + + if (-1 == fseek (fp, 0, SEEK_SET)) + failed ("test_fread_fwrite: fseek"); + + if (n != fread (&y, type, n, fp)) + failed ("test_fread_fwrite: fread"); + + if (length (where (y != x))) + failed ("test_fread_fwrite: fread failed to return: " + string(x)); + + if (-1 == fseek (fp, 0, SEEK_SET)) + failed ("test_fread_fwrite: fseek"); + + if (type == UChar_Type) + { + y = 0; + foreach (fp) using ("char") + { + ch = (); + if (ch != x[y]) + failed ("foreach using char: %S != %S", ch, x[y]); + y++; + } + if (y != n) + failed ("foreach using char 2"); + } + + () = fclose (fp); + + if (-1 == remove (file)) + failed ("remove:" + errno_string(errno)); + if (stat_file (file) != NULL) failed ("remove"); +} + +test_fread_fwrite (""); +test_fread_fwrite ("hello"); +test_fread_fwrite ("hel\0\0lo"); +test_fread_fwrite (Integer_Type[0]); +test_fread_fwrite ([1:10]); +#ifexists Double_Type +test_fread_fwrite (3.17); +test_fread_fwrite ([1:10:0.01]); +#endif +#ifexists Complex_Type +test_fread_fwrite (Complex_Type[50] + 3 + 2i); +test_fread_fwrite (2i+3); +test_fread_fwrite ([2i+3, 7i+1]); +#endif + +print ("Ok\n"); + +exit (0); diff --git a/libslang/src/test/strops.sl b/libslang/src/test/strops.sl new file mode 100644 index 0000000..8669ba3 --- /dev/null +++ b/libslang/src/test/strops.sl @@ -0,0 +1,153 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing string functions..."); + +variable s; + +s = strcompress (" \t \tA\n\ntest\t", " \t\n"); +if (s != "A test") failed ("strcompress"); + +s = " \t hello world\n\t"; +if ("hello world" != strtrim (s)) failed ("strtrim"); +if ("hello world\n\t" != strtrim_beg (s)) failed ("strtrim_beg"); +if (" \t hello world" != strtrim_end (s)) failed ("strtrim_beg"); + +if ("hello wor" != strtrim (s, " \t\nld")) failed ("strtrim with whitespace"); + +if ("" != strcat ("", "")) + failed ("strcat 0"); +if ("1" != strcat ("", "1")) + failed ("strcat 1"); + +if ("abcdefg" != strcat ("a", "b", "c", "d", "e", "f", "g")) failed ("strcat"); +if ("abcdefg" != strcat ("abcdefg")) failed ("strcat 2"); + +if ((strtok (s)[0] != "hello") + or (strtok(s)[1] != "world") + or (strtok (s, "^a-z")[0] != "hello") + or (strtok (s, "^a-z")[1] != "world") + or (2 != length (strtok (s))) + or (2 != length (strtok (s, "^a-z")))) failed ("strtok"); + +define test_create_delimited_string () +{ + variable n = (); + variable args = __pop_args (_NARGS - 3); + variable delim = (); + variable eresult = (); + variable result; + + result = create_delimited_string (delim, __push_args (args), n); + if (eresult != result) + failed ("create_delimited_string: expected: %s, got: %s", + eresult, result); + + if (n) + result = strjoin ([__push_args (args)], delim); + else + result = strjoin (String_Type[0], delim); + + if (eresult != result) + failed ("strjoin: expected: %s, got: %s", + eresult, result); +} + + +test_create_delimited_string ("aXXbXXcXXdXXe", + "XX", + "a", "b", "c", "d", "e", + 5); + + +test_create_delimited_string ("", "", "", 1); +test_create_delimited_string ("a", ",", "a", 1); +test_create_delimited_string (",", ",", "", "", 2); +test_create_delimited_string (",,", ",", "", "", "", 3); +test_create_delimited_string ("", "XXX", 0); + +static define test_strtrans (s, from, to, ans) +{ + variable s1 = strtrans (s, from, to); + if (ans != s1) + failed ("strtrans(%s, %s, %s) --> %s", s, from, to, s1); +} + +test_strtrans ("hello world", "^a-zA-Z", "X", "helloXworld"); +test_strtrans ("hello", "", "xxxx", "hello"); +test_strtrans ("hello", "l", "", "heo"); +test_strtrans ("hello", "helo", "abcd", "abccd"); +test_strtrans ("hello", "hl", "X", "XeXXo"); +test_strtrans ("", "hl", "X", ""); +test_strtrans ("hello", "a-z", "A-Z", "HELLO"); +test_strtrans ("hello", "a-mn-z", "A-MN-Z", "HELLO"); +test_strtrans ("abcdefg", "a-z", "Z-A", "ZYXWVUT"); +test_strtrans ("hejklo", "k-l", "L-L---", "hejL-o"); +test_strtrans ("hello", "he", "-+", "-+llo"); +test_strtrans ("hello", "", "", "hello"); +test_strtrans ("hello", "helo", "", ""); +test_strtrans ("hello", "o", "", "hell"); +test_strtrans ("hello", "hlo", "", "e"); +test_strtrans ("", "hlo", "", ""); +test_strtrans ("HeLLo", "A-Ze", "", "o"); +test_strtrans ("HeLLo", "^A-Z", "", "HLL"); + +define test_str_replace (a, b, c, result, n) +{ + variable new; + variable m; + + (new, m) = strreplace (a, b, c, n); + + if (new != result) + failed ("strreplace (%s, %s, %s, %d) ==> %s", a, b, c, n, new); + + if (n == 1) + { + n = str_replace (a, b, c); + !if (n) a; + new = (); + if (new != result) + failed ("str_replace (%s, %s, %s) ==> %s", a, b, c, new); + } +} + +test_str_replace ("a", "b", "x", "a", 1); +test_str_replace ("a", "b", "x", "a", -1); +test_str_replace ("a", "b", "x", "a", -10); +test_str_replace ("a", "b", "x", "a", 10); +test_str_replace ("a", "b", "x", "a", 0); +test_str_replace ("blafoofbarfoobar", "", "xyyy", "blafoofbarfoobar", 0); +test_str_replace ("blafoofbarfoobar", "", "xyyy", "blafoofbarfoobar", 1); +test_str_replace ("blafoofbarfoobar", "", "xyyy", "blafoofbarfoobar", -1); +test_str_replace ("blafoofbarfoobar", "", "xyyy", "blafoofbarfoobar", -10); + +test_str_replace ("blafoofbarfoobar", "foo", "XY", "blafoofbarfoobar", 0); +test_str_replace ("blafoofbarfoobar", "foo", "XY", "blaXYfbarfoobar", 1); +test_str_replace ("blafoofbarfoobar", "foo", "XY", "blaXYfbarXYbar", 2); +test_str_replace ("blafoofbarfoobar", "foo", "XY", "blaXYfbarXYbar", 10); +test_str_replace ("blafoofbarfoobar", "foo", "XY", "blafoofbarXYbar", -1); +test_str_replace ("blafoofbarfoobar", "foo", "XY", "blaXYfbarXYbar", -2); +test_str_replace ("blafoofbarfoobar", "r", "", "blafoofbarfoobar", 0); +test_str_replace ("blafoofbarfoobar", "r", "", "blafoofbafoobar", 1); +test_str_replace ("blafoofbarfoobar", "r", "", "blafoofbafooba", 2); +test_str_replace ("blafoofbarfoobar", "r", "", "blafoofbarfooba", -1); +test_str_replace ("blafoofbarfoobar", "r", "", "blafoofbafooba", -2); +test_str_replace ("bla", "bla", "", "", -2); +test_str_replace ("bla", "bla", "foo", "foo", -2); +test_str_replace ("bla", "bla", "foo", "foo", 1); + +define test_strcat () +{ + % This test generates a combined byte-code. It is used for leak checking + variable a = "hello"; + variable b = "world"; + loop (20) + { + variable c = a + b; + a = c; + } +} + + +print ("Ok\n"); +exit (0); diff --git a/libslang/src/test/struct.sl b/libslang/src/test/struct.sl new file mode 100644 index 0000000..003f3e7 --- /dev/null +++ b/libslang/src/test/struct.sl @@ -0,0 +1,144 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing structures ..."); + +variable S = struct +{ + a, b, c +}; + +S.a = "a"; +S.b = "b"; +S.c = "c"; + +variable U = @Struct_Type ("a", "b", "c"); +variable abc = get_struct_field_names (U); +if ((abc[0] != "a") + or (abc[1] != "b") + or (abc[2] != "c")) + failed ("@Struct_Type"); + +abc = ["a", "b", "c"]; +U = @Struct_Type (abc); +if (length (where (abc != get_struct_field_names (U)))) + failed ("@Struct_Type([abc])"); + +variable T = @S; + +if (S.a != T.a) failed ("Unable to copy via @S"); +if (S.b != T.b) failed ("Unable to copy via @S"); +if (S.c != T.c) failed ("Unable to copy via @S"); + +T.a = "XXX"; +if (T.a == S.a) failed ("Unable to copy via @S"); + +set_struct_fields (T, 1, 2, "three"); +if ((T.c != "three") or (T.a != 1) or (T.b != 2)) + failed ("set_struct_fields"); + +T.a++; +T.a += 3; +T.a -= 20; +if (T.a != -15) + failed ("structure arithmetic"); + +T.c = S; +S.a = T; + +if (T != T.c.a) + failed ("Unable to create a circular list"); + +typedef struct +{ + TT_x, TT_y +} +TT; + +T = @TT; +if (typeof (T) != TT) + failed ("typeof(T)"); +if (0 == is_struct_type (T)) + failed ("is_struct_type"); +S = typecast (T, Struct_Type); +if (typeof (S) != Struct_Type) + failed ("typecast"); + +% C structures + +S = get_c_struct (); +if ((typeof (S.h) != Short_Type) + or (typeof (S.l) != Long_Type) + or (typeof (S.b) != Char_Type)) + failed ("get_c_struct field types"); + +static define print_struct(s) +{ + foreach (get_struct_field_names (s)) + { + variable f = (); + vmessage ("S.%s = %S", f, get_struct_field (s, f)); + } +} + + +#ifexists Complex_Type +S.z = 1+2i; +#endif +S.a = [1:10]; +#ifexists Double_Type +S.d = PI; +#endif +S.s = "foobar"; +S.ro_str = "FOO"; + +loop (10) + set_c_struct (S); + +loop (10) + T = get_c_struct (); + +%print_struct (T); + +if ((not __eqs(S.a, T.a)) +#ifexists Complex_Type + or (S.z != T.z) +#endif +#ifexists Double_Type + or (S.d != T.d) +#endif + or (T.ro_str != "read-only")) + failed ("C Struct"); + +loop (10) + get_c_struct_via_ref (&T); + +%print_struct (T); + +if ((not __eqs(S.a, T.a)) +#ifexists Complex_Type + or (S.z != T.z) +#endif +#ifexists Double_Type + or (S.d != T.d) +#endif + or (T.ro_str != "read-only")) + failed ("C Struct"); + +static define count_args () +{ + if (_NARGS != 0) + failed ("foreach using with NULL"); +} +static define test_foreach_using_with_null (s) +{ + foreach (s) using ("next") + { + s = (); + } + count_args (); +} +test_foreach_using_with_null (NULL); +print ("Ok\n"); + +exit (0); + diff --git a/libslang/src/test/syntax.sl b/libslang/src/test/syntax.sl new file mode 100644 index 0000000..6321eb9 --- /dev/null +++ b/libslang/src/test/syntax.sl @@ -0,0 +1,142 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing syntax ..."); + +if (0x12 != test_char_return (0x12)) failed ("test_char_return"); +if (0x1234h != test_short_return (0x1234h)) failed ("test_short_return"); +if (0x1234 != test_int_return (0x1234)) failed ("test_int_return"); +if (0x12345678L != test_long_return (0x12345678L)) failed ("test_long_return"); +% if (1.2e34f != test_float_return (1.2e34f)) failed ("test_float_return"); +#ifexists Double_Type +if (1.2e34 != test_double_return (1.2e34)) failed ("test_double_return"); +#endif + +static define static_xxx () +{ + return "xxx"; +} + +private define private_yyy () +{ + return "yyy"; +} + +public define public_zzz () +{ + return "zzz"; +} + +if (is_defined ("static_xxx") or "xxx" != static_xxx ()) + failed ("static_xxx"); +if (is_defined ("private_yyy") or "yyy" != private_yyy ()) + failed ("private_yyy"); +if (not is_defined ("public_zzz") or "zzz" != public_zzz ()) + failed ("public_xxx"); + +variable XXX = 1; +static define xxx () +{ + variable XXX = 2; + if (XXX != 2) failed ("local variable XXX"); +} + +xxx (); +if (XXX != 1) failed ("global variable XXX"); +if (1) +{ + if (orelse + {0} + {0} + {0} + {0} + ) + failed ("orelse"); +} + + +!if (orelse + {0} + {0} + {0} + {1}) failed ("not orelse"); + +_auto_declare = 1; +XXX_auto_declared = 1; + +if (&XXX_auto_declared != __get_reference ("XXX_auto_declared")) + failed ("__get_reference"); + +if (0 == __is_initialized (&XXX_auto_declared)) + failed ("__is_initialized"); +() = __tmp (XXX_auto_declared); +if (__is_initialized (&XXX_auto_declared)) + failed ("__is_initialized __tmp"); +XXX_auto_declared = "xxx"; +__uninitialize (&XXX_auto_declared); +if (__is_initialized (&XXX_auto_declared)) + failed ("__is_initialized __uninitialize"); + +static define test_uninitialize () +{ + variable x; + if (__is_initialized (&x)) + failed ("__is_initialized x"); + x = 3; + !if (__is_initialized (&x)) + failed ("__is_initialized x=3"); + if (3 != __tmp (x)) + failed ("__tmp return value"); + if (__is_initialized (&x)) + failed ("__tmp x"); + x = 4; + __uninitialize (&x); + if (__is_initialized (&x)) + failed ("__uninitialize x"); +} + +test_uninitialize (); + +static define check_args (n) +{ + if (n + 1 != _NARGS) + failed ("check_args %d", n); + _pop_n (_NARGS-1); +} + +static define nitems (n) +{ + loop (n) 1; +} + +check_args (1, 1); +check_args (1,2,2); +check_args (nitems(3), nitems(5), 8); +static variable X = [1:10]; +% X[3]++ produces nothing +check_args (nitems (3), check_args(nitems(4), X[3]++, 4, X[3]+=X[2], 5), 3); + +static define check_no_args () +{ + if (_NARGS != 0) + failed ("check_no_args"); +} + +% This failed in previous versions because abs was not treated as a function +% call. +if (abs (1) > 0) + check_no_args (); + +define check_tmp_optim () +{ + variable a = [1:10:1.0]; + variable b = a*0.0; + if ((a[0] != 1.0) or (__eqs(a,b))) + failed ("__tmp optimization: a[0] = %f", a[0]); +} + +check_tmp_optim (); + +print ("Ok\n"); + +exit (0); + diff --git a/libslang/src/test/template.sl b/libslang/src/test/template.sl new file mode 100644 index 0000000..f63c750 --- /dev/null +++ b/libslang/src/test/template.sl @@ -0,0 +1,10 @@ +_debug_info = 1; () = evalfile ("inc.sl"); + +print ("Testing XXXXX ..."); + +% Tests go here.... + +print ("Ok\n"); + +exit (0); + diff --git a/libslang/src/untic.c b/libslang/src/untic.c new file mode 100644 index 0000000..418ce3b --- /dev/null +++ b/libslang/src/untic.c @@ -0,0 +1,90 @@ +#define SLANG_UNTIC +char *SLang_Untic_Terminfo_File; +#include "sltermin.c" + +static void usage (void) +{ + fprintf (stderr, "Usage: untic [[--terminfo filename] | [term]]\n"); + exit (1); +} + +int main (int argc, char **argv) +{ + SLterminfo_Type *t; + Tgetstr_Map_Type *map = Tgetstr_Map; + unsigned char *str; + char *term; + + term = getenv ("TERM"); + if (argc > 1) + { + if (!strcmp ("--help", argv[1])) usage (); + if (argc == 2) + term = argv[1]; + else if ((argc == 3) && !strcmp(argv[1], "--terminfo")) + { + SLang_Untic_Terminfo_File = argv[2]; + } + else usage (); + } + else if (term == NULL) return -1; + + SLtt_Try_Termcap = 0; + t = _SLtt_tigetent (term); + if (t == NULL) return -1; + + puts (t->terminal_names); + while (*map->name != 0) + { + str = (unsigned char *) SLtt_tigetstr (map->name, (char **) &t); + if (str == NULL) + { + map++; + continue; + /* str = (unsigned char *) "NULL"; */ + } + + fprintf (stdout, "\t%s=", map->name); + while (*str) + { + if ((int) (*str & 0x7F) < ' ') + { + putc ('^', stdout); + *str += '@'; + } + putc (*str, stdout); + str++; + } + if (map->comment != NULL) + fprintf (stdout, "\t\t%s", map->comment); + putc ('\n', stdout); + map++; + } + + map = Tgetflag_Map; + while (*map->name != 0) + { + if (_SLtt_tigetflag (t, map->name) > 0) + { + fprintf (stdout, "\t%s\t\t%s\n", + map->name, + ((map->comment == NULL) ? "" : map->comment)); + } + map++; + } + map = Tgetnum_Map; + while (*map->name != 0) + { + int val; + if ((val = SLtt_tigetnum (map->name, (char **) &t)) >= 0) + { + fprintf (stdout, "\t%s#%d\t\t%s\n", + map->name, val, + ((map->comment == NULL) ? "" : map->comment)); + } + map++; + } + + return 0; +} + diff --git a/libslang/src/util/bcdump.c b/libslang/src/util/bcdump.c new file mode 100644 index 0000000..04c64e4 --- /dev/null +++ b/libslang/src/util/bcdump.c @@ -0,0 +1,457 @@ +#include +#include +#include "sl-feat.h" +#include "slang.h" +#include "_slang.h" + +static void dump_token (_SLang_Token_Type *t) +{ + char buf [256], *b; + + b = buf; + + if (SLang_Error) + return; + + switch (t->type) + { + case IDENT_TOKEN: + b = t->v.s_val; + break; + + case CHAR_TOKEN: + case INT_TOKEN: + sprintf (buf, "%ld", t->v.long_val); + break; + + case DOUBLE_TOKEN: + b = t->v.s_val; + break; + + case STRING_TOKEN: + sprintf (buf, "\"%s\"", t->v.s_val); + break; + + case PLUSPLUS_TOKEN: + sprintf (buf, "++%s", t->v.s_val); + break; + + case POST_PLUSPLUS_TOKEN: + sprintf (buf, "%s++", t->v.s_val); + break; + + case MINUSMINUS_TOKEN: + sprintf (buf, "--%s", t->v.s_val); + break; + + case POST_MINUSMINUS_TOKEN: + sprintf (buf, "%s--", t->v.s_val); + break; + + case MINUSEQS_TOKEN: + sprintf (buf, "-=%s", t->v.s_val); + break; + + case PLUSEQS_TOKEN: + sprintf (buf, "+=%s", t->v.s_val); + break; + + case ASSIGN_TOKEN: + sprintf (buf, "=%s", t->v.s_val); + break; + + case EOF_TOKEN: + b = "EOF_TOKEN"; + break; + + case NOP_TOKEN: + b = "NOP_TOKEN"; + break; + + case FOREVER_TOKEN: + b = "forever"; + break; + + case ARG_TOKEN: + b = "__args"; + break; + + case EARG_TOKEN: + b = "__eargs"; + break; + + case FARG_TOKEN: + b = "__farg"; + break; + + case _INLINE_ARRAY_TOKEN: + b = "__inline_array"; + break; + + case _INLINE_IMPLICIT_ARRAY_TOKEN: + b = "__inline_implicit_array"; + break; + + case IFNOT_TOKEN: + b = "!if"; + break; + + case ABS_TOKEN: + b = "abs"; + break; + + case LT_TOKEN: + b = "<"; + break; + + case LE_TOKEN: + b = "<="; + break; + + case GT_TOKEN: + b = ">"; + break; + + case GE_TOKEN: + b = ">="; + break; + + case EQ_TOKEN: + b = "=="; + break; + + case NE_TOKEN: + b = "!="; + break; + + case AND_TOKEN: + b = "and"; + break; + + case IF_TOKEN: + b = "if"; + break; + + case POP_TOKEN: + b = "pop"; + break; + + case ANDELSE_TOKEN: + b = "andelse"; + break; + + case BXOR_TOKEN: + b = "xor"; + break; + + case BAND_TOKEN: + b = "&"; + break; + + case BOR_TOKEN: + b = "|"; + break; + + case BNOT_TOKEN: + b = "~"; + break; + + case SHR_TOKEN: + b = "shr"; + break; + + case CHS_TOKEN: + b = "chs"; + break; + + case SHL_TOKEN: + b = "shl"; + break; + + case SQR_TOKEN: + b = "sqr"; + break; + + case CASE_TOKEN: + b = "case"; + break; + + case SIGN_TOKEN: + b = "sign"; + break; + + case BREAK_TOKEN: + b = "break"; + break; + + case STATIC_TOKEN: + b = "static"; + break; + + case STRUCT_TOKEN: + b = "struct"; + break; + + case RETURN_TOKEN: + b = "return"; + break; + + case SWITCH_TOKEN: + b = "switch"; + break; + + case EXCH_TOKEN: + b = "exch"; + break; + + case CONT_TOKEN: + b = "continue"; + break; + + case EXITBLK_TOKEN: + b = "EXIT_BLOCK"; + break; + + case ERRBLK_TOKEN: + b = "ERROR_BLOCK"; + break; + + case USRBLK0_TOKEN: + b = "USER_BLOCK0"; + break; + + case USRBLK1_TOKEN: + b = "USER_BLOCK1"; + break; + + case USRBLK2_TOKEN: + b = "USER_BLOCK2"; + break; + + case USRBLK3_TOKEN: + b = "USER_BLOCK3"; + break; + + case USRBLK4_TOKEN: + b = "USER_BLOCK4"; + break; + + case ELSE_TOKEN: + b = "else"; + break; + + case MUL2_TOKEN: + b = "mul2"; + break; + + case DEFINE_TOKEN: + b = ")"; + break; + + case DEFINE_STATIC_TOKEN: + b = ")static"; + break; + + case LOOP_TOKEN: + b = "loop"; + break; + + case MOD_TOKEN: + b = "mod"; + break; + + case DO_TOKEN: + b = "do"; + break; + + case DOWHILE_TOKEN: + b = "do_while"; + break; + + case WHILE_TOKEN: + b = "while"; + break; + + case OR_TOKEN: + b = "or"; + break; + + case VARIABLE_TOKEN: + b = "variable"; + break; + + case _SCALAR_ASSIGN_TOKEN: + sprintf (buf, "=%s", t->v.s_val); + break; + + case _SCALAR_PLUSEQS_TOKEN: + sprintf (buf, "+=%s", t->v.s_val); + break; + + case _SCALAR_MINUSEQS_TOKEN: + sprintf (buf, "-=%s", t->v.s_val); + break; + + case _SCALAR_PLUSPLUS_TOKEN: + sprintf (buf, "++%s", t->v.s_val); + break; + + case _SCALAR_POST_PLUSPLUS_TOKEN: + sprintf (buf, "%s++", t->v.s_val); + break; + + case _SCALAR_MINUSMINUS_TOKEN: + sprintf (buf, "--%s", t->v.s_val); + break; + + case _SCALAR_POST_MINUSMINUS_TOKEN: + sprintf (buf, "%s--", t->v.s_val); + break; + + case _DEREF_ASSIGN_TOKEN: + sprintf (buf, "=@%s", t->v.s_val); + break; + + case _REF_TOKEN: + sprintf (buf, "%s __ref", t->v.s_val); + break; + + case ORELSE_TOKEN: + b = "orelse"; + break; + + case _FOR_TOKEN: + b = "_for"; + break; + + case FOR_TOKEN: + b = "for"; + break; + + case NOT_TOKEN: + b = "not"; + break; + + case OBRACKET_TOKEN: + b = "["; + break; + + case CBRACKET_TOKEN: + b = "]"; + break; + + case OPAREN_TOKEN: + b = "("; + break; + + case CPAREN_TOKEN: + b = ")"; + break; + + case OBRACE_TOKEN: + b = "{"; + break; + + case CBRACE_TOKEN: + b = "}"; + break; + + case DEREF_TOKEN: + b = "@"; + break; + + case COMMA_TOKEN: + b = ","; + break; + + case SEMICOLON_TOKEN: + b = ";"; + break; + + case COLON_TOKEN: + b = ":"; + break; + + case ADD_TOKEN: + b = "+"; + break; + + case SUB_TOKEN: + b = "-"; + break; + + /* case MUL_TOKEN: */ + /* b = "*"; */ + /* break; */ + + case DIV_TOKEN: + b = "/"; + break; + + case ARRAY_TOKEN: + b = "__aget"; + break; + + case _ARRAY_ASSIGN_TOKEN: + b = "__aput"; + break; + + case DOT_TOKEN: + sprintf (buf, "%s .", t->v.s_val); + break; + + case METHOD_TOKEN: + sprintf (buf, "%s __eargs __method_call", t->v.s_val); + break; + + case _STRUCT_ASSIGN_TOKEN: + b = "__struct_eqs"; break; + case _STRUCT_PLUSEQS_TOKEN: + b = "__struct_pluseqs"; break; + case _STRUCT_MINUSEQS_TOKEN: + b = "__struct_minuseqs"; break; + case _STRUCT_PLUSPLUS_TOKEN: + b = "__struct_plusplus"; break; + case _STRUCT_POST_PLUSPLUS_TOKEN: + b = "__struct_pplusplus"; break; + case _STRUCT_MINUSMINUS_TOKEN: + b = "__struct_minusminus"; break; + case _STRUCT_POST_MINUSMINUS_TOKEN: + b = "__struct_pminusminus"; break; + + case _NULL_TOKEN: b = "NULL"; break; + + case USING_TOKEN: + b = "__using__"; break; + case FOREACH_TOKEN: + b = "__foreach__"; break; + + default: + sprintf (buf, "____UNKNOWN___0x%X", t->type); + break; + } + + fprintf (stdout, "0x%2X: %s\n", t->type, b); +} + + +int main (int argc, char **argv) +{ + char *file; + + if (argc == 2) + { + /* fprintf (stderr, "Usage: %s \n", argv[0]); */ + file = argv[1]; + /* return 1; */ + } + else file = NULL; + + if (-1 == SLang_init_slang ()) + return 1; + + _SLcompile_ptr = dump_token; + SLang_load_file (file); + + return SLang_Error; +} diff --git a/libslang/src/util/chkproto.c b/libslang/src/util/chkproto.c new file mode 100644 index 0000000..d4a6e23 --- /dev/null +++ b/libslang/src/util/chkproto.c @@ -0,0 +1,225 @@ +#include +#include +#include +#include + +static char *Make_Intrinsic_Forms [] = +{ + "0", + "I", + "S", + "II", + "SS", + "SI", + "IS", + "III", + "IIS", + "ISI", + "ISS", + "SII", + "SIS", + "SSI", + "SSS", + "IIII", + "SSSS", + NULL +}; + + +static char *output_start (FILE *fp) +{ + char **form; + + form = Make_Intrinsic_Forms; + + while (*form != NULL) + { + char *r = "0ISD"; + char *f; + + while (*r != 0) + { + switch (*r) + { + case '0': + fprintf (fp, "static void (*V_F"); + break; + + case 'I': + fprintf (fp, "static int (*I_F"); + break; + + case 'S': + fprintf (fp, "static char *(*S_F"); + break; + + case 'D': + fprintf (fp, "static double (*D_F"); + break; + } + + f = *form; + fprintf (fp, "%s)(", f); + while (*f != 0) + { + if (f != *form) fputc (',', fp); + switch (*f) + { + case 'I': + fputs ("int*", fp); + break; + + case 'S': + fputs ("char*", fp); + break; + + case '0': + fputs ("void", fp); + break; + } + f++; + } + fputs (");\n", fp); + + r++; + } + form++; + } + + fputs ("\n", fp); + + fprintf (fp, "static void chkproto_not_used_fun (void)\n{\n"); + + return 0; +} + +static void output_finish (FILE *fp) +{ + fputs ("\n}\n", fp); +} + + +static char *skip_whitespace (char *p) +{ + while ((*p == ' ') || (*p == '\t') || (*p == '\n')) + p++; + + return p; +} + +static int do_make_intrinsic (unsigned int linenum, char *p) +{ + char *e; + char *name; + int ret_type; + + e = p; + while (*e && (*e != ' ') && (*e != '\t') && (*e != '(')) + e++; + + if (*e == 0) + { + return -1; + } + *e++ = 0; + + /* We expect form: IIS("name", function_name, RETURN_TYPE) */ + while (*e && (*e != ',')) e++; + if (*e == 0) + { + return -1; + } + e = skip_whitespace (e + 1); + name = e; + if (*name == 0) + { + return -1; + } + while (*e && (*e != ',')) e++; + if (*e == 0) + { + return -1; + } + *e = 0; + + e = skip_whitespace (e + 1); + if (0 == strncmp (e, "SLANG_", 6)) + e += 6; + + if (0 == strncmp (e, "VOID_TYPE", 8)) + ret_type = 'V'; + else if (0 == strncmp (e, "STRING_TYPE", 11)) + ret_type = 'S'; + else if (0 == strncmp (e, "INT_TYPE", 8)) + ret_type = 'I'; + else if (0 == strncmp (e, "DOUBLE_TYPE", 8)) + ret_type = 'D'; + else + { + fprintf (stderr, "return type on line %u is not supported\n", linenum); + return -1; + } + + fprintf (stdout, " %c_F%s = %s;\n", ret_type, p, name); + return 0; +} + + +int main (int argc, char **argv) +{ + char line [1024]; + FILE *fp; + unsigned int linenum; + + if (isatty (0) + || (argc > 1)) + { + fprintf (stderr, "Usage: %s < infile > outfile\n", argv[0]); + exit (1); + } + + output_start (stdout); + + fp = stdin; + + linenum = 0; + while (NULL != fgets (line, sizeof (line), fp)) + { + char *p = skip_whitespace (line); + + linenum++; + + if (*p != 'M') continue; + + if (0 != strncmp (p, "MAKE_INTRINSIC", 14)) + continue; + + if (p[14] != '_') + { + fprintf (stderr, "Warning: line %u is old-fashioned\n", linenum); + continue; + } + + p += 15; + + switch (*p) + { + case 'I': + case 'S': + case '0': + do_make_intrinsic (linenum, p); + break; + + default: + fprintf (stderr, "Warning: Unable to handle MAKE_INTRINSIC form on line %u\n", + linenum); + break; + } + } + + output_finish (stdout); + return 0; +} + + + diff --git a/libslang/src/util/keywords.lis b/libslang/src/util/keywords.lis new file mode 100644 index 0000000..b794a59 --- /dev/null +++ b/libslang/src/util/keywords.lis @@ -0,0 +1,73 @@ +!if IFNOT_TOKEN +ERROR_BLOCK ERRBLK_TOKEN +EXIT_BLOCK EXITBLK_TOKEN +USER_BLOCK0 USRBLK0_TOKEN +USER_BLOCK1 USRBLK1_TOKEN +USER_BLOCK2 USRBLK2_TOKEN +USER_BLOCK3 USRBLK3_TOKEN +USER_BLOCK4 USRBLK4_TOKEN +__tmp TMP_TOKEN +_for _FOR_TOKEN +abs ABS_TOKEN +and AND_TOKEN +andelse ANDELSE_TOKEN +break BREAK_TOKEN +case CASE_TOKEN +chs CHS_TOKEN +continue CONT_TOKEN +define DEFINE_TOKEN +do DO_TOKEN +do_while DOWHILE_TOKEN +else ELSE_TOKEN +exch EXCH_TOKEN +for FOR_TOKEN +foreach FOREACH_TOKEN +forever FOREVER_TOKEN +if IF_TOKEN +loop LOOP_TOKEN +mod MOD_TOKEN +mul2 MUL2_TOKEN +not NOT_TOKEN +or OR_TOKEN +orelse ORELSE_TOKEN +pop POP_TOKEN +private PRIVATE_TOKEN +public PUBLIC_TOKEN +return RETURN_TOKEN +shl SHL_TOKEN +shr SHR_TOKEN +sign SIGN_TOKEN +sqr SQR_TOKEN +static STATIC_TOKEN +struct STRUCT_TOKEN +switch SWITCH_TOKEN +typedef TYPEDEF_TOKEN +using USING_TOKEN +variable VARIABLE_TOKEN +while WHILE_TOKEN +xor BXOR_TOKEN +% +% The kewords below here are commented out because they are not +% used. Most of them could be used if one wanted to write in RPN form +% but I want to discontinue it +% +%push PUSH_TOKEN +%readonly READONLY_TOKEN +%__ref _REF_TOKEN +%__aput _ARRAY_ASSIGN_TOKEN +%__aput_minuseqs _ARRAY_MINUSEQS_TOKEN +%__aput_minusminus _ARRAY_MINUSMINUS_TOKEN +%__aput_pluseqs _ARRAY_PLUSEQS_TOKEN +%__aput_plusplus _ARRAY_PLUSPLUS_TOKEN +%__aput_pminusminus _ARRAY_POST_MINUSMINUS_TOKEN +%__aput_pplusplus _ARRAY_POST_PLUSPLUS_TOKEN +%__arg ARG_TOKEN +%__array ARRAY_TOKEN +%__earg EARG_TOKEN +%__struct_eqs _STRUCT_ASSIGN_TOKEN +%__struct_minuseqs _STRUCT_MINUSEQS_TOKEN +%__struct_minusminus _STRUCT_MINUSMINUS_TOKEN +%__struct_pluseqs _STRUCT_PLUSEQS_TOKEN +%__struct_plusplus _STRUCT_PLUSPLUS_TOKEN +%__struct_pminusminus _STRUCT_POST_MINUSMINUS_TOKEN +%__struct_pplusplus _STRUCT_POST_PLUSPLUS_TOKEN diff --git a/libslang/src/util/perfhash.c b/libslang/src/util/perfhash.c new file mode 100644 index 0000000..b593b19 --- /dev/null +++ b/libslang/src/util/perfhash.c @@ -0,0 +1,600 @@ +/* Copyright (c) 1998, 2001 John E. Davis + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include +#include +#include + +static char *C_Char_Map_Name = "Keyword_Hash_Table"; +static char *C_Hash_Function_Name = "keyword_hash"; +static char *C_Hash_Table_Type = "Keyword_Table_Type"; +static char *C_Hash_Table_Name = "Keyword_Table"; +static char *C_Is_Keyword_Function_Name = "is_keyword"; + +typedef struct +{ + unsigned int hash; + unsigned int len; + unsigned int freq_statistic; + char *name; + char *type; +} +String_Table_Type; + +static String_Table_Type String_Table [256]; + +static unsigned int Num_Strings; + +static unsigned int Max_Table_Value; +static unsigned int Max_String_Len; +static unsigned int Min_String_Len; +static unsigned int Max_Hash_Value; +static unsigned int Tweak_Step_Size; +static int Use_Length = 1; + +static int Char_Table_Map [256]; + +static void write_table (unsigned int min_hash, unsigned int max_hash) +{ + String_Table_Type *st, *st_max; + unsigned int i; + + fprintf (stdout, "\n\ +typedef SLCONST struct\n\ +{\n\ + char *name;\n\ + unsigned int type;\n\ +}\n\ +%s;\n\ +", + C_Hash_Table_Type); + + fprintf (stdout, "\nstatic %s %s [/* %u */] =\n{\n", + C_Hash_Table_Type, C_Hash_Table_Name, (max_hash - min_hash) + 1); + fprintf (stderr, "String Table Size: %u\n", (max_hash - min_hash) + 1); + + for (i = min_hash; i <= max_hash; i++) + { + st = String_Table; + st_max = st + Num_Strings; + while (st < st_max) + { + if ((unsigned int) st->hash == i) + break; + st++; + } + + if (st == st_max) + fprintf (stdout, " {NULL,0},\n"); + else + fprintf (stdout, " {\"%s\",\t%s},\n", st->name, st->type); + } + + fputs ("};\n\n", stdout); + + fprintf (stdout, "\ +static %s *%s (char *str, unsigned int len)\n\ +{\n\ + unsigned int hash;\n\ + char *name;\n\ + %s *kw;\n\ +\n\ + if ((len < MIN_KEYWORD_LEN)\n\ + || (len > MAX_KEYWORD_LEN))\n\ + return NULL;\n\ +\n\ + hash = %s (str, len);\n\ + if ((hash > MAX_HASH_VALUE) || (hash < MIN_HASH_VALUE))\n\ + return NULL;\n\ +\n\ + kw = &%s[hash - MIN_HASH_VALUE];\n\ + if ((NULL != (name = kw->name))\n\ + && (*str == *name)\n\ + && (0 == strcmp (str, name)))\n\ + return kw;\n\ + return NULL;\n\ +}\n\ +", + C_Hash_Table_Type, C_Is_Keyword_Function_Name, + C_Hash_Table_Type, C_Hash_Function_Name, C_Hash_Table_Name); +} + +static unsigned int hash_function (int *char_map, + unsigned char *s, unsigned int len) +{ + unsigned int sum; + + if (Use_Length) sum = len; + else sum = 0; + + while (len) + { + len--; + sum += (unsigned int) char_map [s[len]]; + } + return sum; +} + +static unsigned int Frequency_Table [256]; + +static void init_map (int *map) +{ + unsigned int i; + + for (i = 0; i < 256; i++) map [i] = -1; + + for (i = 0; i < Num_Strings; i++) + { + unsigned char *s; + + s = (unsigned char *) String_Table[i].name; + + while (*s != 0) + { + map [*s] = 0; + s++; + } + } +} + +static void write_map (int *map) +{ + unsigned int i; + unsigned int min_hash, max_hash; + char *type; + + min_hash = 0xFFFF; + max_hash = 0; + for (i = 0; i < Num_Strings; i++) + { + unsigned int h = String_Table[i].hash; + if (h < min_hash) min_hash = h; + if (h > max_hash) max_hash = h; +#if 0 + fprintf (stdout, "-->%s\t%u\n", String_Table[i].name, h); +#endif + } + + fprintf (stdout, "#ifndef SLCONST\n#define SLCONST const\n#endif\n"); + fprintf (stdout, "#define MIN_HASH_VALUE\t%u\n", min_hash); + fprintf (stdout, "#define MAX_HASH_VALUE\t%u\n", max_hash); + fprintf (stdout, "#define MIN_KEYWORD_LEN %u\n", Min_String_Len); + fprintf (stdout, "#define MAX_KEYWORD_LEN %u\n", Max_String_Len); + + for (i = 0; i < 256; i++) + if (map[i] == -1) map[i] = (max_hash + 1); + + if (max_hash + 1 < 0xFF) + type = "unsigned char"; + else if (max_hash + 1 < 0xFFFF) + type = "unsigned short"; + else + type = "unsigned long"; + + fprintf (stderr, "Hash Table is of type %s with max hash %u\n", + type, max_hash); + + fprintf (stdout, "\nstatic %s %s [256] =\n", + type, C_Char_Map_Name); + + fprintf (stdout, "{\n "); + + for (i = 0; i < 255; i++) + { + fprintf (stdout, "%3d, ", map[i]); + if ((i % 16) == 15) + fputs ("\n ", stdout); + } + fprintf (stdout, "%3d\n};\n", map[255]); + + fputs ("\n", stdout); + + fprintf (stdout, "static %s %s (char *s, unsigned int len)\n", + type, C_Hash_Function_Name); + +fprintf (stdout,"\ +{\n\ + unsigned int sum;\n\ +\n\ + sum = %s;\n\ + while (len)\n\ + {\n\ + len--;\n\ + sum += (unsigned int) %s [(unsigned char)s[len]];\n\ + }\n\ + return sum;\n\ +}\n\ +", + (Use_Length ? "len" : "0"), + C_Char_Map_Name); + + write_table (min_hash, max_hash); +} + + +static unsigned int compute_hash (unsigned int i) +{ + String_Table_Type *s; + unsigned int hash; + + s = String_Table + i; + hash = hash_function (Char_Table_Map, (unsigned char *) s->name, s->len); + return s->hash = hash; +} + + +static int tweak_character (unsigned char ch, unsigned int bad) +{ + unsigned int val; + unsigned int val_save; + unsigned int i, j; + unsigned int nvalues; + + val_save = (unsigned int) Char_Table_Map [ch]; + nvalues = Max_Table_Value; + + val = 0; + while (nvalues) + { + val += Tweak_Step_Size; + val = val % Max_Table_Value; + + Char_Table_Map[ch] = (int) val; + + for (i = 0; i <= bad; i++) + { + unsigned int hash = compute_hash (i); + for (j = 0; j < i; j++) + { + if (hash == String_Table[j].hash) + break; + } + if (j != i) + break; + } + + if (i > bad) return 0; + nvalues--; + } + + Char_Table_Map [ch] = (int) val_save; +#if 0 + /* reset hashes */ + for (i = 0; i <= bad; i++) + (void) compute_hash (i); +#endif + return -1; +} + + +static void sort_according_to_frequency (unsigned char *s, unsigned int len) +{ + /* since len is small (I hope), I will be lazy */ + unsigned char si, sj; + unsigned int fi; + unsigned int i, j, imax; + + imax = len - 1; + for (i = 0; i < imax; i++) + { + si = s[i]; + fi = Frequency_Table [si]; + + for (j = i + 1; j < len; j++) + { + sj = s[j]; + if (Frequency_Table[sj] < fi) + { + s[i] = sj; + s[j] = si; + break; + } + } + } +} + +static void create_frequency_table (unsigned int num) +{ + unsigned int i; + + memset ((char *) Frequency_Table, 0, sizeof(Frequency_Table)); + + for (i = 0; i < num; i++) + { + unsigned char *s, ch; + + s = String_Table[i].name; + while (0 != (ch = *s)) + { + Frequency_Table [ch] += 1; + s++; + } + } +} + +static int tweak_hash_function (unsigned int bad, unsigned int good) +{ + unsigned char unique_chars [256]; + unsigned char bad_chars [256], good_chars[256]; + unsigned char *s; + unsigned int i, len; + + + memset ((char *)unique_chars, 0, sizeof (unique_chars)); + memset ((char *)bad_chars, 0, sizeof (bad_chars)); + memset ((char *)good_chars, 0, sizeof (good_chars)); + + s = (unsigned char *) String_Table[bad].name; + while (*s != 0) + { + bad_chars [*s] = 1; + s++; + } + + s = (unsigned char *) String_Table[good].name; + while (*s != 0) + { + good_chars [*s] = 1; + s++; + } + + /* Find out the characters that are in good or bad, and not both. That + * way we are free to manipulate those to avoid the collision. + */ + len = 0; + for (i = 0; i < 256; i++) + { + if (bad_chars[i]) + { + if (good_chars [i] == 0) + unique_chars [len++] = i; + } + else if (good_chars [i]) + unique_chars [len++] = i; + } + + /* Unfortunately, the unique_chars may already be part of the words + * that have already been hashed. So, sort them according to how often + * they occur and deal with those that occur the least often first. + */ +#if 1 + create_frequency_table (bad); +#endif + sort_according_to_frequency (unique_chars, len); + + for (i = 0; i < len; i++) + { + unsigned char ch = unique_chars [i]; + if (0 == tweak_character (ch, bad)) + return 0; + } + + return -1; +} + +static int perfect_hash (void) +{ + unsigned int i, j; + unsigned int hash; + int has_collisions = 1; + + for (i = 0; i < Num_Strings; i++) + { + hash = compute_hash (i); + for (j = 0; j < i; j++) + { + if (hash != String_Table[j].hash) + continue; + + /* Oops. We have a collision. tweak_hash_function will + * adjust the hash table array to resolve this collision + * and ensure that previous ones remain resolved. + */ + if (-1 == tweak_hash_function (i, j)) + { + has_collisions = 1; + /* return -1; */ + } + break; + } + } + + if (has_collisions == 0) + return 0; + + has_collisions = 0; + /* Now check for collisions */ + for (i = 0; i < Num_Strings; i++) + { + char *s = String_Table[i].name; + hash = compute_hash (i); + + for (j = 0; j < i; j++) + { + if (hash != String_Table[j].hash) + continue; + + has_collisions++; + fprintf (stderr, "Collision: %s, %s\n", s, String_Table [j].name); + } + } + + if (has_collisions) + return -1; + + return 0; +} + + +static int sort_function (String_Table_Type *a, String_Table_Type *b) +{ + return b->freq_statistic - a->freq_statistic; +} + +static void sort_strings (void) +{ + unsigned int i; + void (*qsort_fun) (String_Table_Type *, unsigned int, + unsigned int, int (*)(String_Table_Type *, String_Table_Type *)); + + for (i = 0; i < Num_Strings; i++) + { + int f; + unsigned char *s; + + f = 0; + s = (unsigned char *) String_Table[i].name; + while (*s != 0) f += Frequency_Table [*s++]; + String_Table [i].freq_statistic = f; + } + + qsort_fun = (void (*) (String_Table_Type *, unsigned int, + unsigned int, + int (*)(String_Table_Type *, String_Table_Type *))) + qsort; + + qsort_fun (String_Table, Num_Strings, sizeof (String_Table_Type), + sort_function); +} + +int main (int argc, char **argv) +{ + char line[256]; + unsigned int count; + unsigned int min_char; + unsigned int max_char; + unsigned int min_len; + unsigned int max_len; + unsigned int i; + + Tweak_Step_Size = 5; + + if (isatty (0) || (argc > 2)) + { + fprintf (stderr, "Usage: %s [step-size] < keywords > hash.c\n", argv[0]); + fprintf (stderr, " Default step-size is %u\n", Tweak_Step_Size); + return 1; + } + + if (argc > 1) + { + if (1 != sscanf (argv[1], "%u", &Tweak_Step_Size)) + Tweak_Step_Size = 5; + + if ((Tweak_Step_Size % 2) == 0) Tweak_Step_Size++; + } + + count = 0; + min_char = 255; + max_char = 0; + max_len = 0; + min_len = 0xFFFF; + + while (NULL != fgets (line, sizeof (line), stdin)) + { + char *s; + unsigned int len; + char *type; + + if (*line == '%') continue; + + if (count == 256) + { + fprintf (stderr, "Only 256 keywords permitted.\n"); + return 1; + } + + len = strlen (line); + if (len && (line [len - 1] == '\n')) + { + len--; + line [len] = 0; + } + + if (len == 0) + continue; + + s = malloc (len + 1); + if (s == NULL) + { + fprintf (stderr, "Malloc error.\n"); + return 1; + } + strcpy (s, line); + String_Table[count].name = s; + + type = s; + while (*type && (*type != ' ') && (*type != '\t')) + type++; + + len = (unsigned int) (type - s); + String_Table [count].len = len; + if (len > max_len) max_len = len; + if (len < min_len) min_len = len; + + if (*type != 0) + { + *type++ = 0; + while ((*type == ' ') || (*type == '\t')) + type++; + } + + String_Table [count].type = type; + + + for (i = 0; i < len; i++) + { + unsigned char ch; + + ch = (unsigned char) s[i]; + + if (ch < min_char) + min_char = ch; + if (ch > max_char) + max_char = ch; + } + + count++; + } + + + Max_String_Len = max_len; + Min_String_Len = min_len; + + Num_Strings = count; + Max_Table_Value = 1; + while (Max_Table_Value < Num_Strings) + Max_Table_Value = Max_Table_Value << 1; + + Max_Hash_Value = Max_Table_Value * Max_String_Len; + + fprintf (stderr, "Theoretical Max_Table_Value: %u\n", Max_Table_Value); + fprintf (stderr, "Theoretical Max_Hash_Value: %u\n", Max_Hash_Value); + + create_frequency_table (Num_Strings); + sort_strings (); + + init_map (Char_Table_Map); + if (-1 == perfect_hash ()) + { + fprintf (stderr, "Hash failed.\n"); + return -1; + } + + fprintf (stderr, "Success.\n"); + + fprintf (stdout, "/* Perfect hash generated by command line:\n *"); + for (i = 0; i < argc; i++) + fprintf (stdout, " %s", argv[i]); + fputs ("\n */\n", stdout); + + write_map (Char_Table_Map); + return 0; +} + + + + + -- cgit v1.2.3