summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorGuillaume Cottenceau <gc@mandriva.com>2001-05-14 21:47:42 +0000
committerGuillaume Cottenceau <gc@mandriva.com>2001-05-14 21:47:42 +0000
commit98a18b797c63ea9baab31768ed720ad32c0004e8 (patch)
tree2d8b0d9e845b332060ac668a429ef65ca4c47ed1
parent12cf594c688f3bc3e0b26d35305d5d6db7036fc4 (diff)
downloaddrakx-98a18b797c63ea9baab31768ed720ad32c0004e8.tar
drakx-98a18b797c63ea9baab31768ed720ad32c0004e8.tar.gz
drakx-98a18b797c63ea9baab31768ed720ad32c0004e8.tar.bz2
drakx-98a18b797c63ea9baab31768ed720ad32c0004e8.tar.xz
drakx-98a18b797c63ea9baab31768ed720ad32c0004e8.zip
i can compile slang and newt with dietlibc now
-rw-r--r--mdk-stage1/Makefile19
-rw-r--r--mdk-stage1/newt-frontend.c2
-rw-r--r--mdk-stage1/newt/Makefile49
-rw-r--r--mdk-stage1/newt/button.c190
-rw-r--r--mdk-stage1/newt/buttonbar.c46
-rw-r--r--mdk-stage1/newt/checkbox.c290
-rw-r--r--mdk-stage1/newt/checkboxtree.c714
-rw-r--r--mdk-stage1/newt/entry.c376
-rw-r--r--mdk-stage1/newt/form.c712
-rw-r--r--mdk-stage1/newt/grid.c389
-rw-r--r--mdk-stage1/newt/label.c81
-rw-r--r--mdk-stage1/newt/listbox.c752
-rw-r--r--mdk-stage1/newt/newt.c672
-rw-r--r--mdk-stage1/newt/newt.h362
-rw-r--r--mdk-stage1/newt/newt_pr.h82
-rw-r--r--mdk-stage1/newt/scale.c72
-rw-r--r--mdk-stage1/newt/scrollbar.c124
-rw-r--r--mdk-stage1/newt/textbox.c409
-rw-r--r--mdk-stage1/newt/windows.c275
-rw-r--r--mdk-stage1/slang/Makefile48
-rw-r--r--mdk-stage1/slang/_slang.h743
-rw-r--r--mdk-stage1/slang/config.h163
-rw-r--r--mdk-stage1/slang/jdmacros.h53
-rw-r--r--mdk-stage1/slang/keywhash.c190
-rw-r--r--mdk-stage1/slang/sl-feat.h60
-rw-r--r--mdk-stage1/slang/slang.c5547
-rw-r--r--mdk-stage1/slang/slang.h1930
-rw-r--r--mdk-stage1/slang/slarith.c1656
-rw-r--r--mdk-stage1/slang/slarith.inc783
-rw-r--r--mdk-stage1/slang/slarray.c3139
-rw-r--r--mdk-stage1/slang/slarrfun.c464
-rw-r--r--mdk-stage1/slang/slarrfun.inc257
-rw-r--r--mdk-stage1/slang/slarrmis.c38
-rw-r--r--mdk-stage1/slang/slassoc.c713
-rw-r--r--mdk-stage1/slang/slbstr.c615
-rw-r--r--mdk-stage1/slang/slclass.c1391
-rw-r--r--mdk-stage1/slang/slcmd.c351
-rw-r--r--mdk-stage1/slang/slcmplex.c1142
-rw-r--r--mdk-stage1/slang/slcompat.c34
-rw-r--r--mdk-stage1/slang/slcurses.c972
-rw-r--r--mdk-stage1/slang/slcurses.h353
-rw-r--r--mdk-stage1/slang/sldisply.c2596
-rw-r--r--mdk-stage1/slang/slerr.c181
-rw-r--r--mdk-stage1/slang/slerrno.c219
-rw-r--r--mdk-stage1/slang/slgetkey.c306
-rw-r--r--mdk-stage1/slang/slimport.c281
-rw-r--r--mdk-stage1/slang/slinclud.h26
-rw-r--r--mdk-stage1/slang/slintall.c27
-rw-r--r--mdk-stage1/slang/slistruc.c218
-rw-r--r--mdk-stage1/slang/slkeymap.c596
-rw-r--r--mdk-stage1/slang/slkeypad.c163
-rw-r--r--mdk-stage1/slang/sllimits.h64
-rw-r--r--mdk-stage1/slang/slmalloc.c165
-rw-r--r--mdk-stage1/slang/slmath.c565
-rw-r--r--mdk-stage1/slang/slmemchr.c47
-rw-r--r--mdk-stage1/slang/slmemcmp.c76
-rw-r--r--mdk-stage1/slang/slmemcpy.c49
-rw-r--r--mdk-stage1/slang/slmemset.c39
-rw-r--r--mdk-stage1/slang/slmisc.c330
-rw-r--r--mdk-stage1/slang/slnspace.c242
-rw-r--r--mdk-stage1/slang/slospath.c73
-rw-r--r--mdk-stage1/slang/slpack.c785
-rw-r--r--mdk-stage1/slang/slparse.c1970
-rw-r--r--mdk-stage1/slang/slpath.c344
-rw-r--r--mdk-stage1/slang/slposdir.c1057
-rw-r--r--mdk-stage1/slang/slposio.c568
-rw-r--r--mdk-stage1/slang/slprepr.c427
-rw-r--r--mdk-stage1/slang/slproc.c155
-rw-r--r--mdk-stage1/slang/slregexp.c935
-rw-r--r--mdk-stage1/slang/slrline.c836
-rw-r--r--mdk-stage1/slang/slscanf.c718
-rw-r--r--mdk-stage1/slang/slscroll.c450
-rw-r--r--mdk-stage1/slang/slsearch.c239
-rw-r--r--mdk-stage1/slang/slsignal.c336
-rw-r--r--mdk-stage1/slang/slsmg.c1584
-rw-r--r--mdk-stage1/slang/slstd.c724
-rw-r--r--mdk-stage1/slang/slstdio.c1050
-rw-r--r--mdk-stage1/slang/slstring.c546
-rw-r--r--mdk-stage1/slang/slstrops.c1686
-rw-r--r--mdk-stage1/slang/slstruct.c932
-rw-r--r--mdk-stage1/slang/sltermin.c1155
-rw-r--r--mdk-stage1/slang/sltime.c310
-rw-r--r--mdk-stage1/slang/sltoken.c1702
-rw-r--r--mdk-stage1/slang/sltypes.c966
-rw-r--r--mdk-stage1/slang/slutty.c596
-rw-r--r--mdk-stage1/slang/slxstrng.c43
86 files changed, 52622 insertions, 13 deletions
diff --git a/mdk-stage1/Makefile b/mdk-stage1/Makefile
index 9a3ecae43..96eade486 100644
--- a/mdk-stage1/Makefile
+++ b/mdk-stage1/Makefile
@@ -47,22 +47,17 @@ INITOBJS = $(subst .c,.o,$(INITSRC))
#- frontends
NEWT_FRONTEND_SRC = newt-frontend.c
-NEWT_FRONTEND_LIBS = /usr/lib/libnewt.a /usr/lib/libslang.a
+GLIBC_NEWT_FRONTEND_LIBS = newt/libnewt.a slang/libslang.a
+DIETLIBC_NEWT_FRONTEND_LIBS = $(subst .a,-DIET.a,$(GLIBC_NEWT_FRONTEND_LIBS))
STDIO_FRONTEND_SRC = stdio-frontend.c
-STDIO_FRONTEND_LIBS =
+GLIBC_STDIO_FRONTEND_LIBS =
+DIETLIBC_STDIO_FRONTEND_LIBS =
FRONTEND_OBJS = $(subst .c,.o,$($(F)_FRONTEND_SRC))
-FRONTEND_LIBS = $($(F)_FRONTEND_LIBS)
-FRONTEND_LINK = $(FRONTEND_OBJS) $(FRONTEND_LIBS)
-
-ifeq (DIETLIBC, $(L))
-ifeq (NEWT, $(F))
-FRONTEND_LINK = $(subst .c,.o,$(STDIO_FRONTEND_SRC)) $(STDIO_FRONTEND_LIBS)
-endif
-endif
+FRONTEND_LINK = $(FRONTEND_OBJS) $($(L)_$(F)_FRONTEND_LIBS)
ifeq (i386, $(ARCH))
INSMOD = insmod-busybox
@@ -71,7 +66,7 @@ INSMOD = insmod-modutils
endif
GLIBC_STAGE1_OWN_LIBS = $(INSMOD)/libinsmod.a mar/libmar.a bzlib/libbzlib.a
-DIETLIBC_STAGE1_OWN_LIBS = $(INSMOD)/libinsmod-DIET.a mar/libmar-DIET.a bzlib/libbzlib-DIET.a
+DIETLIBC_STAGE1_OWN_LIBS = $(subst .a,-DIET.a,$(GLIBC_STAGE1_OWN_LIBS))
STAGE1_OWN_LIBS = $($(L)_STAGE1_OWN_LIBS)
@@ -125,7 +120,7 @@ BINS += stage1-cdrom stage1-disk stage1-network
endif
-DIRS = dietlibc mar pci-resource bzlib $(INSMOD)
+DIRS = dietlibc mar pci-resource bzlib $(INSMOD) slang newt
ifeq (i386,$(ARCH))
DIRS += pcmcia
endif
diff --git a/mdk-stage1/newt-frontend.c b/mdk-stage1/newt-frontend.c
index 85f56ec10..867a6d7f1 100644
--- a/mdk-stage1/newt-frontend.c
+++ b/mdk-stage1/newt-frontend.c
@@ -33,7 +33,7 @@
#include <sys/time.h>
#include "stage1.h"
#include "log.h"
-#include "newt.h"
+#include "newt/newt.h"
#include "frontend.h"
diff --git a/mdk-stage1/newt/Makefile b/mdk-stage1/newt/Makefile
new file mode 100644
index 000000000..c4e6a7207
--- /dev/null
+++ b/mdk-stage1/newt/Makefile
@@ -0,0 +1,49 @@
+ #******************************************************************************
+ #
+ # Guillaume Cottenceau (gc@mandrakesoft.com)
+ #
+ # Copyright 2000 MandrakeSoft
+ #
+ # This software may be freely redistributed under the terms of the GNU
+ # public license.
+ #
+ # 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.
+ #
+ #*****************************************************************************
+
+top_dir = ..
+
+include $(top_dir)/Makefile.common
+
+
+all: libnewt.a libnewt-DIET.a
+
+clean:
+ rm -f *.o *.a
+
+FLAGS = -Wall -Werror -Os -fomit-frame-pointer -DVERSION=\"0.50.19\" -c
+
+INCS = -I../slang
+
+
+OBJS = newt.o button.o form.o checkbox.o entry.o label.o listbox.o scrollbar.o textbox.o scale.o grid.o windows.o buttonbar.o checkboxtree.o
+OBJS-DIET = $(subst .o,-DIET.o,$(OBJS))
+
+
+libnewt.a: $(OBJS)
+ ar -cru $@ $^
+ ranlib $@
+
+libnewt-DIET.a: $(OBJS-DIET)
+ ar -cru $@ $^
+ ranlib $@
+
+
+$(OBJS): %.o: %.c
+ gcc $(FLAGS) $(GLIBC_INCLUDES) $(INCS) -c $< -o $@
+
+$(OBJS-DIET): %-DIET.o: %.c
+ gcc $(FLAGS) $(DIETLIBC_INCLUDES) $(INCS) -c $< -o $@
+
diff --git a/mdk-stage1/newt/button.c b/mdk-stage1/newt/button.c
new file mode 100644
index 000000000..1ff360dc5
--- /dev/null
+++ b/mdk-stage1/newt/button.c
@@ -0,0 +1,190 @@
+#include <slang.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+struct button {
+ char * text;
+ int compact;
+};
+
+static void buttonDrawIt(newtComponent co, int active, int pushed);
+static void buttonDrawText(newtComponent co, int active, int pushed);
+
+static void buttonDraw(newtComponent c);
+static void buttonDestroy(newtComponent co);
+static struct eventResult buttonEvent(newtComponent c,
+ struct event ev);
+static void buttonPlace(newtComponent co, int newLeft, int newTop);
+
+static struct componentOps buttonOps = {
+ buttonDraw,
+ buttonEvent,
+ buttonDestroy,
+ buttonPlace,
+ newtDefaultMappedHandler,
+} ;
+
+static newtComponent createButton(int left, int row, const char * text, int compact) {
+ newtComponent co;
+ struct button * bu;
+
+ co = malloc(sizeof(*co));
+ bu = malloc(sizeof(struct button));
+ co->data = bu;
+
+ bu->text = strdup(text);
+ bu->compact = compact;
+ co->ops = &buttonOps;
+
+ if (bu->compact) {
+ co->height = 1;
+ co->width = strlen(text) + 3;
+ } else {
+ co->height = 4;
+ co->width = strlen(text) + 5;
+ }
+
+ co->top = row;
+ co->left = left;
+ co->takesFocus = 1;
+ co->isMapped = 0;
+
+ newtGotorc(co->top, co->left);
+
+ return co;
+}
+
+newtComponent newtCompactButton(int left, int row, const char * text) {
+ return createButton(left, row, text, 1);
+}
+
+newtComponent newtButton(int left, int row, const char * text) {
+ return createButton(left, row, text, 0);
+}
+
+static void buttonDestroy(newtComponent co) {
+ struct button * bu = co->data;
+
+ free(bu->text);
+ free(bu);
+ free(co);
+}
+
+static void buttonPlace(newtComponent co, int newLeft, int newTop) {
+ co->top = newTop;
+ co->left = newLeft;
+
+ newtGotorc(co->top, co->left);
+}
+
+static void buttonDraw(newtComponent co) {
+ buttonDrawIt(co, 0, 0);
+}
+
+static void buttonDrawIt(newtComponent co, int active, int pushed) {
+ struct button * bu = co->data;
+
+ if (!co->isMapped) return;
+
+ SLsmg_set_color(NEWT_COLORSET_BUTTON);
+
+ if (bu->compact) {
+ if (active)
+ SLsmg_set_color(NEWT_COLORSET_COMPACTBUTTON);
+ else
+ SLsmg_set_color(NEWT_COLORSET_BUTTON);
+ newtGotorc(co->top+ pushed, co->left + 1 + pushed);
+ SLsmg_write_char('<');
+ SLsmg_write_string(bu->text);
+ SLsmg_write_char('>');
+ } else {
+ if (pushed) {
+ SLsmg_set_color(NEWT_COLORSET_BUTTON);
+ newtDrawBox(co->left + 1, co->top + 1, co->width - 1, 3, 0);
+
+ SLsmg_set_color(NEWT_COLORSET_WINDOW);
+ newtClearBox(co->left, co->top, co->width, 1);
+ newtClearBox(co->left, co->top, 1, co->height);
+ } else {
+ newtDrawBox(co->left, co->top, co->width - 1, 3, 1);
+ }
+
+ buttonDrawText(co, active, pushed);
+ }
+}
+
+static void buttonDrawText(newtComponent co, int active, int pushed) {
+ struct button * bu = co->data;
+
+ if (pushed) pushed = 1;
+
+ if (active)
+ SLsmg_set_color(NEWT_COLORSET_ACTBUTTON);
+ else
+ SLsmg_set_color(NEWT_COLORSET_BUTTON);
+
+ newtGotorc(co->top + 1 + pushed, co->left + 1 + pushed);
+ SLsmg_write_char(' ');
+ SLsmg_write_string(bu->text);
+ SLsmg_write_char(' ');
+}
+
+static struct eventResult buttonEvent(newtComponent co,
+ struct event ev) {
+ struct eventResult er;
+ struct button * bu = co->data;
+
+ if (ev.when == EV_NORMAL) {
+ switch (ev.event) {
+ case EV_FOCUS:
+ buttonDrawIt(co, 1, 0);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case EV_UNFOCUS:
+ buttonDrawIt(co, 0, 0);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case EV_KEYPRESS:
+ if (ev.u.key == ' ' || ev.u.key == '\r') {
+ if (!bu->compact) {
+ /* look pushed */
+ buttonDrawIt(co, 1, 1);
+ newtRefresh();
+ newtDelay(150000);
+ buttonDrawIt(co, 1, 0);
+ newtRefresh();
+ newtDelay(150000);
+ }
+
+ er.result = ER_EXITFORM;
+ } else
+ er.result = ER_IGNORED;
+ break;
+ case EV_MOUSE:
+ if (ev.u.mouse.type == MOUSE_BUTTON_DOWN &&
+ co->top <= ev.u.mouse.y &&
+ co->top + co->height - !bu->compact > ev.u.mouse.y &&
+ co->left <= ev.u.mouse.x &&
+ co->left + co->width - !bu->compact > ev.u.mouse.x) {
+ if (!bu->compact) {
+ buttonDrawIt(co, 1, 1);
+ newtRefresh();
+ newtDelay(150000);
+ buttonDrawIt(co, 1, 0);
+ newtRefresh();
+ newtDelay(150000);
+ }
+ er.result = ER_EXITFORM;
+ }
+ break;
+ }
+ } else
+ er.result = ER_IGNORED;
+
+ return er;
+}
diff --git a/mdk-stage1/newt/buttonbar.c b/mdk-stage1/newt/buttonbar.c
new file mode 100644
index 000000000..45473c9d2
--- /dev/null
+++ b/mdk-stage1/newt/buttonbar.c
@@ -0,0 +1,46 @@
+#include <stdarg.h>
+
+#include "newt.h"
+
+/* if they try and pack more then 50 buttons, screw 'em */
+newtGrid newtButtonBarv(char * button1, newtComponent * b1comp, va_list args) {
+ newtGrid grid;
+ struct buttonInfo {
+ char * name;
+ newtComponent * compPtr;
+ } buttons[50];
+ int num;
+ int i;
+
+ buttons[0].name = button1, buttons[0].compPtr = b1comp, num = 1;
+ while (1) {
+ buttons[num].name = va_arg(args, char *);
+ if (!buttons[num].name) break;
+ buttons[num].compPtr = va_arg(args, newtComponent *);
+ num++;
+ }
+
+ grid = newtCreateGrid(num, 1);
+
+ for (i = 0; i < num; i++) {
+ *buttons[i].compPtr = newtButton(-1, -1, buttons[i].name);
+ newtGridSetField(grid, i, 0, NEWT_GRID_COMPONENT,
+ *buttons[i].compPtr,
+ num ? 1 : 0, 0, 0, 0, 0, 0);
+ }
+
+ return grid;
+}
+
+newtGrid newtButtonBar(char * button1, newtComponent * b1comp, ...) {
+ va_list args;
+ newtGrid grid;
+
+ va_start(args, b1comp);
+
+ grid = newtButtonBarv(button1, b1comp, args);
+
+ va_end(args);
+
+ return grid;
+}
diff --git a/mdk-stage1/newt/checkbox.c b/mdk-stage1/newt/checkbox.c
new file mode 100644
index 000000000..eee514c98
--- /dev/null
+++ b/mdk-stage1/newt/checkbox.c
@@ -0,0 +1,290 @@
+#include <slang.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+enum type { CHECK, RADIO };
+
+struct checkbox {
+ char * text;
+ char * seq;
+ char * result;
+ newtComponent prevButton, lastButton;
+ enum type type;
+ char value;
+ int active, inactive;
+ const void * data;
+ int flags;
+ int hasFocus;
+};
+
+static void makeActive(newtComponent co);
+
+static void cbDraw(newtComponent c);
+static void cbDestroy(newtComponent co);
+struct eventResult cbEvent(newtComponent co, struct event ev);
+
+static struct componentOps cbOps = {
+ cbDraw,
+ cbEvent,
+ cbDestroy,
+ newtDefaultPlaceHandler,
+ newtDefaultMappedHandler,
+} ;
+
+newtComponent newtRadiobutton(int left, int top, const char * text, int isDefault,
+ newtComponent prevButton) {
+ newtComponent co;
+ newtComponent curr;
+ struct checkbox * rb;
+ char initialValue;
+
+ if (isDefault)
+ initialValue = '*';
+ else
+ initialValue = ' ';
+
+ co = newtCheckbox(left, top, text, initialValue, " *", NULL);
+ rb = co->data;
+ rb->type = RADIO;
+
+ rb->prevButton = prevButton;
+
+ for (curr = co; curr; curr = rb->prevButton) {
+ rb = curr->data;
+ rb->lastButton = co;
+ }
+
+ return co;
+}
+
+newtComponent newtRadioGetCurrent(newtComponent setMember) {
+ struct checkbox * rb = setMember->data;
+
+ setMember = rb->lastButton;
+ rb = setMember->data;
+
+ while (rb && rb->value != '*') {
+ setMember = rb->prevButton;
+ if (!setMember)
+ return NULL;
+ rb = setMember->data;
+ }
+
+ return setMember;
+}
+
+char newtCheckboxGetValue(newtComponent co) {
+ struct checkbox * cb = co->data;
+
+ return cb->value;
+}
+
+void newtCheckboxSetValue(newtComponent co, char value) {
+ struct checkbox * cb = co->data;
+
+ *cb->result = value;
+ cbDraw(co);
+}
+
+newtComponent newtCheckbox(int left, int top, const char * text, char defValue,
+ const char * seq, char * result) {
+ newtComponent co;
+ struct checkbox * cb;
+
+ if (!seq) seq = " *";
+
+ co = malloc(sizeof(*co));
+ cb = malloc(sizeof(struct checkbox));
+ co->data = cb;
+ cb->flags = 0;
+ if (result)
+ cb->result = result;
+ else
+ cb->result = &cb->value;
+
+ cb->text = strdup(text);
+ cb->seq = strdup(seq);
+ cb->type = CHECK;
+ cb->hasFocus = 0;
+ cb->inactive = COLORSET_CHECKBOX;
+ cb->active = COLORSET_ACTCHECKBOX;
+ defValue ? (*cb->result = defValue) : (*cb->result = cb->seq[0]);
+
+ co->ops = &cbOps;
+
+ co->callback = NULL;
+ co->height = 1;
+ co->width = strlen(text) + 4;
+ co->top = top;
+ co->left = left;
+ co->takesFocus = 1;
+
+ return co;
+}
+
+void newtCheckboxSetFlags(newtComponent co, int flags, enum newtFlagsSense sense) {
+ struct checkbox * cb = co->data;
+ int row, col;
+
+ cb->flags = newtSetFlags(cb->flags, flags, sense);
+
+ if (!(cb->flags & NEWT_FLAG_DISABLED))
+ co->takesFocus = 1;
+ else
+ co->takesFocus = 0;
+
+ newtGetrc(&row, &col);
+ cbDraw(co);
+ newtGotorc(row, col);
+}
+
+static void cbDraw(newtComponent c) {
+ struct checkbox * cb = c->data;
+
+ if (c->top == -1 || !c->isMapped) return;
+
+ if (cb->flags & NEWT_FLAG_DISABLED) {
+ cb->inactive = NEWT_COLORSET_DISENTRY;
+ cb->active = NEWT_COLORSET_DISENTRY;
+ } else {
+ cb->inactive = COLORSET_CHECKBOX;
+ cb->active = COLORSET_ACTCHECKBOX;
+ }
+
+ SLsmg_set_color(cb->inactive);
+
+ newtGotorc(c->top, c->left);
+
+ switch (cb->type) {
+ case RADIO:
+ SLsmg_write_string("( ) ");
+ break;
+
+ case CHECK:
+ SLsmg_write_string("[ ] ");
+ break;
+
+ default:
+ break;
+ }
+
+ SLsmg_write_string(cb->text);
+
+ if (cb->hasFocus)
+ SLsmg_set_color(cb->active);
+
+ newtGotorc(c->top, c->left + 1);
+ SLsmg_write_char(*cb->result);
+}
+
+static void cbDestroy(newtComponent co) {
+ struct checkbox * cb = co->data;
+
+ free(cb->text);
+ free(cb->seq);
+ free(cb);
+ free(co);
+}
+
+struct eventResult cbEvent(newtComponent co, struct event ev) {
+ struct checkbox * cb = co->data;
+ struct eventResult er;
+ const char * cur;
+
+ if (ev.when == EV_NORMAL) {
+ switch (ev.event) {
+ case EV_FOCUS:
+ cb->hasFocus = 1;
+ cbDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case EV_UNFOCUS:
+ cb->hasFocus = 0;
+ cbDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case EV_KEYPRESS:
+ if (ev.u.key == ' ') {
+ if (cb->type == RADIO) {
+ makeActive(co);
+ } else if (cb->type == CHECK) {
+ cur = strchr(cb->seq, *cb->result);
+ if (!cur)
+ *cb->result = *cb->seq;
+ else {
+ cur++;
+ if (! *cur)
+ *cb->result = *cb->seq;
+ else
+ *cb->result = *cur;
+ }
+ cbDraw(co);
+ er.result = ER_SWALLOWED;
+
+ if (co->callback)
+ co->callback(co, co->callbackData);
+ } else {
+ er.result = ER_IGNORED;
+ }
+ } else if(ev.u.key == NEWT_KEY_ENTER) {
+ er.result = ER_IGNORED;
+ } else {
+ er.result = ER_IGNORED;
+ }
+ break;
+ case EV_MOUSE:
+ if (ev.u.mouse.type == MOUSE_BUTTON_DOWN) {
+ if (cb->type == RADIO) {
+ makeActive(co);
+ } else if (cb->type == CHECK) {
+ cur = strchr(cb->seq, *cb->result);
+ if (!cur)
+ *cb->result = *cb->seq;
+ else {
+ cur++;
+ if (! *cur)
+ *cb->result = *cb->seq;
+ else
+ *cb->result = *cur;
+ }
+ cbDraw(co);
+ er.result = ER_SWALLOWED;
+
+ if (co->callback)
+ co->callback(co, co->callbackData);
+ }
+ }
+ }
+ } else
+ er.result = ER_IGNORED;
+
+ return er;
+}
+
+static void makeActive(newtComponent co) {
+ struct checkbox * cb = co->data;
+ struct checkbox * rb;
+ newtComponent curr;
+
+ /* find the one that's turned off */
+ curr = cb->lastButton;
+ rb = curr->data;
+ while (curr && rb->value == rb->seq[0]) {
+ curr = rb->prevButton;
+ if (curr) rb = curr->data;
+ }
+ if (curr) {
+ rb->value = rb->seq[0];
+ cbDraw(curr);
+ }
+ cb->value = cb->seq[1];
+ cbDraw(co);
+
+ if (co->callback)
+ co->callback(co, co->callbackData);
+}
diff --git a/mdk-stage1/newt/checkboxtree.c b/mdk-stage1/newt/checkboxtree.c
new file mode 100644
index 000000000..b56bd1e9f
--- /dev/null
+++ b/mdk-stage1/newt/checkboxtree.c
@@ -0,0 +1,714 @@
+#include <slang.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+struct items {
+ char * text;
+ const void *data;
+ unsigned char selected;
+ struct items *next;
+ struct items *prev;
+ struct items *branch;
+ int flags;
+ int depth;
+};
+
+struct CheckboxTree {
+ newtComponent sb;
+ int curWidth; /* size of text w/o scrollbar or border*/
+ int curHeight; /* size of text w/o border */
+ struct items * itemlist;
+ struct items ** flatList, ** currItem, ** firstItem;
+ int flatCount;
+ int flags;
+ int pad;
+ char * seq;
+ char * result;
+};
+
+static void ctDraw(newtComponent c);
+static void ctDestroy(newtComponent co);
+static void ctPlace(newtComponent co, int newLeft, int newTop);
+struct eventResult ctEvent(newtComponent co, struct event ev);
+static void ctMapped(newtComponent co, int isMapped);
+static struct items * findItem(struct items * items, const void * data);
+static void buildFlatList(newtComponent co);
+static void doBuildFlatList(struct CheckboxTree * ct, struct items * item);
+enum countWhat { COUNT_EXPOSED=0, COUNT_SELECTED=1 };
+static int countItems(struct items * item, enum countWhat justExposed);
+
+static struct componentOps ctOps = {
+ ctDraw,
+ ctEvent,
+ ctDestroy,
+ ctPlace,
+ ctMapped,
+} ;
+
+static int countItems(struct items * item, enum countWhat what) {
+ int count = 0;
+
+ while (item) {
+ if ((!item->branch && item->selected == what) || (what == COUNT_EXPOSED))
+ count++;
+ if (item->branch || (what == COUNT_EXPOSED && item->selected))
+ count += countItems(item->branch, what);
+ item = item->next;
+ }
+
+ return count;
+}
+
+static void doBuildFlatList(struct CheckboxTree * ct, struct items * item) {
+ while (item) {
+ ct->flatList[ct->flatCount++] = item;
+ if (item->branch && item->selected) doBuildFlatList(ct, item->branch);
+ item = item->next;
+ }
+}
+
+static void buildFlatList(newtComponent co) {
+ struct CheckboxTree * ct = co->data;
+
+ if (ct->flatList) free(ct->flatList);
+ ct->flatCount = countItems(ct->itemlist, COUNT_EXPOSED);
+
+ ct->flatList = malloc(sizeof(*ct->flatList) * (ct->flatCount+1));
+ ct->flatCount = 0;
+ doBuildFlatList(ct, ct->itemlist);
+ ct->flatList[ct->flatCount] = NULL;
+}
+
+int newtCheckboxTreeAddItem(newtComponent co,
+ const char * text, const void * data,
+ int flags, int index, ...) {
+ va_list argList;
+ int numIndexes;
+ int * indexes;
+ int i;
+
+ va_start(argList, index);
+ numIndexes = 0;
+ i = index;
+ while (i != NEWT_ARG_LAST) {
+ numIndexes++;
+ i = va_arg(argList, int);
+ }
+
+ va_end(argList);
+
+ indexes = alloca(sizeof(*indexes) * (numIndexes + 1));
+ va_start(argList, index);
+ numIndexes = 0;
+ i = index;
+ va_start(argList, index);
+ while (i != NEWT_ARG_LAST) {
+ indexes[numIndexes++] = i;
+ i = va_arg(argList, int);
+ }
+ va_end(argList);
+
+ indexes[numIndexes++] = NEWT_ARG_LAST;
+
+ return newtCheckboxTreeAddArray(co, text, data, flags, indexes);
+}
+
+static int doFindItemPath(struct items * items, void * data, int * path,
+ int * len) {
+ int where = 0;
+
+ while (items) {
+ if (items->data == data) {
+ if (path) path[items->depth] = where;
+ if (len) *len = items->depth + 1;
+ return 1;
+ }
+
+ if (items->branch && doFindItemPath(items->branch, data, path, len)) {
+ if (path) path[items->depth] = where;
+ return 1;
+ }
+
+ items = items->next;
+ where++;
+ }
+
+ return 0;
+}
+
+int * newtCheckboxTreeFindItem(newtComponent co, void * data) {
+ int len;
+ int * path;
+ struct CheckboxTree * ct = co->data;
+
+ if (!doFindItemPath(ct->itemlist, data, NULL, &len)) return NULL;
+
+ path = malloc(sizeof(*path) * (len + 1));
+ doFindItemPath(ct->itemlist, data, path, NULL);
+ path[len] = NEWT_ARG_LAST;
+
+ return path;
+}
+
+int newtCheckboxTreeAddArray(newtComponent co,
+ const char * text, const void * data,
+ int flags, int * indexes) {
+ struct items * curList, * newNode, * item = NULL;
+ struct items ** listPtr = NULL;
+ int i, index, numIndexes;
+ struct CheckboxTree * ct = co->data;
+
+ numIndexes = 0;
+ while (indexes[numIndexes] != NEWT_ARG_LAST) numIndexes++;
+
+ if (!ct->itemlist) {
+ if (numIndexes > 1) return -1;
+
+ ct->itemlist = malloc(sizeof(*ct->itemlist));
+ item = ct->itemlist;
+ item->prev = NULL;
+ item->next = NULL;
+ } else {
+ curList = ct->itemlist;
+ listPtr = &ct->itemlist;
+
+ i = 0;
+ index = indexes[i];
+ while (i < numIndexes) {
+ item = curList;
+
+ if (index == NEWT_ARG_APPEND) {
+ item = NULL;
+ } else {
+ while (index && item)
+ item = item->next, index--;
+ }
+
+ i++;
+ if (i < numIndexes) {
+ curList = item->branch;
+ listPtr = &item->branch;
+ if (!curList && (i + 1 != numIndexes)) return -1;
+
+ index = indexes[i];
+ }
+ }
+
+ if (!curList) { /* create a new branch */
+ item = malloc(sizeof(*curList->prev));
+ item->next = item->prev = NULL;
+ *listPtr = item;
+ } else if (!item) { /* append to end */
+ item = curList;
+ while (item->next) item = item->next;
+ item->next = malloc(sizeof(*curList->prev));
+ item->next->prev = item;
+ item = item->next;
+ item->next = NULL;
+ } else {
+ newNode = malloc(sizeof(*newNode));
+ newNode->prev = item->prev;
+ newNode->next = item;
+
+ if (item->prev) item->prev->next = newNode;
+ item->prev = newNode;
+ item = newNode;
+ if (!item->prev) *listPtr = item;
+ }
+ }
+
+ item->text = strdup(text);
+ item->data = data;
+ if (flags & NEWT_FLAG_SELECTED) {
+ item->selected = 1;
+ } else {
+ item->selected = 0;
+ }
+ item->flags = flags;
+ item->branch = NULL;
+ item->depth = numIndexes - 1;
+
+ i = 4 + (3 * item->depth);
+
+ if ((strlen(text) + i + ct->pad) > co->width) {
+ co->width = strlen(text) + i + ct->pad;
+ }
+
+ return 0;
+}
+
+static struct items * findItem(struct items * items, const void * data) {
+ struct items * i;
+
+ while (items) {
+ if (items->data == data) return items;
+ if (items->branch) {
+ i = findItem(items->branch, data);
+ if (i) return i;
+ }
+
+ items = items->next;
+ }
+
+ return NULL;
+}
+
+static void listSelected(struct items * items, int * num, const void ** list, int seqindex) {
+ while (items) {
+ if ((seqindex ? items->selected==seqindex : items->selected) && !items->branch)
+ list[(*num)++] = (void *) items->data;
+ if (items->branch)
+ listSelected(items->branch, num, list, seqindex);
+ items = items->next;
+ }
+}
+
+const void ** newtCheckboxTreeGetSelection(newtComponent co, int *numitems)
+{
+ return newtCheckboxTreeGetMultiSelection(co, numitems, 0);
+}
+
+const void ** newtCheckboxTreeGetMultiSelection(newtComponent co, int *numitems, char seqnum)
+{
+ struct CheckboxTree * ct;
+ const void **retval;
+ int seqindex=0;
+
+ if(!co || !numitems) return NULL;
+
+ ct = co->data;
+
+ if (seqnum) {
+ while( ct->seq[seqindex] && ( ct->seq[seqindex] != seqnum )) seqindex++;
+ } else {
+ seqindex = 0;
+ }
+
+ *numitems = countItems(ct->itemlist, (seqindex ? seqindex : COUNT_SELECTED));
+ if (!*numitems) return NULL;
+
+ retval = malloc(*numitems * sizeof(void *));
+ *numitems = 0;
+ listSelected(ct->itemlist, numitems, retval, seqindex);
+
+ return retval;
+}
+
+newtComponent newtCheckboxTree(int left, int top, int height, int flags) {
+ return newtCheckboxTreeMulti(left, top, height, NULL, flags);
+}
+
+newtComponent newtCheckboxTreeMulti(int left, int top, int height, char *seq, int flags) {
+ newtComponent co;
+ struct CheckboxTree * ct;
+
+ co = malloc(sizeof(*co));
+ ct = malloc(sizeof(struct CheckboxTree));
+ co->callback = NULL;
+ co->data = ct;
+ co->ops = &ctOps;
+ co->takesFocus = 1;
+ co->height = height;
+ co->width = 0;
+ co->isMapped = 0;
+ ct->itemlist = NULL;
+ ct->firstItem = NULL;
+ ct->currItem = NULL;
+ ct->flatList = NULL;
+ if (seq)
+ ct->seq = strdup(seq);
+ else
+ ct->seq = strdup(" *");
+ if (flags & NEWT_FLAG_SCROLL) {
+ ct->sb = newtVerticalScrollbar(left, top, height,
+ COLORSET_LISTBOX, COLORSET_ACTLISTBOX);
+ ct->pad = 2;
+ } else {
+ ct->sb = NULL;
+ ct->pad = 0;
+ }
+
+ return co;
+}
+
+static void ctMapped(newtComponent co, int isMapped) {
+ struct CheckboxTree * ct = co->data;
+
+ co->isMapped = isMapped;
+ if (ct->sb)
+ ct->sb->ops->mapped(ct->sb, isMapped);
+}
+
+static void ctPlace(newtComponent co, int newLeft, int newTop) {
+ struct CheckboxTree * ct = co->data;
+
+ co->top = newTop;
+ co->left = newLeft;
+
+ if (ct->sb)
+ ct->sb->ops->place(ct->sb, co->left + co->width - 1, co->top);
+}
+
+int ctSetItem(newtComponent co, struct items *item, enum newtFlagsSense sense)
+{
+ struct CheckboxTree * ct = co->data;
+ struct items * currItem;
+ struct items * firstItem;
+
+ if (!item)
+ return 1;
+
+ switch(sense) {
+ case NEWT_FLAGS_RESET:
+ item->selected = 0;
+ break;
+ case NEWT_FLAGS_SET:
+ item->selected = 1;
+ break;
+ case NEWT_FLAGS_TOGGLE:
+ if (item->branch)
+ item->selected = !item->selected;
+ else {
+ item->selected++;
+ if (item->selected==strlen(ct->seq))
+ item->selected = 0;
+ }
+ break;
+ }
+
+ if (item->branch) {
+ currItem = *ct->currItem;
+ firstItem = *ct->firstItem;
+
+ buildFlatList(co);
+
+ ct->currItem = ct->flatList;
+ while (*ct->currItem != currItem) ct->currItem++;
+
+ ct->firstItem = ct->flatList;
+ if (ct->flatCount > co->height) {
+ struct items ** last = ct->flatList + ct->flatCount - co->height;
+ while (*ct->firstItem != firstItem && ct->firstItem != last)
+ ct->firstItem++;
+ }
+ }
+
+ return 0;
+}
+
+static void ctSetItems(struct items *item, int selected)
+{
+ for (; item; item = item->next) {
+ if (!item->branch)
+ item->selected = selected;
+ else
+ ctSetItems(item->branch, selected);
+ }
+}
+
+static void ctDraw(newtComponent co) {
+ struct CheckboxTree * ct = co->data;
+ struct items ** item;
+ int i, j;
+ char * spaces = NULL;
+ int currRow = -1;
+
+ if (!co->isMapped) return ;
+
+ if (!ct->firstItem) {
+ buildFlatList(co);
+ ct->firstItem = ct->currItem = ct->flatList;
+ }
+
+ item = ct->firstItem;
+
+ i = 0;
+ while (*item && i < co->height) {
+ newtGotorc(co->top + i, co->left);
+ if (*item == *ct->currItem) {
+ SLsmg_set_color(NEWT_COLORSET_ACTLISTBOX);
+ currRow = co->top + i;
+ } else
+ SLsmg_set_color(NEWT_COLORSET_LISTBOX);
+
+ for (j = 0; j < (*item)->depth; j++)
+ SLsmg_write_string(" ");
+
+ if ((*item)->branch) {
+ if ((*item)->selected)
+ SLsmg_write_string("<-> ");
+ else
+ SLsmg_write_string("<+> ");
+ } else {
+ char tmp[5];
+ snprintf(tmp,5,"[%c] ",ct->seq[(*item)->selected]);
+ SLsmg_write_string(tmp);
+ }
+
+ SLsmg_write_nstring((*item)->text, co->width - 4 -
+ (3 * (*item)->depth));
+ item++;
+ i++;
+ }
+
+ /* There could be empty lines left (i.e. if the user closes an expanded
+ list which is the last thing in the tree, and whose elements are
+ displayed at the bottom of the screen */
+ if (i < co->height) {
+ spaces = alloca(co->width);
+ memset(spaces, ' ', co->width);
+ SLsmg_set_color(NEWT_COLORSET_LISTBOX);
+ }
+ while (i < co->height) {
+ newtGotorc(co->top + i, co->left);
+ SLsmg_write_nstring(spaces, co->width);
+ i++;
+ }
+
+ if(ct->sb) {
+ newtScrollbarSet(ct->sb, ct->currItem - ct->flatList,
+ ct->flatCount - 1);
+ ct->sb->ops->draw(ct->sb);
+ }
+
+ newtGotorc(currRow, co->left + 1);
+}
+
+static void ctDestroy(newtComponent co) {
+ struct CheckboxTree * ct = co->data;
+ struct items * item, * nextitem;
+
+ nextitem = item = ct->itemlist;
+
+ while (item != NULL) {
+ nextitem = item->next;
+ free(item->text);
+ free(item);
+ item = nextitem;
+ }
+
+ free(ct->seq);
+ free(ct);
+ free(co);
+}
+
+struct eventResult ctEvent(newtComponent co, struct event ev) {
+ struct CheckboxTree * ct = co->data;
+ struct eventResult er;
+ struct items ** listEnd, ** lastItem;
+ int key, selnum = 1;
+
+ er.result = ER_IGNORED;
+
+ if(ev.when == EV_EARLY || ev.when == EV_LATE) {
+ return er;
+ }
+
+ switch(ev.event) {
+ case EV_KEYPRESS:
+ key = ev.u.key;
+ if (key == (char) key && key != ' ') {
+ for (selnum = 0; ct->seq[selnum]; selnum++)
+ if (key == ct->seq[selnum])
+ break;
+ if (!ct->seq[selnum])
+ switch (key) {
+ case '-': selnum = 0; break;
+ case '+':
+ case '*': selnum = 1; break;
+ }
+ if (ct->seq[selnum])
+ key = '*';
+ }
+ switch(key) {
+ case ' ':
+ case NEWT_KEY_ENTER:
+ ctSetItem(co, *ct->currItem, NEWT_FLAGS_TOGGLE);
+ er.result = ER_SWALLOWED;
+ if (!(*ct->currItem)->branch || (*ct->currItem)->selected)
+ key = NEWT_KEY_DOWN;
+ else
+ key = '*';
+ break;
+ case '*':
+ if ((*ct->currItem)->branch) {
+ ctSetItems((*ct->currItem)->branch, selnum);
+ if (!(*ct->currItem)->selected)
+ key = NEWT_KEY_DOWN;
+ } else {
+ (*ct->currItem)->selected = selnum;
+ key = NEWT_KEY_DOWN;
+ }
+ er.result = ER_SWALLOWED;
+ break;
+ }
+ switch (key) {
+ case '*':
+ ctDraw(co);
+ if(co->callback) co->callback(co, co->callbackData);
+ return er;
+ case NEWT_KEY_HOME:
+ ct->currItem = ct->flatList;
+ ct->firstItem = ct->flatList;
+ ctDraw(co);
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ return er;
+ case NEWT_KEY_END:
+ ct->currItem = ct->flatList + ct->flatCount - 1;
+ if (ct->flatCount <= co->height)
+ ct->firstItem = ct->flatList;
+ else
+ ct->firstItem = ct->flatList + ct->flatCount - co->height;
+ ctDraw(co);
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ return er;
+ case NEWT_KEY_DOWN:
+ if (ev.u.key != NEWT_KEY_DOWN) {
+ if(co->callback) co->callback(co, co->callbackData);
+ if (strlen(ct->seq) != 2) {
+ ctDraw(co);
+ return er;
+ }
+ }
+ if ((ct->currItem - ct->flatList + 1) < ct->flatCount) {
+ ct->currItem++;
+
+ if (ct->currItem - ct->firstItem >= co->height)
+ ct->firstItem++;
+
+ ctDraw(co);
+ } else if (ev.u.key != NEWT_KEY_DOWN)
+ ctDraw(co);
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ return er;
+ case NEWT_KEY_UP:
+ if (ct->currItem != ct->flatList) {
+ ct->currItem--;
+
+ if (ct->currItem < ct->firstItem)
+ ct->firstItem = ct->currItem;
+
+ ctDraw(co);
+ }
+ er.result = ER_SWALLOWED;
+ if(co->callback) co->callback(co, co->callbackData);
+ return er;
+ case NEWT_KEY_PGUP:
+ if (ct->firstItem - co->height < ct->flatList) {
+ ct->firstItem = ct->currItem = ct->flatList;
+ } else {
+ ct->currItem -= co->height;
+ ct->firstItem -= co->height;
+ }
+
+ ctDraw(co);
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ return er;
+ case NEWT_KEY_PGDN:
+ listEnd = ct->flatList + ct->flatCount - 1;
+ lastItem = ct->firstItem + co->height - 1;
+
+ if (lastItem + co->height > listEnd) {
+ ct->firstItem = listEnd - co->height + 1;
+ ct->currItem = listEnd;
+ } else {
+ ct->currItem += co->height;
+ ct->firstItem += co->height;
+ }
+
+ ctDraw(co);
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ return er;
+ }
+ break;
+
+ case EV_FOCUS:
+ ctDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case EV_UNFOCUS:
+ ctDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+ default:
+ break;
+ }
+
+ return er;
+}
+
+const void * newtCheckboxTreeGetCurrent(newtComponent co) {
+ struct CheckboxTree * ct = co->data;
+
+ if (!ct->currItem) return NULL;
+ return (*ct->currItem)->data;
+}
+
+void newtCheckboxTreeSetEntry(newtComponent co, const void * data, const char * text)
+{
+ struct CheckboxTree * ct;
+ struct items * item;
+ int i;
+
+ if (!co) return;
+ ct = co->data;
+ item = findItem(ct->itemlist, data);
+ if (!item) return;
+
+ free(item->text);
+ item->text = strdup(text);
+
+ i = 4 + (3 * item->depth);
+
+ if ((strlen(text) + i + ct->pad) > co->width) {
+ co->width = strlen(text) + i + ct->pad;
+ }
+
+ ctDraw(co);
+}
+
+char newtCheckboxTreeGetEntryValue(newtComponent co, const void * data)
+{
+ struct CheckboxTree * ct;
+ struct items * item;
+
+ if (!co) return -1;
+ ct = co->data;
+ item = findItem(ct->itemlist, data);
+ if (!item) return -1;
+ if (item->branch)
+ return item->selected ? NEWT_CHECKBOXTREE_EXPANDED : NEWT_CHECKBOXTREE_COLLAPSED;
+ else
+ return ct->seq[item->selected];
+}
+
+void newtCheckboxTreeSetEntryValue(newtComponent co, const void * data, char value)
+{
+ struct CheckboxTree * ct;
+ struct items * item;
+ int i;
+
+ if (!co) return;
+ ct = co->data;
+ item = findItem(ct->itemlist, data);
+ if (!item || item->branch) return;
+
+ for(i = 0; ct->seq[i]; i++)
+ if (value == ct->seq[i])
+ break;
+
+ if (!ct->seq[i]) return;
+ item->selected = i;
+
+ ctDraw(co);
+}
+
diff --git a/mdk-stage1/newt/entry.c b/mdk-stage1/newt/entry.c
new file mode 100644
index 000000000..154edba71
--- /dev/null
+++ b/mdk-stage1/newt/entry.c
@@ -0,0 +1,376 @@
+#include <ctype.h>
+#include <slang.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+struct entry {
+ int flags;
+ char * buf;
+ char ** resultPtr;
+ int bufAlloced;
+ int bufUsed; /* amount of the buffer that's been used */
+ int cursorPosition; /* cursor *in the string* on on screen */
+ int firstChar; /* first character position being shown */
+ newtEntryFilter filter;
+ void * filterData;
+};
+
+static void entryDraw(newtComponent co);
+static void entryDestroy(newtComponent co);
+static struct eventResult entryEvent(newtComponent co,
+ struct event ev);
+
+static struct eventResult entryHandleKey(newtComponent co, int key);
+
+static struct componentOps entryOps = {
+ entryDraw,
+ entryEvent,
+ entryDestroy,
+ newtDefaultPlaceHandler,
+ newtDefaultMappedHandler,
+} ;
+
+void newtEntrySet(newtComponent co, const char * value, int cursorAtEnd) {
+ struct entry * en = co->data;
+
+ if ((strlen(value) + 1) > (unsigned int)en->bufAlloced) {
+ free(en->buf);
+ en->bufAlloced = strlen(value) + 1;
+ en->buf = malloc(en->bufAlloced);
+ if (en->resultPtr) *en->resultPtr = en->buf;
+ }
+ memset(en->buf, 0, en->bufAlloced); /* clear the buffer */
+ strcpy(en->buf, value);
+ en->bufUsed = strlen(value);
+ en->firstChar = 0;
+ if (cursorAtEnd)
+ en->cursorPosition = en->bufUsed;
+ else
+ en->cursorPosition = 0;
+
+ entryDraw(co);
+} ;
+
+newtComponent newtEntry(int left, int top, const char * initialValue, int width,
+ char ** resultPtr, int flags) {
+ newtComponent co;
+ struct entry * en;
+
+ co = malloc(sizeof(*co));
+ en = malloc(sizeof(struct entry));
+ co->data = en;
+
+ co->top = top;
+ co->left = left;
+ co->height = 1;
+ co->width = width;
+ co->isMapped = 0;
+ co->callback = NULL;
+
+ co->ops = &entryOps;
+
+ en->flags = flags;
+ en->cursorPosition = 0;
+ en->firstChar = 0;
+ en->bufUsed = 0;
+ en->bufAlloced = width + 1;
+ en->filter = NULL;
+
+ if (!(en->flags & NEWT_FLAG_DISABLED))
+ co->takesFocus = 1;
+ else
+ co->takesFocus = 0;
+
+ if (initialValue && strlen(initialValue) > (unsigned int)width) {
+ en->bufAlloced = strlen(initialValue) + 1;
+ }
+ en->buf = malloc(en->bufAlloced);
+ en->resultPtr = resultPtr;
+ if (en->resultPtr) *en->resultPtr = en->buf;
+
+ memset(en->buf, 0, en->bufAlloced);
+ if (initialValue) {
+ strcpy(en->buf, initialValue);
+ en->bufUsed = strlen(initialValue);
+ en->cursorPosition = en->bufUsed;
+ } else {
+ *en->buf = '\0';
+ en->bufUsed = 0;
+ en->cursorPosition = 0;
+ }
+
+ return co;
+}
+
+static void entryDraw(newtComponent co) {
+ struct entry * en = co->data;
+ int i;
+ char * chptr;
+ int len;
+
+ if (!co->isMapped) return;
+
+ if (en->flags & NEWT_FLAG_DISABLED)
+ SLsmg_set_color(NEWT_COLORSET_DISENTRY);
+ else
+ SLsmg_set_color(NEWT_COLORSET_ENTRY);
+
+ if (en->flags & NEWT_FLAG_HIDDEN) {
+ newtGotorc(co->top, co->left);
+ for (i = 0; i < co->width; i++)
+ SLsmg_write_char('_');
+ newtGotorc(co->top, co->left);
+
+ return;
+ }
+
+ newtGotorc(co->top, co->left);
+
+ if (en->cursorPosition < en->firstChar) {
+ /* scroll to the left */
+ en->firstChar = en->cursorPosition;
+ } else if ((en->firstChar + co->width) <= en->cursorPosition) {
+ /* scroll to the right */
+ en->firstChar = en->cursorPosition - co->width + 1;
+ }
+
+ chptr = en->buf + en->firstChar;
+
+ if (en->flags & NEWT_FLAG_PASSWORD) {
+ char *tmpptr, *p;
+
+ tmpptr = alloca(strlen(chptr+2));
+ strcpy(tmpptr, chptr);
+ for (p = tmpptr; *p; p++)
+ *p = '*';
+ chptr = tmpptr;
+ }
+
+ len = strlen(chptr);
+
+ if (len <= co->width) {
+ i = len;
+ SLsmg_write_string(chptr);
+ while (i < co->width) {
+ SLsmg_write_char('_');
+ i++;
+ }
+ } else {
+ SLsmg_write_nstring(chptr, co->width);
+ }
+
+ if (en->flags & NEWT_FLAG_HIDDEN)
+ newtGotorc(co->top, co->left);
+ else
+ newtGotorc(co->top, co->left + (en->cursorPosition - en->firstChar));
+}
+
+void newtEntrySetFlags(newtComponent co, int flags, enum newtFlagsSense sense) {
+ struct entry * en = co->data;
+ int row, col;
+
+ en->flags = newtSetFlags(en->flags, flags, sense);
+
+ if (!(en->flags & NEWT_FLAG_DISABLED))
+ co->takesFocus = 1;
+ else
+ co->takesFocus = 0;
+
+ newtGetrc(&row, &col);
+ entryDraw(co);
+ newtGotorc(row, col);
+}
+
+static void entryDestroy(newtComponent co) {
+ struct entry * en = co->data;
+
+ free(en->buf);
+ free(en);
+ free(co);
+}
+
+static struct eventResult entryEvent(newtComponent co,
+ struct event ev) {
+ struct entry * en = co->data;
+ struct eventResult er;
+ int ch;
+
+ if (ev.when == EV_NORMAL) {
+ switch (ev.event) {
+ case EV_FOCUS:
+ newtCursorOn();
+ if (en->flags & NEWT_FLAG_HIDDEN)
+ newtGotorc(co->top, co->left);
+ else
+ newtGotorc(co->top, co->left +
+ (en->cursorPosition - en->firstChar));
+ er.result = ER_SWALLOWED;
+ break;
+
+ case EV_UNFOCUS:
+ newtCursorOff();
+ newtGotorc(0, 0);
+ er.result = ER_SWALLOWED;
+ if (co->callback)
+ co->callback(co, co->callbackData);
+ break;
+
+ case EV_KEYPRESS:
+ ch = ev.u.key;
+ if (en->filter)
+ ch = en->filter(co, en->filterData, ch, en->cursorPosition);
+ if (ch) er = entryHandleKey(co, ch);
+ break;
+
+ case EV_MOUSE:
+ if ((ev.u.mouse.type == MOUSE_BUTTON_DOWN) &&
+ (en->flags ^ NEWT_FLAG_HIDDEN)) {
+ if (strlen(en->buf) >= ev.u.mouse.x - co->left) {
+ en->cursorPosition = ev.u.mouse.x - co->left;
+ newtGotorc(co->top,
+ co->left +(en->cursorPosition - en->firstChar));
+ } else {
+ en->cursorPosition = strlen(en->buf);
+ newtGotorc(co->top,
+ co->left +(en->cursorPosition - en->firstChar));
+ }
+ }
+ break;
+ }
+ } else
+ er.result = ER_IGNORED;
+
+ return er;
+}
+
+static struct eventResult entryHandleKey(newtComponent co, int key) {
+ struct entry * en = co->data;
+ struct eventResult er;
+ char * chptr, * insPoint;
+
+ er.result = ER_SWALLOWED;
+ switch (key) {
+ case '\r': /* Return */
+ if (en->flags & NEWT_FLAG_RETURNEXIT) {
+ er.result = ER_EXITFORM;
+ } else {
+ er.result = ER_NEXTCOMP;
+ }
+ break;
+
+ case '\001': /* ^A */
+ case NEWT_KEY_HOME:
+ en->cursorPosition = 0;
+ break;
+
+ case '\005': /* ^E */
+ case NEWT_KEY_END:
+ en->cursorPosition = en->bufUsed;
+ break;
+
+ case '\013': /* ^K */
+ en->bufUsed = en->cursorPosition;
+ memset(en->buf + en->bufUsed, 0, en->bufAlloced - en->bufUsed);
+ break;
+
+ case '\002': /* ^B */
+ case NEWT_KEY_LEFT:
+ if (en->cursorPosition)
+ en->cursorPosition--;
+ break;
+
+ case '\004':
+ case NEWT_KEY_DELETE:
+ chptr = en->buf + en->cursorPosition;
+ if (*chptr) {
+ chptr++;
+ while (*chptr) {
+ *(chptr - 1) = *chptr;
+ chptr++;
+ }
+ *(chptr - 1) = '\0';
+ en->bufUsed--;
+ }
+ break;
+
+ case NEWT_KEY_BKSPC:
+ if (en->cursorPosition) {
+ /* if this isn't true, there's nothing to erase */
+ chptr = en->buf + en->cursorPosition;
+ en->bufUsed--;
+ en->cursorPosition--;
+ while (*chptr) {
+ *(chptr - 1) = *chptr;
+ chptr++;
+ }
+ *(chptr - 1) = '\0';
+ }
+ break;
+
+ case '\006': /* ^B */
+ case NEWT_KEY_RIGHT:
+ if (en->cursorPosition < en->bufUsed)
+ en->cursorPosition++;
+ break;
+
+ default:
+ if ((key >= 0x20 && key <= 0x7e) || (key >= 0xa0 && key <= 0xff)) {
+ if (!(en->flags & NEWT_FLAG_SCROLL) && en->bufUsed >= co->width) {
+ SLtt_beep();
+ break;
+ }
+
+ if ((en->bufUsed + 1) == en->bufAlloced) {
+ en->bufAlloced += 20;
+ en->buf = realloc(en->buf, en->bufAlloced);
+ if (en->resultPtr) *en->resultPtr = en->buf;
+ memset(en->buf + en->bufUsed + 1, 0, 20);
+ }
+
+ if (en->cursorPosition == en->bufUsed) {
+ en->bufUsed++;
+ } else {
+ /* insert the new character */
+
+ /* chptr is the last character in the string */
+ chptr = (en->buf + en->bufUsed) - 1;
+ if ((en->bufUsed + 1) == en->bufAlloced) {
+ /* this string fills the buffer, so clip it */
+ chptr--;
+ } else
+ en->bufUsed++;
+
+ insPoint = en->buf + en->cursorPosition;
+
+ while (chptr >= insPoint) {
+ *(chptr + 1) = *chptr;
+ chptr--;
+ }
+
+ }
+
+ en->buf[en->cursorPosition++] = key;
+ } else {
+ er.result = ER_IGNORED;
+ }
+ }
+
+ entryDraw(co);
+
+ return er;
+}
+
+char * newtEntryGetValue(newtComponent co) {
+ struct entry * en = co->data;
+
+ return en->buf;
+}
+
+void newtEntrySetFilter(newtComponent co, newtEntryFilter filter, void * data) {
+ struct entry * en = co->data;
+ en->filter = filter;
+ en->filterData = data;
+}
diff --git a/mdk-stage1/newt/form.c b/mdk-stage1/newt/form.c
new file mode 100644
index 000000000..4ad465e38
--- /dev/null
+++ b/mdk-stage1/newt/form.c
@@ -0,0 +1,712 @@
+#include <unistd.h>
+#include <slang.h>
+#include <stdarg.h>
+#include <stdlib.h>
+#include <sys/time.h>
+#include <sys/types.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+
+/****************************************************************************
+ These forms handle vertical scrolling of components with a height of 1
+
+ Horizontal scrolling won't work, and scrolling large widgets will fail
+ miserably. It shouldn't be too hard to fix either of those if anyone
+ cares to. I only use scrolling for listboxes and text boxes though so
+ I didn't bother.
+*****************************************************************************/
+
+struct element {
+ int top, left; /* Actual, not virtual. These are translated */
+ newtComponent co; /* into actual through vertOffset */
+};
+
+struct fdInfo {
+ int fd;
+ int flags;
+};
+
+struct form {
+ int numCompsAlloced;
+ struct element * elements;
+ int numComps;
+ int currComp;
+ int fixedHeight;
+ int flags;
+ int vertOffset;
+ newtComponent vertBar, exitComp;
+ const char * help;
+ int numRows;
+ int * hotKeys;
+ int numHotKeys;
+ int background;
+ int beenSet;
+ int numFds;
+ struct fdInfo * fds;
+ int maxFd;
+ int timer; /* in milliseconds */
+ struct timeval lastTimeout;
+ void * helpTag;
+ newtCallback helpCb;
+};
+
+static void gotoComponent(struct form * form, int newComp);
+static struct eventResult formEvent(newtComponent co, struct event ev);
+static struct eventResult sendEvent(newtComponent comp, struct event ev);
+static void formPlace(newtComponent co, int left, int top);
+
+/* Global, ick */
+static newtCallback helpCallback;
+
+/* this isn't static as grid.c tests against it to find forms */
+struct componentOps formOps = {
+ newtDrawForm,
+ formEvent,
+ newtFormDestroy,
+ formPlace,
+ newtDefaultMappedHandler,
+} ;
+
+static inline int componentFits(newtComponent co, int compNum) {
+ struct form * form = co->data;
+ struct element * el = form->elements + compNum;
+
+ if ((co->top + form->vertOffset) > el->top) return 0;
+ if ((co->top + form->vertOffset + co->height) <
+ (el->top + el->co->height)) return 0;
+
+ return 1;
+}
+
+newtComponent newtForm(newtComponent vertBar, void * help, int flags) {
+ newtComponent co;
+ struct form * form;
+
+ co = malloc(sizeof(*co));
+ form = malloc(sizeof(*form));
+ co->data = form;
+ co->width = 0;
+ co->height = 0;
+ co->top = -1;
+ co->left = -1;
+ co->isMapped = 0;
+
+ co->takesFocus = 0; /* we may have 0 components */
+ co->ops = &formOps;
+
+ form->help = help;
+ form->flags = flags;
+ form->numCompsAlloced = 5;
+ form->numComps = 0;
+ form->currComp = -1;
+ form->vertOffset = 0;
+ form->fixedHeight = 0;
+ form->numRows = 0;
+ form->numFds = 0;
+ form->maxFd = 0;
+ form->fds = NULL;
+ form->beenSet = 0;
+ form->elements = malloc(sizeof(*(form->elements)) * form->numCompsAlloced);
+
+ form->background = COLORSET_WINDOW;
+ form->hotKeys = malloc(sizeof(int));
+ form->numHotKeys = 0;
+ form->timer = 0;
+ form->lastTimeout.tv_sec = form->lastTimeout.tv_usec = 0;
+ if (!(form->flags & NEWT_FLAG_NOF12)) {
+ newtFormAddHotKey(co, NEWT_KEY_F12);
+ }
+
+ if (vertBar)
+ form->vertBar = vertBar;
+ else
+ form->vertBar = NULL;
+
+ form->helpTag = help;
+ form->helpCb = helpCallback;
+
+ return co;
+}
+
+newtComponent newtFormGetCurrent(newtComponent co) {
+ struct form * form = co->data;
+
+ return form->elements[form->currComp].co;
+}
+
+void newtFormSetCurrent(newtComponent co, newtComponent subco) {
+ struct form * form = co->data;
+ int i, new;
+
+ for (i = 0; i < form->numComps; i++) {
+ if (form->elements[i].co == subco) break;
+ }
+
+ if (form->elements[i].co != subco) return;
+ new = i;
+
+ if (co->isMapped && !componentFits(co, new)) {
+ gotoComponent(form, -1);
+ form->vertOffset = form->elements[new].top - co->top - 1;
+ if (form->vertOffset > (form->numRows - co->height))
+ form->vertOffset = form->numRows - co->height;
+ }
+
+ gotoComponent(form, new);
+}
+
+void newtFormSetTimer(newtComponent co, int millisecs) {
+ struct form * form = co->data;
+
+ form->timer = millisecs;
+ form->lastTimeout.tv_usec = 0;
+ form->lastTimeout.tv_sec = 0;
+}
+
+void newtFormSetHeight(newtComponent co, int height) {
+ struct form * form = co->data;
+
+ form->fixedHeight = 1;
+ co->height = height;
+}
+
+void newtFormSetWidth(newtComponent co, int width) {
+ co->width = width;
+}
+
+void newtFormAddComponent(newtComponent co, newtComponent newco) {
+ struct form * form = co->data;
+
+ co->takesFocus = 1;
+
+ if (form->numCompsAlloced == form->numComps) {
+ form->numCompsAlloced += 5;
+ form->elements = realloc(form->elements,
+ sizeof(*(form->elements)) * form->numCompsAlloced);
+ }
+
+ /* we grab real values for these a bit later */
+ form->elements[form->numComps].left = -2;
+ form->elements[form->numComps].top = -2;
+ form->elements[form->numComps].co = newco;
+
+ if (newco->takesFocus && form->currComp == -1)
+ form->currComp = form->numComps;
+
+ form->numComps++;
+}
+
+void newtFormAddComponents(newtComponent co, ...) {
+ va_list ap;
+ newtComponent subco;
+
+ va_start(ap, co);
+
+ while ((subco = va_arg(ap, newtComponent)))
+ newtFormAddComponent(co, subco);
+
+ va_end(ap);
+}
+
+static void formPlace(newtComponent co, int left, int top) {
+ struct form * form = co->data;
+ int vertDelta, horizDelta;
+ struct element * el;
+ int i;
+
+ newtFormSetSize(co);
+
+ vertDelta = top - co->top;
+ horizDelta = left - co->left;
+ co->top = top;
+ co->left = left;
+
+ for (i = 0, el = form->elements; i < form->numComps; i++, el++) {
+ el->co->top += vertDelta;
+ el->top += vertDelta;
+ el->co->left += horizDelta;
+ el->left += horizDelta;
+ }
+}
+
+void newtDrawForm(newtComponent co) {
+ struct form * form = co->data;
+ struct element * el;
+ int i;
+
+ newtFormSetSize(co);
+
+ SLsmg_set_color(form->background);
+ newtClearBox(co->left, co->top, co->width, co->height);
+ for (i = 0, el = form->elements; i < form->numComps; i++, el++) {
+ /* the scrollbar *always* fits somewhere */
+ if (el->co == form->vertBar) {
+ el->co->ops->mapped(el->co, 1);
+ el->co->ops->draw(el->co);
+ } else {
+ /* only draw it if it'll fit on the screen vertically */
+ if (componentFits(co, i)) {
+ el->co->top = el->top - form->vertOffset;
+ el->co->ops->mapped(el->co, 1);
+ el->co->ops->draw(el->co);
+ } else {
+ el->co->ops->mapped(el->co, 0);
+ }
+ }
+ }
+
+ if (form->vertBar)
+ newtScrollbarSet(form->vertBar, form->vertOffset,
+ form->numRows - co->height);
+}
+
+static struct eventResult formEvent(newtComponent co, struct event ev) {
+ struct form * form = co->data;
+ newtComponent subco = form->elements[form->currComp].co;
+ int new, wrap = 0;
+ struct eventResult er;
+ int dir = 0, page = 0;
+ int i, num, found;
+ struct element * el;
+
+ er.result = ER_IGNORED;
+ if (!form->numComps) return er;
+
+ subco = form->elements[form->currComp].co;
+
+ switch (ev.when) {
+ case EV_EARLY:
+ if (ev.event == EV_KEYPRESS) {
+ if (ev.u.key == NEWT_KEY_TAB) {
+ er.result = ER_SWALLOWED;
+ dir = 1;
+ wrap = 1;
+ } else if (ev.u.key == NEWT_KEY_UNTAB) {
+ er.result = ER_SWALLOWED;
+ dir = -1;
+ wrap = 1;
+ }
+ }
+
+ if (form->numComps) {
+ i = form->currComp;
+ num = 0;
+ while (er.result == ER_IGNORED && num != form->numComps ) {
+ er = form->elements[i].co->ops->event(form->elements[i].co, ev);
+
+ num++;
+ i++;
+ if (i == form->numComps) i = 0;
+ }
+ }
+
+ break;
+
+ case EV_NORMAL:
+ if (ev.event == EV_MOUSE) {
+ found = 0;
+ for (i = 0, el = form->elements; i < form->numComps; i++, el++) {
+ if ((el->co->top <= ev.u.mouse.y) &&
+ (el->co->top + el->co->height > ev.u.mouse.y) &&
+ (el->co->left <= ev.u.mouse.x) &&
+ (el->co->left + el->co->width > ev.u.mouse.x)) {
+ found = 1;
+ if (el->co->takesFocus) {
+ gotoComponent(form, i);
+ subco = form->elements[form->currComp].co;
+ }
+ }
+ /* If we did not find a co to send this event to, we
+ should just swallow the event here. */
+ }
+ if (!found) {
+ er.result = ER_SWALLOWED;
+
+ return er;
+ }
+ }
+ er = subco->ops->event(subco, ev);
+ switch (er.result) {
+ case ER_NEXTCOMP:
+ er.result = ER_SWALLOWED;
+ dir = 1;
+ break;
+
+ case ER_EXITFORM:
+ form->exitComp = subco;
+ break;
+
+ default:
+ break;
+ }
+ break;
+
+ case EV_LATE:
+ er = subco->ops->event(subco, ev);
+
+ if (er.result == ER_IGNORED) {
+ switch (ev.u.key) {
+ case NEWT_KEY_UP:
+ case NEWT_KEY_LEFT:
+ case NEWT_KEY_BKSPC:
+ er.result = ER_SWALLOWED;
+ dir = -1;
+ break;
+
+ case NEWT_KEY_DOWN:
+ case NEWT_KEY_RIGHT:
+ er.result = ER_SWALLOWED;
+ dir = 1;
+ break;
+
+ case NEWT_KEY_PGUP:
+ er.result = ER_SWALLOWED;
+ dir = -1;
+ page = 1;
+ break;
+
+ case NEWT_KEY_PGDN:
+ er.result = ER_SWALLOWED;
+ dir = 1;
+ page = 1;
+ break;
+ }
+ }
+ }
+
+ if (dir) {
+ new = form->currComp;
+
+ if (page) {
+ new += dir * co->height;
+ if (new < 0)
+ new = 0;
+ else if (new >= form->numComps)
+ new = (form->numComps - 1);
+
+ while (!form->elements[new].co->takesFocus)
+ new = new - dir;
+ } else {
+ do {
+ new += dir;
+
+ if (wrap) {
+ if (new < 0)
+ new = form->numComps - 1;
+ else if (new >= form->numComps)
+ new = 0;
+ } else if (new < 0 || new >= form->numComps)
+ return er;
+ } while (!form->elements[new].co->takesFocus);
+ }
+
+ /* make sure this component is visible */
+ if (!componentFits(co, new)) {
+ gotoComponent(form, -1);
+
+ if (dir < 0) {
+ /* make the new component the first one */
+ form->vertOffset = form->elements[new].top - co->top;
+ } else {
+ /* make the new component the last one */
+ form->vertOffset = (form->elements[new].top +
+ form->elements[new].co->height) -
+ (co->top + co->height);
+ }
+
+ if (form->vertOffset < 0) form->vertOffset = 0;
+ if (form->vertOffset > (form->numRows - co->height))
+ form->vertOffset = form->numRows - co->height;
+
+ newtDrawForm(co);
+ }
+
+ gotoComponent(form, new);
+ er.result = ER_SWALLOWED;
+ }
+
+ return er;
+}
+
+/* this also destroys all of the components on the form */
+void newtFormDestroy(newtComponent co) {
+ newtComponent subco;
+ struct form * form = co->data;
+ int i;
+
+ /* first, destroy all of the components */
+ for (i = 0; i < form->numComps; i++) {
+ subco = form->elements[i].co;
+ if (subco->ops->destroy) {
+ subco->ops->destroy(subco);
+ } else {
+ if (subco->data) free(subco->data);
+ free(subco);
+ }
+ }
+
+ if (form->hotKeys) free(form->hotKeys);
+
+ free(form->elements);
+ free(form);
+ free(co);
+}
+
+newtComponent newtRunForm(newtComponent co) {
+ struct newtExitStruct es;
+
+ newtFormRun(co, &es);
+ if (es.reason == NEWT_EXIT_HOTKEY) {
+ if (es.u.key == NEWT_KEY_F12) {
+ es.reason = NEWT_EXIT_COMPONENT;
+ es.u.co = co;
+ } else {
+ return NULL;
+ }
+ }
+
+ return es.u.co;
+}
+
+void newtFormAddHotKey(newtComponent co, int key) {
+ struct form * form = co->data;
+
+ form->numHotKeys++;
+ form->hotKeys = realloc(form->hotKeys, sizeof(int) * form->numHotKeys);
+ form->hotKeys[form->numHotKeys - 1] = key;
+}
+
+void newtFormSetSize(newtComponent co) {
+ struct form * form = co->data;
+ int delta, i;
+ struct element * el;
+
+ if (form->beenSet) return;
+
+ form->beenSet = 1;
+
+ if (!form->numComps) return;
+
+ co->width = 0;
+ if (!form->fixedHeight) co->height = 0;
+
+ co->top = form->elements[0].co->top;
+ co->left = form->elements[0].co->left;
+ for (i = 0, el = form->elements; i < form->numComps; i++, el++) {
+ if (el->co->ops == &formOps)
+ newtFormSetSize(el->co);
+
+ el->left = el->co->left;
+ el->top = el->co->top;
+
+ if (co->left > el->co->left) {
+ delta = co->left - el->co->left;
+ co->left -= delta;
+ co->width += delta;
+ }
+
+ if (co->top > el->co->top) {
+ delta = co->top - el->co->top;
+ co->top -= delta;
+ if (!form->fixedHeight)
+ co->height += delta;
+ }
+
+ if ((co->left + co->width) < (el->co->left + el->co->width))
+ co->width = (el->co->left + el->co->width) - co->left;
+
+ if (!form->fixedHeight) {
+ if ((co->top + co->height) < (el->co->top + el->co->height))
+ co->height = (el->co->top + el->co->height) - co->top;
+ }
+
+ if ((el->co->top + el->co->height - co->top) > form->numRows) {
+ form->numRows = el->co->top + el->co->height - co->top;
+ }
+ }
+}
+
+void newtFormRun(newtComponent co, struct newtExitStruct * es) {
+ struct form * form = co->data;
+ struct event ev;
+ struct eventResult er;
+ int key, i, max;
+ int done = 0;
+ fd_set readSet, writeSet;
+ struct timeval nextTimeout, now, timeout;
+
+ newtFormSetSize(co);
+ /* draw all of the components */
+ newtDrawForm(co);
+
+ if (form->currComp == -1) {
+ gotoComponent(form, 0);
+ } else
+ gotoComponent(form, form->currComp);
+
+ while (!done) {
+ newtRefresh();
+
+ FD_ZERO(&readSet);
+ FD_ZERO(&writeSet);
+ FD_SET(0, &readSet);
+ max = form->maxFd;
+
+ for (i = 0; i < form->numFds; i++) {
+ if (form->fds[i].flags & NEWT_FD_READ)
+ FD_SET(form->fds[i].fd, &readSet);
+ if (form->fds[i].flags & NEWT_FD_WRITE)
+ FD_SET(form->fds[i].fd, &writeSet);
+ }
+
+ if (form->timer) {
+ /* Calculate when we next need to return with a timeout. Do
+ this inside the loop in case a callback resets the timer. */
+ if (!form->lastTimeout.tv_sec && !form->lastTimeout.tv_usec)
+ gettimeofday(&form->lastTimeout, NULL);
+
+ nextTimeout.tv_sec = form->lastTimeout.tv_sec +
+ (form->timer / 1000);
+ nextTimeout.tv_usec = form->lastTimeout.tv_usec +
+ (form->timer % 1000) * 1000;
+
+ gettimeofday(&now, 0);
+
+ if (now.tv_sec > nextTimeout.tv_sec) {
+ timeout.tv_sec = timeout.tv_usec = 0;
+ } else if (now.tv_sec == nextTimeout.tv_sec) {
+ timeout.tv_sec = 0;
+ if (now.tv_usec > nextTimeout.tv_usec)
+ timeout.tv_usec = 0;
+ else
+ timeout.tv_usec = nextTimeout.tv_usec - now.tv_usec;
+ } else if (now.tv_sec < nextTimeout.tv_sec) {
+ timeout.tv_sec = nextTimeout.tv_sec - now.tv_sec;
+ if (now.tv_usec > nextTimeout.tv_usec)
+ timeout.tv_sec--,
+ timeout.tv_usec = nextTimeout.tv_usec + 1000000 -
+ now.tv_usec;
+ else
+ timeout.tv_usec = nextTimeout.tv_usec - now.tv_usec;
+ }
+ } else {
+ timeout.tv_sec = timeout.tv_usec = 0;
+ }
+
+ i = select(max + 1, &readSet, &writeSet, NULL,
+ form->timer ? &timeout : NULL);
+ if (i < 0) continue; /* ?? What should we do here? */
+
+ if (i == 0) {
+ done = 1;
+ es->reason = NEWT_EXIT_TIMER;
+ gettimeofday(&form->lastTimeout, NULL);
+ } else
+ {
+ if (FD_ISSET(0, &readSet)) {
+
+ key = newtGetKey();
+
+ if (key == NEWT_KEY_RESIZE) {
+ /* newtResizeScreen(1); */
+ continue;
+ }
+
+ for (i = 0; i < form->numHotKeys; i++) {
+ if (form->hotKeys[i] == key) {
+ es->reason = NEWT_EXIT_HOTKEY;
+ es->u.key = key;
+ done = 1;
+ break;
+ }
+ }
+
+ if (key == NEWT_KEY_F1 && form->helpTag && form->helpCb)
+ form->helpCb(co, form->helpTag);
+
+ if (!done) {
+ ev.event = EV_KEYPRESS;
+ ev.u.key = key;
+
+ er = sendEvent(co, ev);
+
+ if (er.result == ER_EXITFORM) {
+ done = 1;
+ es->reason = NEWT_EXIT_COMPONENT;
+ es->u.co = form->exitComp;
+ }
+ }
+ } else {
+ es->reason = NEWT_EXIT_FDREADY;
+ done = 1;
+ }
+ }
+ }
+ newtRefresh();
+}
+
+static struct eventResult sendEvent(newtComponent co, struct event ev) {
+ struct eventResult er;
+
+ ev.when = EV_EARLY;
+ er = co->ops->event(co, ev);
+
+ if (er.result == ER_IGNORED) {
+ ev.when = EV_NORMAL;
+ er = co->ops->event(co, ev);
+ }
+
+ if (er.result == ER_IGNORED) {
+ ev.when = EV_LATE;
+ er = co->ops->event(co, ev);
+ }
+
+ return er;
+}
+
+static void gotoComponent(struct form * form, int newComp) {
+ struct event ev;
+
+ if (form->currComp != -1) {
+ ev.event = EV_UNFOCUS;
+ sendEvent(form->elements[form->currComp].co, ev);
+ }
+
+ form->currComp = newComp;
+
+ if (form->currComp != -1) {
+ ev.event = EV_FOCUS;
+ ev.when = EV_NORMAL;
+ sendEvent(form->elements[form->currComp].co, ev);
+ }
+}
+
+void newtComponentAddCallback(newtComponent co, newtCallback f, void * data) {
+ co->callback = f;
+ co->callbackData = data;
+}
+
+void newtComponentTakesFocus(newtComponent co, int val) {
+ co->takesFocus = val;
+}
+
+void newtFormSetBackground(newtComponent co, int color) {
+ struct form * form = co->data;
+
+ form->background = color;
+}
+
+void newtFormWatchFd(newtComponent co, int fd, int fdFlags) {
+ struct form * form = co->data;
+
+ form->fds = realloc(form->fds, (form->numFds + 1) * sizeof(*form->fds));
+ form->fds[form->numFds].fd = fd;
+ form->fds[form->numFds++].flags = fdFlags;
+ if (form->maxFd < fd) form->maxFd = fd;
+}
+
+void newtSetHelpCallback(newtCallback cb) {
+ helpCallback = cb;
+}
diff --git a/mdk-stage1/newt/grid.c b/mdk-stage1/newt/grid.c
new file mode 100644
index 000000000..433011396
--- /dev/null
+++ b/mdk-stage1/newt/grid.c
@@ -0,0 +1,389 @@
+#include <alloca.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+struct gridField {
+ enum newtGridElement type;
+ union {
+ newtGrid grid;
+ newtComponent co;
+ } u;
+ int padLeft, padTop, padRight, padBottom;
+ int anchor;
+ int flags;
+};
+
+struct grid_s {
+ int rows, cols;
+ int width, height; /* totals, -1 means unknown */
+ struct gridField ** fields;
+};
+
+/* this is a bit of a hack */
+extern struct componentOps formOps[];
+
+newtGrid newtCreateGrid(int cols, int rows) {
+ newtGrid grid;
+
+ grid = malloc(sizeof(*grid));
+ grid->rows = rows;
+ grid->cols = cols;
+
+ grid->fields = malloc(sizeof(*grid->fields) * cols);
+ while (cols--) {
+ grid->fields[cols] = malloc(sizeof(**(grid->fields)) * rows);
+ memset(grid->fields[cols], 0, sizeof(**(grid->fields)) * rows);
+ }
+
+ grid->width = grid->height = -1;
+
+ return grid;
+}
+
+void newtGridSetField(newtGrid grid, int col, int row,
+ enum newtGridElement type, void * val, int padLeft,
+ int padTop, int padRight, int padBottom, int anchor,
+ int flags) {
+ struct gridField * field = &grid->fields[col][row];
+
+ if (field->type == NEWT_GRID_SUBGRID)
+ newtGridFree(field->u.grid, 1);
+
+ field->type = type;
+ field->u.co = (void *) val;
+
+ field->padLeft = padLeft;
+ field->padRight = padRight;
+ field->padTop = padTop;
+ field->padBottom = padBottom;
+ field->anchor = anchor;
+ field->flags = flags;
+
+ grid->width = grid->height = -1;
+}
+
+static void distSpace(int extra, int items, int * list) {
+ int all, some, i;
+
+ all = extra / items;
+ some = extra % items;
+ for (i = 0; i < items; i++) {
+ list[i] += all;
+ if (some) {
+ list[i]++;
+ some--;
+ }
+ }
+}
+
+static void shuffleGrid(newtGrid grid, int left, int top, int set) {
+ struct gridField * field;
+ int row, col;
+ int i, j;
+ int minWidth, minHeight;
+ int * widths, * heights;
+ int thisLeft, thisTop;
+ int x, y, remx, remy;
+
+ widths = alloca(sizeof(*widths) * grid->cols);
+ memset(widths, 0, sizeof(*widths) * grid->cols);
+ heights = alloca(sizeof(*heights) * grid->rows);
+ memset(heights, 0, sizeof(*heights) * grid->rows);
+
+ minWidth = 0;
+ for (row = 0; row < grid->rows; row++) {
+ i = 0;
+ for (col = 0; col < grid->cols; col++) {
+ field = &grid->fields[col][row];
+ if (field->type == NEWT_GRID_SUBGRID) {
+ /* we'll have to redo this later */
+ if (field->u.grid->width == -1)
+ shuffleGrid(field->u.grid, left, top, 0);
+ j = field->u.grid->width;
+ } else if (field->type == NEWT_GRID_COMPONENT) {
+ if (field->u.co->ops == formOps)
+ newtFormSetSize(field->u.co);
+ j = field->u.co->width;
+ } else
+ j = 0;
+
+ j += field->padLeft + field->padRight;
+
+ if (j > widths[col]) widths[col] = j;
+ i += widths[col];
+ }
+
+ if (i > minWidth) minWidth = i;
+ }
+
+ minHeight = 0;
+ for (col = 0; col < grid->cols; col++) {
+ i = 0;
+ for (row = 0; row < grid->rows; row++) {
+ field = &grid->fields[col][row];
+ if (field->type == NEWT_GRID_SUBGRID) {
+ /* we'll have to redo this later */
+ if (field->u.grid->height == -1)
+ shuffleGrid(field->u.grid, 0, 0, 0);
+ j = field->u.grid->height;
+ } else if (field->type == NEWT_GRID_COMPONENT){
+ j = field->u.co->height;
+ } else
+ j = 0;
+
+ j += field->padTop + field->padBottom;
+
+ if (j > heights[row]) heights[row] = j;
+ i += heights[row];
+ }
+
+ if (i > minHeight) minHeight = i;
+ }
+
+ /* this catches the -1 case */
+ if (grid->width < minWidth) grid->width = minWidth; /* ack! */
+ if (grid->height < minHeight) grid->height = minHeight; /* ditto! */
+
+ if (!set) return;
+
+ distSpace(grid->width - minWidth, grid->cols, widths);
+ distSpace(grid->height - minHeight, grid->rows, heights);
+
+ thisTop = top;
+ for (row = 0; row < grid->rows; row++) {
+ i = 0;
+ thisLeft = left;
+ for (col = 0; col < grid->cols; col++) {
+ field = &grid->fields[col][row];
+
+ if (field->type == NEWT_GRID_EMPTY) continue;
+
+ x = thisLeft + field->padLeft;
+ remx = widths[col] - field->padLeft - field->padRight;
+ y = thisTop + field->padTop;
+ remy = heights[row] - field->padTop - field->padBottom;
+
+ if (field->type == NEWT_GRID_SUBGRID) {
+ remx -= field->u.grid->width;
+ remy -= field->u.grid->height;
+ } else if (field->type == NEWT_GRID_COMPONENT) {
+ remx -= field->u.co->width;
+ remy -= field->u.co->height;
+ }
+
+ if (!(field->flags & NEWT_GRID_FLAG_GROWX)) {
+ if (field->anchor & NEWT_ANCHOR_RIGHT)
+ x += remx;
+ else if (!(field->anchor & NEWT_ANCHOR_LEFT))
+ x += (remx / 2);
+ }
+
+ if (!(field->flags & NEWT_GRID_FLAG_GROWY)) {
+ if (field->anchor & NEWT_ANCHOR_BOTTOM)
+ y += remx;
+ else if (!(field->anchor & NEWT_ANCHOR_TOP))
+ y += (remy / 2);
+ }
+
+ if (field->type == NEWT_GRID_SUBGRID) {
+ if (field->flags & NEWT_GRID_FLAG_GROWX)
+ field->u.grid->width = widths[col] - field->padLeft
+ - field->padRight;
+ if (field->flags & NEWT_GRID_FLAG_GROWY)
+ field->u.grid->height = heights[col] - field->padTop
+ - field->padBottom;
+
+ shuffleGrid(field->u.grid, x, y, 1);
+ } else if (field->type == NEWT_GRID_COMPONENT) {
+ field->u.co->ops->place(field->u.co, x, y);
+ }
+
+ thisLeft += widths[col];
+ }
+
+ thisTop += heights[row];
+ }
+}
+
+void newtGridPlace(newtGrid grid, int left, int top) {
+ shuffleGrid(grid, left, top, 1);
+}
+
+void newtGridFree(newtGrid grid, int recurse) {
+ int row, col;
+
+ for (col = 0; col < grid->cols; col++) {
+ if (recurse) {
+ for (row = 0; row < grid->rows; row++) {
+ if (grid->fields[col][row].type == NEWT_GRID_SUBGRID)
+ newtGridFree(grid->fields[col][row].u.grid, 1);
+ }
+ }
+
+ free(grid->fields[col]);
+ }
+
+ free(grid->fields);
+ free(grid);
+}
+
+void newtGridGetSize(newtGrid grid, int * width, int * height) {
+ if (grid->width == -1 || grid->height == -1) {
+ grid->width = grid->height = -1;
+ shuffleGrid(grid, 0, 0, 1);
+ }
+
+ *width = grid->width;
+ *height = grid->height;
+}
+
+void newtGridWrappedWindow(newtGrid grid, char * title) {
+ int width, height, offset = 0;
+
+ newtGridGetSize(grid, &width, &height);
+ if (width < strlen(title) + 2) {
+ offset = ((strlen(title) + 2) - width) / 2;
+ width = strlen(title) + 2;
+ }
+ newtCenteredWindow(width + 2, height + 2, title);
+ newtGridPlace(grid, 1 + offset, 1);
+}
+
+void newtGridWrappedWindowAt(newtGrid grid, char * title, int left, int top) {
+ int width, height;
+
+ newtGridGetSize(grid, &width, &height);
+ newtOpenWindow(left, top, width + 2, height + 2, title);
+ newtGridPlace(grid, 1, 1);
+}
+
+void newtGridAddComponentsToForm(newtGrid grid, newtComponent form,
+ int recurse) {
+ int row, col;
+
+ for (col = 0; col < grid->cols; col++) {
+ for (row = 0; row < grid->rows; row++) {
+ if (grid->fields[col][row].type == NEWT_GRID_SUBGRID && recurse)
+ newtGridAddComponentsToForm(grid->fields[col][row].u.grid,
+ form, 1);
+ else if (grid->fields[col][row].type == NEWT_GRID_COMPONENT)
+ newtFormAddComponent(form, grid->fields[col][row].u.co);
+ }
+ }
+}
+
+/* this handles up to 50 items */
+static newtGrid stackem(int isVert, enum newtGridElement type1, void * what1,
+ va_list args, int close) {
+ struct item {
+ enum newtGridElement type;
+ void * what;
+ } items[50];
+ int i, num;
+ newtGrid grid;
+
+ items[0].type = type1, items[0].what = what1, num = 1;
+ while (1) {
+ items[num].type = va_arg(args, enum newtGridElement);
+ if (items[num].type == NEWT_GRID_EMPTY) break;
+
+ items[num].what = va_arg(args, void *);
+ num++;
+ }
+
+ grid = newtCreateGrid(isVert ? 1 : num, isVert ? num : 1);
+
+ for (i = 0; i < num; i++) {
+ newtGridSetField(grid, isVert ? 0 : i, isVert ? i : 0,
+ items[i].type, items[i].what,
+ close ? 0 : (i ? (isVert ? 0 : 1) : 0),
+ close ? 0 : (i ? (isVert ? 1 : 0) : 0), 0, 0, 0, 0);
+ }
+
+ return grid;
+}
+
+newtGrid newtGridHCloseStacked(enum newtGridElement type1, void * what1, ...) {
+ va_list args;
+ newtGrid grid;
+
+ va_start(args, what1);
+
+ grid = stackem(0, type1, what1, args, 1);
+
+ va_start(args, what1);
+
+ return grid;
+}
+
+newtGrid newtGridVCloseStacked(enum newtGridElement type1, void * what1, ...) {
+ va_list args;
+ newtGrid grid;
+
+ va_start(args, what1);
+
+ grid = stackem(1, type1, what1, args, 1);
+
+ va_start(args, what1);
+
+ return grid;
+}
+
+newtGrid newtGridVStacked(enum newtGridElement type1, void * what1, ...) {
+ va_list args;
+ newtGrid grid;
+
+ va_start(args, what1);
+
+ grid = stackem(1, type1, what1, args, 0);
+
+ va_start(args, what1);
+
+ return grid;
+}
+
+newtGrid newtGridHStacked(enum newtGridElement type1, void * what1, ...) {
+ va_list args;
+ newtGrid grid;
+
+ va_start(args, what1);
+
+ grid = stackem(0, type1, what1, args, 0);
+
+ va_start(args, what1);
+
+ return grid;
+}
+
+newtGrid newtGridBasicWindow(newtComponent text, newtGrid middle,
+ newtGrid buttons) {
+ newtGrid grid;
+
+ grid = newtCreateGrid(1, 3);
+ newtGridSetField(grid, 0, 0, NEWT_GRID_COMPONENT, text,
+ 0, 0, 0, 0, NEWT_ANCHOR_LEFT, 0);
+ newtGridSetField(grid, 0, 1, NEWT_GRID_SUBGRID, middle,
+ 0, 1, 0, 0, 0, 0);
+ newtGridSetField(grid, 0, 2, NEWT_GRID_SUBGRID, buttons,
+ 0, 1, 0, 0, 0, NEWT_GRID_FLAG_GROWX);
+
+ return grid;
+}
+
+newtGrid newtGridSimpleWindow(newtComponent text, newtComponent middle,
+ newtGrid buttons) {
+ newtGrid grid;
+
+ grid = newtCreateGrid(1, 3);
+ newtGridSetField(grid, 0, 0, NEWT_GRID_COMPONENT, text,
+ 0, 0, 0, 0, NEWT_ANCHOR_LEFT, 0);
+ newtGridSetField(grid, 0, 1, NEWT_GRID_COMPONENT, middle,
+ 0, 1, 0, 0, 0, 0);
+ newtGridSetField(grid, 0, 2, NEWT_GRID_SUBGRID, buttons,
+ 0, 1, 0, 0, 0, NEWT_GRID_FLAG_GROWX);
+
+ return grid;
+}
diff --git a/mdk-stage1/newt/label.c b/mdk-stage1/newt/label.c
new file mode 100644
index 000000000..f1a9cebbf
--- /dev/null
+++ b/mdk-stage1/newt/label.c
@@ -0,0 +1,81 @@
+#include <slang.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+struct label {
+ char * text;
+ int length;
+};
+
+static void labelDraw(newtComponent co);
+static void labelDestroy(newtComponent co);
+
+static struct componentOps labelOps = {
+ labelDraw,
+ newtDefaultEventHandler,
+ labelDestroy,
+ newtDefaultPlaceHandler,
+ newtDefaultMappedHandler,
+} ;
+
+newtComponent newtLabel(int left, int top, const char * text) {
+ newtComponent co;
+ struct label * la;
+
+ co = malloc(sizeof(*co));
+ la = malloc(sizeof(struct label));
+ co->data = la;
+
+ co->ops = &labelOps;
+
+ co->height = 1;
+ co->width = strlen(text);
+ co->top = top;
+ co->left = left;
+ co->takesFocus = 0;
+
+ la->length = strlen(text);
+ la->text = strdup(text);
+
+ return co;
+}
+
+void newtLabelSetText(newtComponent co, const char * text) {
+ int newLength;
+ struct label * la = co->data;
+
+ newLength = strlen(text);
+ if (newLength <= la->length) {
+ memset(la->text, ' ', la->length);
+ memcpy(la->text, text, newLength);
+ } else {
+ free(la->text);
+ la->text = strdup(text);
+ la->length = newLength;
+ co->width = newLength;
+ }
+
+ labelDraw(co);
+}
+
+static void labelDraw(newtComponent co) {
+ struct label * la = co->data;
+
+ if (co->isMapped == -1) return;
+
+ SLsmg_set_color(COLORSET_LABEL);
+
+ newtGotorc(co->top, co->left);
+ SLsmg_write_string(la->text);
+}
+
+static void labelDestroy(newtComponent co) {
+ struct label * la = co->data;
+
+ free(la->text);
+ free(la);
+ free(co);
+}
diff --git a/mdk-stage1/newt/listbox.c b/mdk-stage1/newt/listbox.c
new file mode 100644
index 000000000..ef276aeb4
--- /dev/null
+++ b/mdk-stage1/newt/listbox.c
@@ -0,0 +1,752 @@
+/* This goofed-up box whacked into shape by Elliot Lee <sopwith@cuc.edu>
+ (from the original listbox by Erik Troan <ewt@redhat.com>)
+ and contributed to newt for use under the LGPL license.
+ Copyright (C) 1996, 1997 Elliot Lee */
+
+#include <slang.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+
+/* Linked list of items in the listbox */
+struct items {
+ char * text;
+ const void *data;
+ unsigned char isSelected;
+ struct items *next;
+};
+
+/* Holds all the relevant information for this listbox */
+struct listbox {
+ newtComponent sb; /* Scrollbar on right side of listbox */
+ int curWidth; /* size of text w/o scrollbar or border*/
+ int curHeight; /* size of text w/o border */
+ int sbAdjust;
+ int bdxAdjust, bdyAdjust;
+ int numItems, numSelected;
+ int userHasSetWidth;
+ int currItem, startShowItem; /* startShowItem is the first item displayed
+ on the screen */
+ int isActive; /* If we handle key events all the time, it seems
+ to do things even when they are supposed to be for
+ another button/whatever */
+ struct items *boxItems;
+ int grow;
+ int flags; /* flags for this listbox, right now just
+ NEWT_FLAG_RETURNEXIT */
+};
+
+static void listboxDraw(newtComponent co);
+static void listboxDestroy(newtComponent co);
+static struct eventResult listboxEvent(newtComponent co, struct event ev);
+static void newtListboxRealSetCurrent(newtComponent co);
+static void listboxPlace(newtComponent co, int newLeft, int newTop);
+static inline void updateWidth(newtComponent co, struct listbox * li,
+ int maxField);
+static void listboxMapped(newtComponent co, int isMapped);
+
+static struct componentOps listboxOps = {
+ listboxDraw,
+ listboxEvent,
+ listboxDestroy,
+ listboxPlace,
+ listboxMapped,
+};
+
+static void listboxMapped(newtComponent co, int isMapped) {
+ struct listbox * li = co->data;
+
+ co->isMapped = isMapped;
+ if (li->sb)
+ li->sb->ops->mapped(li->sb, isMapped);
+}
+
+static void listboxPlace(newtComponent co, int newLeft, int newTop) {
+ struct listbox * li = co->data;
+
+ co->top = newTop;
+ co->left = newLeft;
+
+ if (li->sb)
+ li->sb->ops->place(li->sb, co->left + co->width - li->bdxAdjust - 1,
+ co->top);
+}
+
+newtComponent newtListbox(int left, int top, int height, int flags) {
+ newtComponent co, sb;
+ struct listbox * li;
+
+ if (!(co = malloc(sizeof(*co))))
+ return NULL;
+
+ if (!(li = malloc(sizeof(struct listbox)))) {
+ free(co);
+ return NULL;
+ }
+
+ li->boxItems = NULL;
+ li->numItems = 0;
+ li->currItem = 0;
+ li->numSelected = 0;
+ li->isActive = 0;
+ li->userHasSetWidth = 0;
+ li->startShowItem = 0;
+ li->sbAdjust = 0;
+ li->bdxAdjust = 0;
+ li->bdyAdjust = 0;
+ li->flags = flags & (NEWT_FLAG_RETURNEXIT | NEWT_FLAG_BORDER |
+ NEWT_FLAG_MULTIPLE);
+
+ if (li->flags & NEWT_FLAG_BORDER) {
+ li->bdxAdjust = 2;
+ li->bdyAdjust = 1;
+ }
+
+ co->height = height;
+ li->curHeight = co->height - (2 * li->bdyAdjust);
+
+ if (height) {
+ li->grow = 0;
+ if (flags & NEWT_FLAG_SCROLL) {
+ sb = newtVerticalScrollbar(left, top + li->bdyAdjust,
+ li->curHeight,
+ COLORSET_LISTBOX, COLORSET_ACTLISTBOX);
+ li->sbAdjust = 3;
+ } else {
+ sb = NULL;
+ }
+ } else {
+ li->grow = 1;
+ sb = NULL;
+ }
+
+ li->sb = sb;
+ co->data = li;
+ co->isMapped = 0;
+ co->left = left;
+ co->top = top;
+ co->ops = &listboxOps;
+ co->takesFocus = 1;
+ co->callback = NULL;
+
+ updateWidth(co, li, 5);
+
+ return co;
+}
+
+static inline void updateWidth(newtComponent co, struct listbox * li,
+ int maxField) {
+ li->curWidth = maxField;
+ co->width = li->curWidth + li->sbAdjust + 2 * li->bdxAdjust;
+
+ if (li->sb)
+ li->sb->left = co->left + co->width - li->bdxAdjust - 1;
+}
+
+void newtListboxSetCurrentByKey(newtComponent co, void * key) {
+ struct listbox * li = co->data;
+ struct items * item;
+ int i;
+
+ item = li->boxItems, i = 0;
+ while (item && item->data != key)
+ item = item->next, i++;
+
+ if (item)
+ newtListboxSetCurrent(co, i);
+}
+
+void newtListboxSetCurrent(newtComponent co, int num)
+{
+ struct listbox * li = co->data;
+
+ if (num >= li->numItems)
+ li->currItem = li->numItems - 1;
+ else if (num < 0)
+ li->currItem = 0;
+ else
+ li->currItem = num;
+
+ if (li->currItem < li->startShowItem)
+ li->startShowItem = li->currItem;
+ else if (li->currItem - li->startShowItem > li->curHeight - 1)
+ li->startShowItem = li->currItem - li->curHeight + 1;
+ if (li->startShowItem + li->curHeight > li->numItems)
+ li->startShowItem = li->numItems - li->curHeight;
+ if(li->startShowItem < 0)
+ li->startShowItem = 0;
+
+ newtListboxRealSetCurrent(co);
+}
+
+static void newtListboxRealSetCurrent(newtComponent co)
+{
+ struct listbox * li = co->data;
+
+ if(li->sb)
+ newtScrollbarSet(li->sb, li->currItem + 1, li->numItems);
+ listboxDraw(co);
+ if(co->callback) co->callback(co, co->callbackData);
+}
+
+void newtListboxSetWidth(newtComponent co, int width) {
+ struct listbox * li = co->data;
+
+ co->width = width;
+ li->curWidth = co->width - li->sbAdjust - 2 * li->bdxAdjust;
+ li->userHasSetWidth = 1;
+ if (li->sb) li->sb->left = co->width + co->left - 1;
+ listboxDraw(co);
+}
+
+void * newtListboxGetCurrent(newtComponent co) {
+ struct listbox * li = co->data;
+ int i;
+ struct items *item;
+
+ for(i = 0, item = li->boxItems; item != NULL && i < li->currItem;
+ i++, item = item->next);
+
+ if (item)
+ return (void *)item->data;
+ else
+ return NULL;
+}
+
+void newtListboxSelectItem(newtComponent co, const void * key,
+ enum newtFlagsSense sense)
+{
+ struct listbox * li = co->data;
+ int i;
+ struct items * item;
+
+ item = li->boxItems, i = 0;
+ while (item && item->data != key)
+ item = item->next, i++;
+
+ if (!item) return;
+
+ if (item->isSelected)
+ li->numSelected--;
+
+ switch(sense) {
+ case NEWT_FLAGS_RESET:
+ item->isSelected = 0; break;
+ case NEWT_FLAGS_SET:
+ item->isSelected = 1; break;
+ case NEWT_FLAGS_TOGGLE:
+ item->isSelected = !item->isSelected;
+ }
+
+ if (item->isSelected)
+ li->numSelected++;
+
+ listboxDraw(co);
+}
+
+void newtListboxClearSelection(newtComponent co)
+{
+ struct items *item;
+ struct listbox * li = co->data;
+
+ for(item = li->boxItems; item != NULL;
+ item = item->next)
+ item->isSelected = 0;
+ li->numSelected = 0;
+ listboxDraw(co);
+}
+
+/* Free the returned array after use, but NOT the values in the array */
+void ** newtListboxGetSelection(newtComponent co, int *numitems)
+{
+ struct listbox * li;
+ int i;
+ void **retval;
+ struct items *item;
+
+ if(!co || !numitems) return NULL;
+
+ li = co->data;
+ if(!li || !li->numSelected) return NULL;
+
+ retval = malloc(li->numSelected * sizeof(void *));
+ for(i = 0, item = li->boxItems; item != NULL;
+ item = item->next)
+ if(item->isSelected)
+ retval[i++] = (void *)item->data;
+ *numitems = li->numSelected;
+ return retval;
+}
+
+void newtListboxSetEntry(newtComponent co, int num, const char * text) {
+ struct listbox * li = co->data;
+ int i;
+ struct items *item;
+
+ for(i = 0, item = li->boxItems; item != NULL && i < num;
+ i++, item = item->next);
+
+ if(!item)
+ return;
+ else {
+ free(item->text);
+ item->text = strdup(text);
+ }
+ if (li->userHasSetWidth == 0 && strlen(text) > li->curWidth) {
+ updateWidth(co, li, strlen(text));
+ }
+
+ if (num >= li->startShowItem && num <= li->startShowItem + co->height)
+ listboxDraw(co);
+}
+
+void newtListboxSetData(newtComponent co, int num, void * data) {
+ struct listbox * li = co->data;
+ int i;
+ struct items *item;
+
+ for(i = 0, item = li->boxItems; item != NULL && i < num;
+ i++, item = item->next);
+
+ item->data = data;
+}
+
+int newtListboxAppendEntry(newtComponent co, const char * text,
+ const void * data) {
+ struct listbox * li = co->data;
+ struct items *item;
+
+ if(li->boxItems) {
+ for (item = li->boxItems; item->next != NULL; item = item->next);
+
+ item = item->next = malloc(sizeof(struct items));
+ } else {
+ item = li->boxItems = malloc(sizeof(struct items));
+ }
+
+ if (!li->userHasSetWidth && text && (strlen(text) > li->curWidth))
+ updateWidth(co, li, strlen(text));
+
+ item->text = strdup(text); item->data = data; item->next = NULL;
+ item->isSelected = 0;
+
+ if (li->grow)
+ co->height++, li->curHeight++;
+ li->numItems++;
+
+ return 0;
+}
+
+int newtListboxInsertEntry(newtComponent co, const char * text,
+ const void * data, void * key) {
+ struct listbox * li = co->data;
+ struct items *item, *t;
+
+ if (li->boxItems) {
+ if (key) {
+ item = li->boxItems;
+ while (item && item->data != key) item = item->next;
+
+ if (!item) return 1;
+
+ t = item->next;
+ item = item->next = malloc(sizeof(struct items));
+ item->next = t;
+ } else {
+ t = li->boxItems;
+ item = li->boxItems = malloc(sizeof(struct items));
+ item->next = t;
+ }
+ } else if (key) {
+ return 1;
+ } else {
+ item = li->boxItems = malloc(sizeof(struct items));
+ item->next = NULL;
+ }
+
+ if (!li->userHasSetWidth && text && (strlen(text) > li->curWidth))
+ updateWidth(co, li, strlen(text));
+
+ item->text = strdup(text?text:"(null)"); item->data = data;
+ item->isSelected = 0;
+
+ if (li->sb)
+ li->sb->left = co->left + co->width - li->bdxAdjust - 1;
+ li->numItems++;
+
+ listboxDraw(co);
+
+ return 0;
+}
+
+int newtListboxDeleteEntry(newtComponent co, void * key) {
+ struct listbox * li = co->data;
+ int widest = 0, t;
+ struct items *item, *item2 = NULL;
+ int num;
+
+ if (li->boxItems == NULL || li->numItems <= 0)
+ return 0;
+
+ num = 0;
+
+ item2 = NULL, item = li->boxItems;
+ while (item && item->data != key) {
+ item2 = item;
+ item = item->next;
+ num++;
+ }
+
+ if (!item)
+ return -1;
+
+ if (item2)
+ item2->next = item->next;
+ else
+ li->boxItems = item->next;
+
+ free(item->text);
+ free(item);
+ li->numItems--;
+
+ if (!li->userHasSetWidth) {
+ widest = 0;
+ for (item = li->boxItems; item != NULL; item = item->next)
+ if ((t = strlen(item->text)) > widest) widest = t;
+ }
+
+ if (li->currItem >= num)
+ li->currItem--;
+
+ if (!li->userHasSetWidth) {
+ updateWidth(co, li, widest);
+ }
+
+ listboxDraw(co);
+
+ return 0;
+}
+
+void newtListboxClear(newtComponent co)
+{
+ struct listbox * li;
+ struct items *anitem, *nextitem;
+ if(co == NULL || (li = co->data) == NULL)
+ return;
+ for(anitem = li->boxItems; anitem != NULL; anitem = nextitem) {
+ nextitem = anitem->next;
+ free(anitem->text);
+ free(anitem);
+ }
+ li->numItems = li->numSelected = li->currItem = li->startShowItem = 0;
+ li->boxItems = NULL;
+ if (!li->userHasSetWidth)
+ updateWidth(co, li, 5);
+}
+
+/* If you don't want to get back the text, pass in NULL for the ptr-ptr. Same
+ goes for the data. */
+void newtListboxGetEntry(newtComponent co, int num, char **text, void **data) {
+ struct listbox * li = co->data;
+ int i;
+ struct items *item;
+
+ if (!li->boxItems || num >= li->numItems) {
+ if(text)
+ *text = NULL;
+ if(data)
+ *data = NULL;
+ return;
+ }
+
+ i = 0;
+ item = li->boxItems;
+ while (item && i < num) {
+ i++, item = item->next;
+ }
+
+ if (item) {
+ if (text)
+ *text = item->text;
+ if (data)
+ *data = (void *)item->data;
+ }
+}
+
+static void listboxDraw(newtComponent co)
+{
+ struct listbox * li = co->data;
+ struct items *item;
+ int i, j;
+
+ if (!co->isMapped) return ;
+
+ if(li->flags & NEWT_FLAG_BORDER) {
+ if(li->isActive)
+ SLsmg_set_color(NEWT_COLORSET_ACTLISTBOX);
+ else
+ SLsmg_set_color(NEWT_COLORSET_LISTBOX);
+
+ newtDrawBox(co->left, co->top, co->width, co->height, 0);
+ }
+
+ if(li->sb)
+ li->sb->ops->draw(li->sb);
+
+ SLsmg_set_color(NEWT_COLORSET_LISTBOX);
+
+ for(i = 0, item = li->boxItems; item != NULL && i < li->startShowItem;
+ i++, item = item->next);
+
+ j = i;
+
+ for (i = 0; item != NULL && i < li->curHeight; i++, item = item->next) {
+ if (!item->text) continue;
+
+ newtGotorc(co->top + i + li->bdyAdjust, co->left + li->bdxAdjust);
+ if(j + i == li->currItem) {
+ if(item->isSelected)
+ SLsmg_set_color(NEWT_COLORSET_ACTSELLISTBOX);
+ else
+ SLsmg_set_color(NEWT_COLORSET_ACTLISTBOX);
+ } else if(item->isSelected)
+ SLsmg_set_color(NEWT_COLORSET_SELLISTBOX);
+ else
+ SLsmg_set_color(NEWT_COLORSET_LISTBOX);
+
+ SLsmg_write_nstring(item->text, li->curWidth);
+
+ }
+ newtGotorc(co->top + (li->currItem - li->startShowItem), co->left);
+}
+
+static struct eventResult listboxEvent(newtComponent co, struct event ev) {
+ struct eventResult er;
+ struct listbox * li = co->data;
+ struct items *item;
+ int i;
+
+ er.result = ER_IGNORED;
+
+ if(ev.when == EV_EARLY || ev.when == EV_LATE) {
+ return er;
+ }
+
+ switch(ev.event) {
+ case EV_KEYPRESS:
+ if (!li->isActive) break;
+
+ switch(ev.u.key) {
+ case ' ':
+ if(!(li->flags & NEWT_FLAG_MULTIPLE)) break;
+ newtListboxSelectItem(co, li->boxItems[li->currItem].data,
+ NEWT_FLAGS_TOGGLE);
+ er.result = ER_SWALLOWED;
+ /* We don't break here, because it is cool to be able to
+ hold space to select a bunch of items in a list at once */
+
+ case NEWT_KEY_DOWN:
+ if(li->numItems <= 0) break;
+ if(li->currItem < li->numItems - 1) {
+ li->currItem++;
+ if(li->currItem > (li->startShowItem + li->curHeight - 1)) {
+ li->startShowItem = li->currItem - li->curHeight + 1;
+ if(li->startShowItem + li->curHeight > li->numItems)
+ li->startShowItem = li->numItems - li->curHeight;
+ }
+ if(li->sb)
+ newtScrollbarSet(li->sb, li->currItem + 1, li->numItems);
+ listboxDraw(co);
+ }
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case NEWT_KEY_ENTER:
+ if(li->numItems <= 0) break;
+ if(li->flags & NEWT_FLAG_RETURNEXIT)
+ er.result = ER_EXITFORM;
+ break;
+
+ case NEWT_KEY_UP:
+ if(li->numItems <= 0) break;
+ if(li->currItem > 0) {
+ li->currItem--;
+ if(li->currItem < li->startShowItem)
+ li->startShowItem = li->currItem;
+ if(li->sb)
+ newtScrollbarSet(li->sb, li->currItem + 1, li->numItems);
+ listboxDraw(co);
+ }
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case NEWT_KEY_PGUP:
+ if(li->numItems <= 0) break;
+ li->startShowItem -= li->curHeight - 1;
+ if(li->startShowItem < 0)
+ li->startShowItem = 0;
+ li->currItem -= li->curHeight - 1;
+ if(li->currItem < 0)
+ li->currItem = 0;
+ newtListboxRealSetCurrent(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case NEWT_KEY_PGDN:
+ if(li->numItems <= 0) break;
+ li->startShowItem += li->curHeight;
+ if(li->startShowItem > (li->numItems - li->curHeight)) {
+ li->startShowItem = li->numItems - li->curHeight;
+ }
+ li->currItem += li->curHeight;
+ if(li->currItem >= li->numItems) {
+ li->currItem = li->numItems - 1;
+ }
+ newtListboxRealSetCurrent(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case NEWT_KEY_HOME:
+ if(li->numItems <= 0) break;
+ newtListboxSetCurrent(co, 0);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case NEWT_KEY_END:
+ if(li->numItems <= 0) break;
+ li->startShowItem = li->numItems - li->curHeight;
+ if(li->startShowItem < 0)
+ li->startShowItem = 0;
+ li->currItem = li->numItems - 1;
+ newtListboxRealSetCurrent(co);
+ er.result = ER_SWALLOWED;
+ break;
+ default:
+ if (li->numItems <= 0) break;
+ if (ev.u.key < NEWT_KEY_EXTRA_BASE && isalpha(ev.u.key)) {
+ for(i = 0, item = li->boxItems; item != NULL &&
+ i < li->currItem; i++, item = item->next);
+
+ if (item && item->text && (toupper(*item->text) == toupper(ev.u.key))) {
+ item = item->next;
+ i++;
+ } else {
+ item = li->boxItems;
+ i = 0;
+ }
+ while (item && item->text &&
+ toupper(*item->text) != toupper(ev.u.key)) {
+ item = item->next;
+ i++;
+ }
+ if (item) {
+ li->currItem = i;
+ if(li->currItem < li->startShowItem ||
+ li->currItem > li->startShowItem)
+ li->startShowItem =
+ li->currItem > li->numItems - li->curHeight ?
+ li->startShowItem = li->numItems - li->curHeight :
+ li->currItem;
+ if(li->sb)
+ newtScrollbarSet(li->sb, li->currItem + 1, li->numItems);
+ newtListboxRealSetCurrent(co);
+ er.result = ER_SWALLOWED;
+ }
+ }
+ }
+ break;
+
+ case EV_FOCUS:
+ li->isActive = 1;
+ listboxDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case EV_UNFOCUS:
+ li->isActive = 0;
+ listboxDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case EV_MOUSE:
+ /* if this mouse click was within the listbox, make the current
+ item the item clicked on. */
+ /* Up scroll arrow */
+ if (li->sb &&
+ ev.u.mouse.x == co->left + co->width - li->bdxAdjust - 1 &&
+ ev.u.mouse.y == co->top + li->bdyAdjust) {
+ if(li->numItems <= 0) break;
+ if(li->currItem > 0) {
+ li->currItem--;
+ if(li->currItem < li->startShowItem)
+ li->startShowItem = li->currItem;
+ if(li->sb)
+ newtScrollbarSet(li->sb, li->currItem + 1, li->numItems);
+ listboxDraw(co);
+ }
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ break;
+ }
+ /* Down scroll arrow */
+ if (li->sb &&
+ ev.u.mouse.x == co->left + co->width - li->bdxAdjust - 1 &&
+ ev.u.mouse.y == co->top + co->height - li->bdyAdjust - 1) {
+ if(li->numItems <= 0) break;
+ if(li->currItem < li->numItems - 1) {
+ li->currItem++;
+ if(li->currItem > (li->startShowItem + li->curHeight - 1)) {
+ li->startShowItem = li->currItem - li->curHeight + 1;
+ if(li->startShowItem + li->curHeight > li->numItems)
+ li->startShowItem = li->numItems - li->curHeight;
+ }
+ if(li->sb)
+ newtScrollbarSet(li->sb, li->currItem + 1, li->numItems);
+ listboxDraw(co);
+ }
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ break;
+ }
+ if ((ev.u.mouse.y >= co->top + li->bdyAdjust) &&
+ (ev.u.mouse.y <= co->top + co->height - (li->bdyAdjust * 2)) &&
+ (ev.u.mouse.x >= co->left + li->bdxAdjust) &&
+ (ev.u.mouse.x <= co->left + co->width + (li->bdxAdjust * 2))) {
+ li->currItem = li->startShowItem +
+ (ev.u.mouse.y - li->bdyAdjust - co->top);
+ newtListboxRealSetCurrent(co);
+ listboxDraw(co);
+ if(co->callback) co->callback(co, co->callbackData);
+ er.result = ER_SWALLOWED;
+ break;
+ }
+ }
+
+ return er;
+}
+
+static void listboxDestroy(newtComponent co) {
+ struct listbox * li = co->data;
+ struct items * item, * nextitem;
+
+ nextitem = item = li->boxItems;
+
+ while (item != NULL) {
+ nextitem = item->next;
+ free(item->text);
+ free(item);
+ item = nextitem;
+ }
+
+ if (li->sb) li->sb->ops->destroy(li->sb);
+
+ free(li);
+ free(co);
+}
diff --git a/mdk-stage1/newt/newt.c b/mdk-stage1/newt/newt.c
new file mode 100644
index 000000000..1cfe3ac93
--- /dev/null
+++ b/mdk-stage1/newt/newt.c
@@ -0,0 +1,672 @@
+#include <slang.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/signal.h>
+#include <sys/time.h>
+#include <sys/types.h>
+#include <termios.h>
+#include <unistd.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+struct Window {
+ int height, width, top, left;
+ short * buffer;
+ char * title;
+};
+
+struct keymap {
+ char * str;
+ int code;
+ char * tc;
+};
+
+static struct Window windowStack[20];
+static struct Window * currentWindow = NULL;
+
+static char * helplineStack[20];
+static char ** currentHelpline = NULL;
+
+static int cursorRow, cursorCol;
+static int needResize;
+static int cursorOn = 1;
+
+static const char * defaultHelpLine =
+" <Tab>/<Alt-Tab> between elements | <Space> selects | <F12> next screen"
+;
+
+const struct newtColors newtDefaultColorPalette = {
+ "cyan", "black", /* root fg, bg */
+ "black", "blue", /* border fg, bg */
+ "white", "blue", /* window fg, bg */
+ "white", "black", /* shadow fg, bg */
+ "white", "blue", /* title fg, bg */
+ "black", "cyan", /* button fg, bg */
+ "yellow", "cyan", /* active button fg, bg */
+ "yellow", "blue", /* checkbox fg, bg */
+ "blue", "brown", /* active checkbox fg, bg */
+ "yellow", "blue", /* entry box fg, bg */
+ "white", "blue", /* label fg, bg */
+ "black", "cyan", /* listbox fg, bg */
+ "yellow", "cyan", /* active listbox fg, bg */
+ "white", "blue", /* textbox fg, bg */
+ "cyan", "black", /* active textbox fg, bg */
+ "white", "blue", /* help line */
+ "yellow", "blue", /* root text */
+ "blue", /* scale full */
+ "red", /* scale empty */
+ "blue", "cyan", /* disabled entry fg, bg */
+ "white", "blue", /* compact button fg, bg */
+ "yellow", "red", /* active & sel listbox */
+ "black", "brown" /* selected listbox */
+};
+
+static const struct keymap keymap[] = {
+ { "\033OA", NEWT_KEY_UP, "kh" },
+ { "\033[A", NEWT_KEY_UP, "ku" },
+ { "\033OB", NEWT_KEY_DOWN, "kd" },
+ { "\033[B", NEWT_KEY_DOWN, "kd" },
+ { "\033[C", NEWT_KEY_RIGHT, "kr" },
+ { "\033OC", NEWT_KEY_RIGHT, "kr" },
+ { "\033[D", NEWT_KEY_LEFT, "kl" },
+ { "\033OD", NEWT_KEY_LEFT, "kl" },
+ { "\033[H", NEWT_KEY_HOME, "kh" },
+ { "\033[1~", NEWT_KEY_HOME, "kh" },
+ { "\033Ow", NEWT_KEY_END, "kH" },
+ { "\033[4~", NEWT_KEY_END, "kH" },
+
+ { "\033[3~", NEWT_KEY_DELETE, "kl" },
+ { "\033[2~", NEWT_KEY_INSERT, NULL },
+
+ { "\033\t", NEWT_KEY_UNTAB, NULL },
+
+ { "\033[5~", NEWT_KEY_PGUP, NULL },
+ { "\033[6~", NEWT_KEY_PGDN, NULL },
+ { "\033V", NEWT_KEY_PGUP, "kH" },
+ { "\033v", NEWT_KEY_PGUP, "kH" },
+
+ { "\033[[A", NEWT_KEY_F1, NULL },
+ { "\033[[B", NEWT_KEY_F2, NULL },
+ { "\033[[C", NEWT_KEY_F3, NULL },
+ { "\033[[D", NEWT_KEY_F4, NULL },
+ { "\033[[E", NEWT_KEY_F5, NULL },
+
+ { "\033OP", NEWT_KEY_F1, NULL },
+ { "\033OQ", NEWT_KEY_F2, NULL },
+ { "\033OR", NEWT_KEY_F3, NULL },
+ { "\033OS", NEWT_KEY_F4, NULL },
+
+ { "\033[11~", NEWT_KEY_F1, NULL },
+ { "\033[12~", NEWT_KEY_F2, NULL },
+ { "\033[13~", NEWT_KEY_F3, NULL },
+ { "\033[14~", NEWT_KEY_F4, NULL },
+ { "\033[15~", NEWT_KEY_F5, NULL },
+ { "\033[17~", NEWT_KEY_F6, NULL },
+ { "\033[18~", NEWT_KEY_F7, NULL },
+ { "\033[19~", NEWT_KEY_F8, NULL },
+ { "\033[20~", NEWT_KEY_F9, NULL },
+ { "\033[21~", NEWT_KEY_F10, NULL },
+ { "\033[23~", NEWT_KEY_F11, NULL },
+ { "\033[24~", NEWT_KEY_F12, NULL },
+
+ { NULL, 0, NULL }, /* LEAVE this one */
+};
+static char keyPrefix = '\033';
+
+static const char * version = "Newt windowing library version " VERSION
+ " - (C) 1996-2000 Red Hat Software. "
+ "Redistributable under the term of the Library "
+ "GNU Public License. "
+ "Written by Erik Troan\n";
+
+static newtSuspendCallback suspendCallback = NULL;
+static void * suspendCallbackData = NULL;
+
+void newtSetSuspendCallback(newtSuspendCallback cb, void * data) {
+ suspendCallback = cb;
+ suspendCallbackData = data;
+}
+
+static void handleSigwinch(int signum) {
+ needResize = 1;
+}
+
+static int getkeyInterruptHook(void) {
+ return -1;
+}
+
+void newtFlushInput(void) {
+ while (SLang_input_pending(0)) {
+ SLang_getkey();
+ }
+}
+
+void newtRefresh(void) {
+ SLsmg_refresh();
+}
+
+void newtSuspend(void) {
+ SLtt_set_cursor_visibility (1);
+ SLsmg_suspend_smg();
+ SLang_reset_tty();
+ SLtt_set_cursor_visibility (cursorOn);
+}
+
+void newtResume(void) {
+ SLsmg_resume_smg ();
+ SLsmg_refresh();
+ SLang_init_tty(0, 0, 0);
+}
+
+void newtCls(void) {
+ SLsmg_set_color(NEWT_COLORSET_ROOT);
+ SLsmg_gotorc(0, 0);
+ SLsmg_erase_eos();
+
+ newtRefresh();
+}
+
+#if defined(THIS_DOESNT_WORK)
+void newtResizeScreen(int redraw) {
+ newtPushHelpLine("");
+
+ SLtt_get_screen_size();
+ SLang_init_tty(0, 0, 0);
+
+ SLsmg_touch_lines (0, SLtt_Screen_Rows - 1);
+
+ /* I don't know why I need this */
+ SLsmg_refresh();
+
+ newtPopHelpLine();
+
+ if (redraw)
+ SLsmg_refresh();
+}
+#endif
+
+int newtInit(void) {
+ char * MonoValue, * MonoEnv = "NEWT_MONO";
+
+ /* use the version variable just to be sure it gets included */
+ strlen(version);
+
+ SLtt_get_terminfo();
+ SLtt_get_screen_size();
+
+ MonoValue = getenv(MonoEnv);
+ if ( MonoValue == NULL ) {
+ SLtt_Use_Ansi_Colors = 1;
+ } else {
+ SLtt_Use_Ansi_Colors = 0;
+ }
+
+ SLsmg_init_smg();
+ SLang_init_tty(0, 0, 0);
+
+ newtSetColors(newtDefaultColorPalette);
+ newtCursorOff();
+ /*initKeymap();*/
+
+ /*memset(&sa, 0, sizeof(sa));
+ sa.sa_handler = handleSigwinch;
+ sigaction(SIGWINCH, &sa, NULL);*/
+
+ SLsignal_intr(SIGWINCH, handleSigwinch);
+ SLang_getkey_intr_hook = getkeyInterruptHook;
+
+
+
+ return 0;
+}
+
+int newtFinished(void) {
+ SLsmg_gotorc(SLtt_Screen_Rows - 1, 0);
+ newtCursorOn();
+ SLsmg_refresh();
+ SLsmg_reset_smg();
+ SLang_reset_tty();
+
+ return 0;
+}
+
+void newtSetColors(struct newtColors colors) {
+ SLtt_set_color(NEWT_COLORSET_ROOT, "", colors.rootFg, colors.rootBg);
+ SLtt_set_color(NEWT_COLORSET_BORDER, "", colors.borderFg, colors.borderBg);
+ SLtt_set_color(NEWT_COLORSET_WINDOW, "", colors.windowFg, colors.windowBg);
+ SLtt_set_color(NEWT_COLORSET_SHADOW, "", colors.shadowFg, colors.shadowBg);
+ SLtt_set_color(NEWT_COLORSET_TITLE, "", colors.titleFg, colors.titleBg);
+ SLtt_set_color(NEWT_COLORSET_BUTTON, "", colors.buttonFg, colors.buttonBg);
+ SLtt_set_color(NEWT_COLORSET_ACTBUTTON, "", colors.actButtonFg,
+ colors.actButtonBg);
+ SLtt_set_color(NEWT_COLORSET_CHECKBOX, "", colors.checkboxFg,
+ colors.checkboxBg);
+ SLtt_set_color(NEWT_COLORSET_ACTCHECKBOX, "", colors.actCheckboxFg,
+ colors.actCheckboxBg);
+ SLtt_set_color(NEWT_COLORSET_ENTRY, "", colors.entryFg, colors.entryBg);
+ SLtt_set_color(NEWT_COLORSET_LABEL, "", colors.labelFg, colors.labelBg);
+ SLtt_set_color(NEWT_COLORSET_LISTBOX, "", colors.listboxFg,
+ colors.listboxBg);
+ SLtt_set_color(NEWT_COLORSET_ACTLISTBOX, "", colors.actListboxFg,
+ colors.actListboxBg);
+ SLtt_set_color(NEWT_COLORSET_TEXTBOX, "", colors.textboxFg,
+ colors.textboxBg);
+ SLtt_set_color(NEWT_COLORSET_ACTTEXTBOX, "", colors.actTextboxFg,
+ colors.actTextboxBg);
+ SLtt_set_color(NEWT_COLORSET_HELPLINE, "", colors.helpLineFg,
+ colors.helpLineBg);
+ SLtt_set_color(NEWT_COLORSET_ROOTTEXT, "", colors.rootTextFg,
+ colors.rootTextBg);
+
+ SLtt_set_color(NEWT_COLORSET_EMPTYSCALE, "", "black",
+ colors.emptyScale);
+ SLtt_set_color(NEWT_COLORSET_FULLSCALE, "", "black",
+ colors.fullScale);
+ SLtt_set_color(NEWT_COLORSET_DISENTRY, "", colors.disabledEntryFg,
+ colors.disabledEntryBg);
+
+ SLtt_set_color(NEWT_COLORSET_COMPACTBUTTON, "", colors.compactButtonFg,
+ colors.compactButtonBg);
+
+ SLtt_set_color(NEWT_COLORSET_ACTSELLISTBOX, "", colors.actSelListboxFg,
+ colors.actSelListboxBg);
+ SLtt_set_color(NEWT_COLORSET_SELLISTBOX, "", colors.selListboxFg,
+ colors.selListboxBg);
+}
+
+int newtGetKey(void) {
+ int key;
+ char buf[10], * chptr = buf;
+ const struct keymap * curr;
+
+ do {
+ key = SLang_getkey();
+ if (key == 0xFFFF) {
+ if (needResize)
+ return NEWT_KEY_RESIZE;
+
+ /* ignore other signals */
+ continue;
+ }
+
+ if (key == NEWT_KEY_SUSPEND && suspendCallback)
+ suspendCallback(suspendCallbackData);
+ } while (key == NEWT_KEY_SUSPEND);
+
+ switch (key) {
+ case 'v' | 0x80:
+ case 'V' | 0x80:
+ return NEWT_KEY_PGUP;
+
+ case 22:
+ return NEWT_KEY_PGDN;
+
+ return NEWT_KEY_BKSPC;
+ case 0x7f:
+ return NEWT_KEY_BKSPC;
+
+ case 0x08:
+ return NEWT_KEY_BKSPC;
+
+ default:
+ if (key != keyPrefix) return key;
+ }
+
+ memset(buf, 0, sizeof(buf));
+
+ *chptr++ = key;
+ while (SLang_input_pending(5)) {
+ key = SLang_getkey();
+ if (key == keyPrefix) {
+ /* he hit unknown keys too many times -- start over */
+ memset(buf, 0, sizeof(buf));
+ chptr = buf;
+ }
+
+ *chptr++ = key;
+
+ /* this search should use bsearch(), but when we only look through
+ a list of 20 (or so) keymappings, it's probably faster just to
+ do a inline linear search */
+
+ for (curr = keymap; curr->code; curr++) {
+ if (curr->str) {
+ if (!strcmp(curr->str, buf))
+ return curr->code;
+ }
+ }
+ }
+
+ for (curr = keymap; curr->code; curr++) {
+ if (curr->str) {
+ if (!strcmp(curr->str, buf))
+ return curr->code;
+ }
+ }
+
+ /* Looks like we were a bit overzealous in reading characters. Return
+ just the first character, and put everything else back in the buffer
+ for later */
+
+ chptr--;
+ while (chptr > buf)
+ SLang_ungetkey(*chptr--);
+
+ return *chptr;
+}
+
+void newtWaitForKey(void) {
+ newtRefresh();
+
+ SLang_getkey();
+ newtClearKeyBuffer();
+}
+
+void newtClearKeyBuffer(void) {
+ while (SLang_input_pending(1)) {
+ SLang_getkey();
+ }
+}
+
+int newtOpenWindow(int left, int top, int width, int height,
+ const char * title) {
+ int j, row, col;
+ int n;
+ int i;
+
+ newtFlushInput();
+
+ if (!currentWindow) {
+ currentWindow = windowStack;
+ } else {
+ currentWindow++;
+ }
+
+ currentWindow->left = left;
+ currentWindow->top = top;
+ currentWindow->width = width;
+ currentWindow->height = height;
+ currentWindow->title = title ? strdup(title) : NULL;
+
+ currentWindow->buffer = malloc(sizeof(short) * (width + 3) * (height + 3));
+
+ row = top - 1;
+ col = left - 1;
+ n = 0;
+ for (j = 0; j < height + 3; j++, row++) {
+ SLsmg_gotorc(row, col);
+ SLsmg_read_raw(currentWindow->buffer + n,
+ currentWindow->width + 3);
+ n += currentWindow->width + 3;
+ }
+
+ SLsmg_set_color(NEWT_COLORSET_BORDER);
+ SLsmg_draw_box(top - 1, left - 1, height + 2, width + 2);
+
+ if (currentWindow->title) {
+ i = strlen(currentWindow->title) + 4;
+ i = ((width - i) / 2) + left;
+ SLsmg_gotorc(top - 1, i);
+ SLsmg_set_char_set(1);
+ SLsmg_write_char(SLSMG_RTEE_CHAR);
+ SLsmg_set_char_set(0);
+ SLsmg_write_char(' ');
+ SLsmg_set_color(NEWT_COLORSET_TITLE);
+ SLsmg_write_string((char *)currentWindow->title);
+ SLsmg_set_color(NEWT_COLORSET_BORDER);
+ SLsmg_write_char(' ');
+ SLsmg_set_char_set(1);
+ SLsmg_write_char(SLSMG_LTEE_CHAR);
+ SLsmg_set_char_set(0);
+ }
+
+ SLsmg_set_color(NEWT_COLORSET_WINDOW);
+ SLsmg_fill_region(top, left, height, width, ' ');
+
+ SLsmg_set_color(NEWT_COLORSET_SHADOW);
+ SLsmg_fill_region(top + height + 1, left, 1, width + 2, ' ');
+ SLsmg_fill_region(top, left + width + 1, height + 1, 1, ' ');
+
+ for (i = top; i < (top + height + 1); i++) {
+ SLsmg_gotorc(i, left + width + 1);
+ SLsmg_write_string(" ");
+ }
+
+ return 0;
+}
+
+int newtCenteredWindow(int width, int height, const char * title) {
+ int top, left;
+
+ top = (SLtt_Screen_Rows - height) / 2;
+
+ /* I don't know why, but this seems to look better */
+ if ((SLtt_Screen_Rows % 2) && (top % 2)) top--;
+
+ left = (SLtt_Screen_Cols - width) / 2;
+
+ newtOpenWindow(left, top, width, height, title);
+
+ return 0;
+}
+
+void newtPopWindow(void) {
+ int j, row, col;
+ int n = 0;
+
+ row = col = 0;
+
+ row = currentWindow->top - 1;
+ col = currentWindow->left - 1;
+ for (j = 0; j < currentWindow->height + 3; j++, row++) {
+ SLsmg_gotorc(row, col);
+ SLsmg_write_raw(currentWindow->buffer + n,
+ currentWindow->width + 3);
+ n += currentWindow->width + 3;
+ }
+
+ free(currentWindow->buffer);
+ free(currentWindow->title);
+
+ if (currentWindow == windowStack)
+ currentWindow = NULL;
+ else
+ currentWindow--;
+
+ SLsmg_set_char_set(0);
+
+ newtRefresh();
+}
+
+void newtGetWindowPos(int * x, int * y) {
+ if (currentWindow) {
+ *x = currentWindow->left;
+ *y = currentWindow->top;
+ } else
+ *x = *y = 0;
+}
+
+void newtGetrc(int * row, int * col) {
+ *row = cursorRow;
+ *col = cursorCol;
+}
+
+void newtGotorc(int newRow, int newCol) {
+ if (currentWindow) {
+ newRow += currentWindow->top;
+ newCol += currentWindow->left;
+ }
+
+ cursorRow = newRow;
+ cursorCol = newCol;
+ SLsmg_gotorc(cursorRow, cursorCol);
+}
+
+void newtDrawBox(int left, int top, int width, int height, int shadow) {
+ if (currentWindow) {
+ top += currentWindow->top;
+ left += currentWindow->left;
+ }
+
+ SLsmg_draw_box(top, left, height, width);
+
+ if (shadow) {
+ SLsmg_set_color(NEWT_COLORSET_SHADOW);
+ SLsmg_fill_region(top + height, left + 1, 1, width - 1, ' ');
+ SLsmg_fill_region(top + 1, left + width, height, 1, ' ');
+ }
+}
+
+void newtClearBox(int left, int top, int width, int height) {
+ if (currentWindow) {
+ top += currentWindow->top;
+ left += currentWindow->left;
+ }
+
+ SLsmg_fill_region(top, left, height, width, ' ');
+}
+
+#if 0
+/* This doesn't seem to work quite right. I don't know why not, but when
+ I rsh from an rxvt into a box and run this code, the machine returns
+ console key's (\033[B) rather then xterm ones (\033OB). */
+static void initKeymap(void) {
+ struct keymap * curr;
+
+ for (curr = keymap; curr->code; curr++) {
+ if (!curr->str)
+ curr->str = SLtt_tgetstr(curr->tc);
+ }
+
+ /* Newt's keymap handling is a bit broken. It assumes that any extended
+ keystrokes begin with ESC. If you're using a homebrek terminal you
+ will probably need to fix this, or just yell at me and I'll be so
+ ashamed of myself for doing it this way I'll fix it */
+
+ keyPrefix = 0x1b; /* ESC */
+}
+#endif
+
+void newtDelay(int usecs) {
+ fd_set set;
+ struct timeval tv;
+
+ FD_ZERO(&set);
+
+ tv.tv_sec = usecs / 1000000;
+ tv.tv_usec = usecs % 1000000;
+
+ select(0, &set, &set, &set, &tv);
+}
+
+struct eventResult newtDefaultEventHandler(newtComponent c,
+ struct event ev) {
+ struct eventResult er;
+
+ er.result = ER_IGNORED;
+ return er;
+}
+
+void newtRedrawHelpLine(void) {
+ char * buf;
+
+ SLsmg_set_color(NEWT_COLORSET_HELPLINE);
+
+ buf = alloca(SLtt_Screen_Cols + 1);
+ memset(buf, ' ', SLtt_Screen_Cols);
+ buf[SLtt_Screen_Cols] = '\0';
+
+ if (currentHelpline)
+ memcpy(buf, *currentHelpline, strlen(*currentHelpline));
+
+ SLsmg_gotorc(SLtt_Screen_Rows - 1, 0);
+ SLsmg_write_string(buf);
+}
+
+void newtPushHelpLine(const char * text) {
+ if (!text)
+ text = defaultHelpLine;
+
+ if (currentHelpline)
+ (*(++currentHelpline)) = strdup(text);
+ else {
+ currentHelpline = helplineStack;
+ *currentHelpline = strdup(text);
+ }
+
+ newtRedrawHelpLine();
+}
+
+void newtPopHelpLine(void) {
+ if (!currentHelpline) return;
+
+ free(*currentHelpline);
+ if (currentHelpline == helplineStack)
+ currentHelpline = NULL;
+ else
+ currentHelpline--;
+
+ newtRedrawHelpLine();
+}
+
+void newtDrawRootText(int col, int row, const char * text) {
+ SLsmg_set_color(NEWT_COLORSET_ROOTTEXT);
+
+ if (col < 0) {
+ col = SLtt_Screen_Cols + col;
+ }
+
+ if (row < 0) {
+ row = SLtt_Screen_Rows + row;
+ }
+
+ SLsmg_gotorc(row, col);
+ SLsmg_write_string((char *)text);
+}
+
+int newtSetFlags(int oldFlags, int newFlags, enum newtFlagsSense sense) {
+ switch (sense) {
+ case NEWT_FLAGS_SET:
+ return oldFlags | newFlags;
+
+ case NEWT_FLAGS_RESET:
+ return oldFlags & (~newFlags);
+
+ case NEWT_FLAGS_TOGGLE:
+ return oldFlags ^ newFlags;
+
+ default:
+ return oldFlags;
+ }
+}
+
+void newtBell(void)
+{
+ SLtt_beep();
+}
+
+void newtGetScreenSize(int * cols, int * rows) {
+ if (rows) *rows = SLtt_Screen_Rows;
+ if (cols) *cols = SLtt_Screen_Cols;
+}
+
+void newtDefaultPlaceHandler(newtComponent c, int newLeft, int newTop) {
+ c->left = newLeft;
+ c->top = newTop;
+}
+
+void newtDefaultMappedHandler(newtComponent c, int isMapped) {
+ c->isMapped = isMapped;
+}
+
+void newtCursorOff(void) {
+ cursorOn = 0;
+ SLtt_set_cursor_visibility (cursorOn);
+}
+
+void newtCursorOn(void) {
+ cursorOn = 1;
+ SLtt_set_cursor_visibility (cursorOn);
+}
diff --git a/mdk-stage1/newt/newt.h b/mdk-stage1/newt/newt.h
new file mode 100644
index 000000000..d3fd8bedc
--- /dev/null
+++ b/mdk-stage1/newt/newt.h
@@ -0,0 +1,362 @@
+#ifndef H_NEWT
+#define H_NEWT
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <stdarg.h>
+
+#define NEWT_COLORSET_ROOT 2
+#define NEWT_COLORSET_BORDER 3
+#define NEWT_COLORSET_WINDOW 4
+#define NEWT_COLORSET_SHADOW 5
+#define NEWT_COLORSET_TITLE 6
+#define NEWT_COLORSET_BUTTON 7
+#define NEWT_COLORSET_ACTBUTTON 8
+#define NEWT_COLORSET_CHECKBOX 9
+#define NEWT_COLORSET_ACTCHECKBOX 10
+#define NEWT_COLORSET_ENTRY 11
+#define NEWT_COLORSET_LABEL 12
+#define NEWT_COLORSET_LISTBOX 13
+#define NEWT_COLORSET_ACTLISTBOX 14
+#define NEWT_COLORSET_TEXTBOX 15
+#define NEWT_COLORSET_ACTTEXTBOX 16
+#define NEWT_COLORSET_HELPLINE 17
+#define NEWT_COLORSET_ROOTTEXT 18
+#define NEWT_COLORSET_EMPTYSCALE 19
+#define NEWT_COLORSET_FULLSCALE 20
+#define NEWT_COLORSET_DISENTRY 21
+#define NEWT_COLORSET_COMPACTBUTTON 22
+#define NEWT_COLORSET_ACTSELLISTBOX 23
+#define NEWT_COLORSET_SELLISTBOX 24
+
+#define NEWT_ARG_LAST -100000
+#define NEWT_ARG_APPEND -1
+
+struct newtColors {
+ char * rootFg, * rootBg;
+ char * borderFg, * borderBg;
+ char * windowFg, * windowBg;
+ char * shadowFg, * shadowBg;
+ char * titleFg, * titleBg;
+ char * buttonFg, * buttonBg;
+ char * actButtonFg, * actButtonBg;
+ char * checkboxFg, * checkboxBg;
+ char * actCheckboxFg, * actCheckboxBg;
+ char * entryFg, * entryBg;
+ char * labelFg, * labelBg;
+ char * listboxFg, * listboxBg;
+ char * actListboxFg, * actListboxBg;
+ char * textboxFg, * textboxBg;
+ char * actTextboxFg, * actTextboxBg;
+ char * helpLineFg, * helpLineBg;
+ char * rootTextFg, * rootTextBg;
+ char * emptyScale, * fullScale;
+ char * disabledEntryFg, * disabledEntryBg;
+ char * compactButtonFg, * compactButtonBg;
+ char * actSelListboxFg, * actSelListboxBg;
+ char * selListboxFg, * selListboxBg;
+};
+
+enum newtFlagsSense { NEWT_FLAGS_SET, NEWT_FLAGS_RESET, NEWT_FLAGS_TOGGLE };
+
+#define NEWT_FLAG_RETURNEXIT (1 << 0)
+#define NEWT_FLAG_HIDDEN (1 << 1)
+#define NEWT_FLAG_SCROLL (1 << 2)
+#define NEWT_FLAG_DISABLED (1 << 3)
+/* OBSOLETE #define NEWT_FLAG_NOSCROLL (1 << 4) for listboxes */
+#define NEWT_FLAG_BORDER (1 << 5)
+#define NEWT_FLAG_WRAP (1 << 6)
+#define NEWT_FLAG_NOF12 (1 << 7)
+#define NEWT_FLAG_MULTIPLE (1 << 8)
+#define NEWT_FLAG_SELECTED (1 << 9)
+#define NEWT_FLAG_CHECKBOX (1 << 10)
+#define NEWT_FLAG_PASSWORD (1 << 11) /* draw '*' of chars in entrybox */
+#define NEWT_FD_READ (1 << 0)
+#define NEWT_FD_WRITE (1 << 1)
+
+#define NEWT_CHECKBOXTREE_COLLAPSED '\0'
+#define NEWT_CHECKBOXTREE_EXPANDED '\1'
+#define NEWT_CHECKBOXTREE_UNSELECTED ' '
+#define NEWT_CHECKBOXTREE_SELECTED '*'
+
+/* Backwards compatibility */
+#define NEWT_LISTBOX_RETURNEXIT NEWT_FLAG_RETURNEXIT
+#define NEWT_ENTRY_SCROLL NEWT_FLAG_SCROLL
+#define NEWT_ENTRY_HIDDEN NEWT_FLAG_HIDDEN
+#define NEWT_ENTRY_RETURNEXIT NEWT_FLAG_RETURNEXIT
+#define NEWT_ENTRY_DISABLED NEWT_FLAG_DISABLED
+
+#define NEWT_TEXTBOX_WRAP NEWT_FLAG_WRAP
+#define NEWT_TEXTBOX_SCROLL NEWT_FLAG_SCROLL
+#define NEWT_FORM_NOF12 NEWT_FLAG_NOF12
+
+#define newtListboxAddEntry newtListboxAppendEntry
+
+
+typedef struct newtComponent_struct * newtComponent;
+
+extern const struct newtColors newtDefaultColorPalette;
+
+typedef void (*newtCallback)(newtComponent, void *);
+typedef void (*newtSuspendCallback)(void * data);
+
+int newtInit(void);
+int newtFinished(void);
+void newtCls(void);
+void newtResizeScreen(int redraw);
+void newtWaitForKey(void);
+void newtClearKeyBuffer(void);
+void newtDelay(int usecs);
+/* top, left are *not* counting the border */
+int newtOpenWindow(int left, int top, int width, int height,
+ const char * title);
+int newtCenteredWindow(int width, int height, const char * title);
+void newtPopWindow(void);
+void newtSetColors(struct newtColors colors);
+void newtRefresh(void);
+void newtSuspend(void);
+void newtSetSuspendCallback(newtSuspendCallback cb, void * data);
+void newtSetHelpCallback(newtCallback cb);
+void newtResume(void);
+void newtPushHelpLine(const char * text);
+void newtRedrawHelpLine(void);
+void newtPopHelpLine(void);
+void newtDrawRootText(int col, int row, const char * text);
+void newtBell(void);
+void newtCursorOff(void);
+void newtCursorOn(void);
+
+/* Components */
+
+newtComponent newtCompactButton(int left, int top, const char * text);
+newtComponent newtButton(int left, int top, const char * text);
+newtComponent newtCheckbox(int left, int top, const char * text, char defValue,
+ const char * seq, char * result);
+char newtCheckboxGetValue(newtComponent co);
+void newtCheckboxSetValue(newtComponent co, char value);
+void newtCheckboxSetFlags(newtComponent co, int flags, enum newtFlagsSense sense);
+
+
+newtComponent newtRadiobutton(int left, int top, const char * text, int isDefault,
+ newtComponent prevButton);
+newtComponent newtRadioGetCurrent(newtComponent setMember);
+newtComponent newtListitem(int left, int top, const char * text, int isDefault,
+ newtComponent prevItem, const void * data, int flags);
+void newtListitemSet(newtComponent co, const char * text);
+void * newtListitemGetData(newtComponent co);
+void newtGetScreenSize(int * cols, int * rows);
+
+newtComponent newtLabel(int left, int top, const char * text);
+void newtLabelSetText(newtComponent co, const char * text);
+newtComponent newtVerticalScrollbar(int left, int top, int height,
+ int normalColorset, int thumbColorset);
+void newtScrollbarSet(newtComponent co, int where, int total);
+
+newtComponent newtListbox(int left, int top, int height, int flags);
+void * newtListboxGetCurrent(newtComponent co);
+void newtListboxSetCurrent(newtComponent co, int num);
+void newtListboxSetCurrentByKey(newtComponent co, void * key);
+void newtListboxSetEntry(newtComponent co, int num, const char * text);
+void newtListboxSetWidth(newtComponent co, int width);
+void newtListboxSetData(newtComponent co, int num, void * data);
+int newtListboxAppendEntry(newtComponent co, const char * text,
+ const void * data);
+/* Send the key to insert after, or NULL to insert at the top */
+int newtListboxInsertEntry(newtComponent co, const char * text, const void * data, void * key);
+int newtListboxDeleteEntry(newtComponent co, void * data);
+void newtListboxClear(newtComponent co); /* removes all entries from listbox */
+void newtListboxGetEntry(newtComponent co, int num, char **text, void **data);
+/* Returns an array of data pointers from items, last element is NULL */
+void **newtListboxGetSelection(newtComponent co, int *numitems);
+void newtListboxClearSelection(newtComponent co);
+void newtListboxSelectItem(newtComponent co, const void * key,
+ enum newtFlagsSense sense);
+
+newtComponent newtCheckboxTree(int left, int top, int height, int flags);
+newtComponent newtCheckboxTreeMulti(int left, int top, int height, char *seq, int flags);
+const void ** newtCheckboxTreeGetSelection(newtComponent co, int *numitems);
+const void * newtCheckboxTreeGetCurrent(newtComponent co);
+const void ** newtCheckboxTreeGetMultiSelection(newtComponent co, int *numitems, char seqnum);
+/* last item is NEWT_ARG_LAST for all of these */
+int newtCheckboxTreeAddItem(newtComponent co,
+ const char * text, const void * data,
+ int flags, int index, ...);
+int newtCheckboxTreeAddArray(newtComponent co,
+ const char * text, const void * data,
+ int flags, int * indexes);
+int * newtCheckboxTreeFindItem(newtComponent co, void * data);
+void newtCheckboxTreeSetEntry(newtComponent co, const void * data,
+ const char * text);
+char newtCheckboxTreeGetEntryValue(newtComponent co, const void * data);
+void newtCheckboxTreeSetEntryValue(newtComponent co, const void * data,
+ char value);
+
+newtComponent newtTextboxReflowed(int left, int top, char * text, int width,
+ int flexDown, int flexUp, int flags);
+newtComponent newtTextbox(int left, int top, int width, int height, int flags);
+void newtTextboxSetText(newtComponent co, const char * text);
+void newtTextboxSetHeight(newtComponent co, int height);
+int newtTextboxGetNumLines(newtComponent co);
+char * newtReflowText(char * text, int width, int flexDown, int flexUp,
+ int * actualWidth, int * actualHeight);
+
+struct newtExitStruct {
+ enum { NEWT_EXIT_HOTKEY, NEWT_EXIT_COMPONENT, NEWT_EXIT_FDREADY,
+ NEWT_EXIT_TIMER } reason;
+ union {
+ int key;
+ newtComponent co;
+ } u;
+} ;
+
+newtComponent newtForm(newtComponent vertBar, void * helpTag, int flags);
+void newtFormSetTimer(newtComponent form, int millisecs);
+void newtFormWatchFd(newtComponent form, int fd, int fdFlags);
+void newtFormSetSize(newtComponent co);
+newtComponent newtFormGetCurrent(newtComponent co);
+void newtFormSetBackground(newtComponent co, int color);
+void newtFormSetCurrent(newtComponent co, newtComponent subco);
+void newtFormAddComponent(newtComponent form, newtComponent co);
+void newtFormAddComponents(newtComponent form, ...);
+void newtFormSetHeight(newtComponent co, int height);
+void newtFormSetWidth(newtComponent co, int width);
+newtComponent newtRunForm(newtComponent form); /* obsolete */
+void newtFormRun(newtComponent co, struct newtExitStruct * es);
+void newtDrawForm(newtComponent form);
+void newtFormAddHotKey(newtComponent co, int key);
+
+typedef int (*newtEntryFilter)(newtComponent entry, void * data, int ch,
+ int cursor);
+newtComponent newtEntry(int left, int top, const char * initialValue, int width,
+ char ** resultPtr, int flags);
+void newtEntrySet(newtComponent co, const char * value, int cursorAtEnd);
+void newtEntrySetFilter(newtComponent co, newtEntryFilter filter, void * data);
+char * newtEntryGetValue(newtComponent co);
+void newtEntrySetFlags(newtComponent co, int flags, enum newtFlagsSense sense);
+
+newtComponent newtScale(int left, int top, int width, int fullValue);
+void newtScaleSet(newtComponent co, unsigned int amount);
+
+void newtComponentAddCallback(newtComponent co, newtCallback f, void * data);
+void newtComponentTakesFocus(newtComponent co, int val);
+
+/* this also destroys all of the components (including other forms) on the
+ form */
+void newtFormDestroy(newtComponent form);
+
+/* Key codes */
+
+#define NEWT_KEY_TAB '\t'
+#define NEWT_KEY_ENTER '\r'
+#define NEWT_KEY_SUSPEND '\032' /* ctrl - z*/
+#define NEWT_KEY_RETURN NEWT_KEY_ENTER
+
+#define NEWT_KEY_EXTRA_BASE 0x8000
+#define NEWT_KEY_UP NEWT_KEY_EXTRA_BASE + 1
+#define NEWT_KEY_DOWN NEWT_KEY_EXTRA_BASE + 2
+#define NEWT_KEY_LEFT NEWT_KEY_EXTRA_BASE + 4
+#define NEWT_KEY_RIGHT NEWT_KEY_EXTRA_BASE + 5
+#define NEWT_KEY_BKSPC NEWT_KEY_EXTRA_BASE + 6
+#define NEWT_KEY_DELETE NEWT_KEY_EXTRA_BASE + 7
+#define NEWT_KEY_HOME NEWT_KEY_EXTRA_BASE + 8
+#define NEWT_KEY_END NEWT_KEY_EXTRA_BASE + 9
+#define NEWT_KEY_UNTAB NEWT_KEY_EXTRA_BASE + 10
+#define NEWT_KEY_PGUP NEWT_KEY_EXTRA_BASE + 11
+#define NEWT_KEY_PGDN NEWT_KEY_EXTRA_BASE + 12
+#define NEWT_KEY_INSERT NEWT_KEY_EXTRA_BASE + 13
+
+#define NEWT_KEY_F1 NEWT_KEY_EXTRA_BASE + 101
+#define NEWT_KEY_F2 NEWT_KEY_EXTRA_BASE + 102
+#define NEWT_KEY_F3 NEWT_KEY_EXTRA_BASE + 103
+#define NEWT_KEY_F4 NEWT_KEY_EXTRA_BASE + 104
+#define NEWT_KEY_F5 NEWT_KEY_EXTRA_BASE + 105
+#define NEWT_KEY_F6 NEWT_KEY_EXTRA_BASE + 106
+#define NEWT_KEY_F7 NEWT_KEY_EXTRA_BASE + 107
+#define NEWT_KEY_F8 NEWT_KEY_EXTRA_BASE + 108
+#define NEWT_KEY_F9 NEWT_KEY_EXTRA_BASE + 109
+#define NEWT_KEY_F10 NEWT_KEY_EXTRA_BASE + 110
+#define NEWT_KEY_F11 NEWT_KEY_EXTRA_BASE + 111
+#define NEWT_KEY_F12 NEWT_KEY_EXTRA_BASE + 112
+
+/* not really a key, but newtGetKey returns it */
+#define NEWT_KEY_RESIZE NEWT_KEY_EXTRA_BASE + 113
+
+#define NEWT_ANCHOR_LEFT (1 << 0)
+#define NEWT_ANCHOR_RIGHT (1 << 1)
+#define NEWT_ANCHOR_TOP (1 << 2)
+#define NEWT_ANCHOR_BOTTOM (1 << 3)
+
+#define NEWT_GRID_FLAG_GROWX (1 << 0)
+#define NEWT_GRID_FLAG_GROWY (1 << 1)
+
+typedef struct grid_s * newtGrid;
+enum newtGridElement { NEWT_GRID_EMPTY = 0,
+ NEWT_GRID_COMPONENT, NEWT_GRID_SUBGRID };
+
+newtGrid newtCreateGrid(int cols, int rows);
+/* TYPE, what, TYPE, what, ..., NULL */
+newtGrid newtGridVStacked(enum newtGridElement type, void * what, ...);
+newtGrid newtGridVCloseStacked(enum newtGridElement type, void * what, ...);
+newtGrid newtGridHStacked(enum newtGridElement type1, void * what1, ...);
+newtGrid newtGridHCloseStacked(enum newtGridElement type1, void * what1, ...);
+newtGrid newtGridBasicWindow(newtComponent text, newtGrid middle,
+ newtGrid buttons);
+newtGrid newtGridSimpleWindow(newtComponent text, newtComponent middle,
+ newtGrid buttons);
+void newtGridSetField(newtGrid grid, int col, int row,
+ enum newtGridElement type, void * val, int padLeft,
+ int padTop, int padRight, int padBottom, int anchor,
+ int flags);
+void newtGridPlace(newtGrid grid, int left, int top);
+#define newtGridDestroy newtGridFree
+void newtGridFree(newtGrid grid, int recurse);
+void newtGridGetSize(newtGrid grid, int * width, int * height);
+void newtGridWrappedWindow(newtGrid grid, char * title);
+void newtGridWrappedWindowAt(newtGrid grid, char * title, int left, int top);
+void newtGridAddComponentsToForm(newtGrid grid, newtComponent form,
+ int recurse);
+
+/* convienve */
+newtGrid newtButtonBarv(char * button1, newtComponent * b1comp, va_list args);
+newtGrid newtButtonBar(char * button1, newtComponent * b1comp, ...);
+
+/* automatically centered and shrink wrapped */
+void newtWinMessage(char * title, char * buttonText, char * text, ...);
+void newtWinMessagev(char * title, char * buttonText, char * text,
+ va_list argv);
+
+/* having separate calls for these two seems silly, but having two separate
+ variable length-arg lists seems like a bad idea as well */
+
+/* Returns 0 if F12 was pressed, 1 for button1, 2 for button2 */
+int newtWinChoice(char * title, char * button1, char * button2,
+ char * text, ...);
+/* Returns 0 if F12 was pressed, 1 for button1, 2 for button2,
+ 3 for button3 */
+int newtWinTernary(char * title, char * button1, char * button2,
+ char * button3, char * message, ...);
+
+/* Returns the button number pressed, 0 on F12 */
+int newtWinMenu(char * title, char * text, int suggestedWidth, int flexDown,
+ int flexUp, int maxListHeight, char ** items, int * listItem,
+ char * button1, ...);
+
+struct newtWinEntry {
+ char * text;
+ char ** value; /* may be initialized to set default */
+ int flags;
+};
+
+/* Returns the button number pressed, 0 on F12. The final values are
+ dynamically allocated, and need to be freed. */
+int newtWinEntries(char * title, char * text, int suggestedWidth, int flexDown,
+ int flexUp, int dataWidth,
+ struct newtWinEntry * items, char * button1, ...);
+
+#ifdef __cplusplus
+} /* End of extern "C" { */
+#endif
+
+#endif /* H_NEWT */
diff --git a/mdk-stage1/newt/newt_pr.h b/mdk-stage1/newt/newt_pr.h
new file mode 100644
index 000000000..76f5e2f6f
--- /dev/null
+++ b/mdk-stage1/newt/newt_pr.h
@@ -0,0 +1,82 @@
+#ifndef H_NEWT_PR
+#define H_NEWT_PR
+
+#define COLORSET_ROOT NEWT_COLORSET_ROOT
+#define COLORSET_BORDER NEWT_COLORSET_BORDER
+#define COLORSET_WINDOW NEWT_COLORSET_WINDOW
+#define COLORSET_SHADOW NEWT_COLORSET_SHADOW
+#define COLORSET_TITLE NEWT_COLORSET_TITLE
+#define COLORSET_BUTTON NEWT_COLORSET_BUTTON
+#define COLORSET_ACTBUTTON NEWT_COLORSET_ACTBUTTON
+#define COLORSET_CHECKBOX NEWT_COLORSET_CHECKBOX
+#define COLORSET_ACTCHECKBOX NEWT_COLORSET_ACTCHECKBOX
+#define COLORSET_ENTRY NEWT_COLORSET_ENTRY
+#define COLORSET_LABEL NEWT_COLORSET_LABEL
+#define COLORSET_LISTBOX NEWT_COLORSET_LISTBOX
+#define COLORSET_ACTLISTBOX NEWT_COLORSET_ACTLISTBOX
+#define COLORSET_TEXTBOX NEWT_COLORSET_TEXTBOX
+#define COLORSET_ACTTEXTBOX NEWT_COLORSET_ACTTEXTBOX
+
+int newtSetFlags(int oldFlags, int newFlags, enum newtFlagsSense sense);
+
+void newtGotorc(int row, int col);
+void newtGetrc(int * row, int * col);
+void newtGetWindowPos(int * x, int * y);
+void newtDrawBox(int left, int top, int width, int height, int shadow);
+void newtClearBox(int left, int top, int width, int height);
+
+int newtGetKey(void);
+
+struct newtComponent_struct {
+ /* common data */
+ int height, width;
+ int top, left;
+ int takesFocus;
+ int isMapped;
+
+ struct componentOps * ops;
+
+ newtCallback callback;
+ void * callbackData;
+
+ void * data;
+} ;
+
+enum eventResultTypes { ER_IGNORED, ER_SWALLOWED, ER_EXITFORM, ER_SETFOCUS,
+ ER_NEXTCOMP };
+struct eventResult {
+ enum eventResultTypes result;
+ union {
+ newtComponent focus;
+ } u;
+};
+
+enum eventTypes { EV_FOCUS, EV_UNFOCUS, EV_KEYPRESS, EV_MOUSE };
+enum eventSequence { EV_EARLY, EV_NORMAL, EV_LATE };
+
+struct event {
+ enum eventTypes event;
+ enum eventSequence when;
+ union {
+ int key;
+ struct {
+ enum { MOUSE_MOTION, MOUSE_BUTTON_DOWN, MOUSE_BUTTON_UP } type;
+ int x, y;
+ } mouse;
+ } u;
+} ;
+
+struct componentOps {
+ void (* draw)(newtComponent c);
+ struct eventResult (* event)(newtComponent c, struct event ev);
+ void (* destroy)(newtComponent c);
+ void (* place)(newtComponent c, int newLeft, int newTop);
+ void (* mapped)(newtComponent c, int isMapped);
+} ;
+
+void newtDefaultPlaceHandler(newtComponent c, int newLeft, int newTop);
+void newtDefaultMappedHandler(newtComponent c, int isMapped);
+struct eventResult newtDefaultEventHandler(newtComponent c,
+ struct event ev);
+
+#endif /* H_NEWT_PR */
diff --git a/mdk-stage1/newt/scale.c b/mdk-stage1/newt/scale.c
new file mode 100644
index 000000000..800958580
--- /dev/null
+++ b/mdk-stage1/newt/scale.c
@@ -0,0 +1,72 @@
+#include <slang.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+struct scale {
+ int fullValue;
+ int charsSet;
+};
+
+static void scaleDraw(newtComponent co);
+
+static struct componentOps scaleOps = {
+ scaleDraw,
+ newtDefaultEventHandler,
+ NULL,
+ newtDefaultPlaceHandler,
+ newtDefaultMappedHandler,
+} ;
+
+newtComponent newtScale(int left, int top, int width, int fullValue) {
+ newtComponent co;
+ struct scale * sc;
+
+ co = malloc(sizeof(*co));
+ sc = malloc(sizeof(struct scale));
+ co->data = sc;
+
+ co->ops = &scaleOps;
+
+ co->height = 1;
+ co->width = width;
+ co->top = top;
+ co->left = left;
+ co->takesFocus = 0;
+
+ sc->fullValue = fullValue;
+ sc->charsSet = 0;
+
+ return co;
+}
+
+void newtScaleSet(newtComponent co, unsigned int amount) {
+ struct scale * sc = co->data;
+ int newCharsSet;
+
+ newCharsSet = (amount * co->width) / sc->fullValue;
+
+ if (newCharsSet != sc->charsSet) {
+ sc->charsSet = newCharsSet;
+ scaleDraw(co);
+ }
+}
+
+static void scaleDraw(newtComponent co) {
+ struct scale * sc = co->data;
+ int i;
+
+ if (co->top == -1) return;
+
+ newtGotorc(co->top, co->left);
+
+ SLsmg_set_color(NEWT_COLORSET_FULLSCALE);
+ for (i = 0; i < sc->charsSet; i++)
+ SLsmg_write_string(" ");
+
+ SLsmg_set_color(NEWT_COLORSET_EMPTYSCALE);
+ for (i = 0; i < (co->width - sc->charsSet); i++)
+ SLsmg_write_string(" ");
+}
diff --git a/mdk-stage1/newt/scrollbar.c b/mdk-stage1/newt/scrollbar.c
new file mode 100644
index 000000000..cb4bc2757
--- /dev/null
+++ b/mdk-stage1/newt/scrollbar.c
@@ -0,0 +1,124 @@
+#include <slang.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+struct scrollbar {
+ int curr;
+ int cs, csThumb;
+ int arrows;
+} ;
+
+static void sbDraw(newtComponent co);
+static void sbDestroy(newtComponent co);
+static void sbDrawThumb(newtComponent co, int isOn);
+
+static struct componentOps sbOps = {
+ sbDraw,
+ newtDefaultEventHandler,
+ sbDestroy,
+ newtDefaultPlaceHandler,
+ newtDefaultMappedHandler,
+} ;
+
+void newtScrollbarSet(newtComponent co, int where, int total) {
+ struct scrollbar * sb = co->data;
+ int new;
+
+ if (sb->arrows)
+ new = (where * (co->height - 3)) / (total ? total : 1) + 1;
+ else
+ new = (where * (co->height - 1)) / (total ? total : 1);
+ if (new != sb->curr) {
+ sbDrawThumb(co, 0);
+ sb->curr = new;
+ sbDrawThumb(co, 1);
+ }
+}
+
+newtComponent newtVerticalScrollbar(int left, int top, int height,
+ int normalColorset, int thumbColorset) {
+ newtComponent co;
+ struct scrollbar * sb;
+
+ co = malloc(sizeof(*co));
+ sb = malloc(sizeof(*sb));
+ co->data = sb;
+
+ if (!strcmp(getenv("TERM"), "linux") && height >= 2) {
+ sb->arrows = 1;
+ sb->curr = 1;
+ } else {
+ sb->arrows = 0;
+ sb->curr = 0;
+ }
+ sb->cs = normalColorset;
+ sb->csThumb = thumbColorset;
+
+ co->ops = &sbOps;
+ co->isMapped = 0;
+ co->left = left;
+ co->top = top;
+ co->height = height;
+ co->width = 1;
+ co->takesFocus = 0;
+
+ return co;
+}
+
+static void sbDraw(newtComponent co) {
+ struct scrollbar * sb = co->data;
+ int i;
+
+ if (!co->isMapped) return;
+
+ SLsmg_set_color(sb->cs);
+
+ SLsmg_set_char_set(1);
+ if (sb->arrows) {
+ newtGotorc(co->top, co->left);
+ SLsmg_write_char('\x2d');
+ for (i = 1; i < co->height - 1; i++) {
+ newtGotorc(i + co->top, co->left);
+ SLsmg_write_char('\x61');
+ }
+ newtGotorc(co->top + co->height - 1, co->left);
+ SLsmg_write_char('\x2e');
+ } else {
+ for (i = 0; i < co->height; i++) {
+ newtGotorc(i + co->top, co->left);
+ SLsmg_write_char('\x61');
+ }
+ }
+
+ SLsmg_set_char_set(0);
+
+ sbDrawThumb(co, 1);
+}
+
+static void sbDrawThumb(newtComponent co, int isOn) {
+ struct scrollbar * sb = co->data;
+ char ch = isOn ? '#' : '\x61';
+
+ if (!co->isMapped) return;
+
+ newtGotorc(sb->curr + co->top, co->left);
+ SLsmg_set_char_set(1);
+
+ /*if (isOn)
+ SLsmg_set_color(sb->csThumb);
+ else*/
+ SLsmg_set_color(sb->cs);
+
+ SLsmg_write_char(ch);
+ SLsmg_set_char_set(0);
+}
+
+static void sbDestroy(newtComponent co) {
+ struct scrollbar * sb = co->data;
+
+ free(sb);
+ free(co);
+}
diff --git a/mdk-stage1/newt/textbox.c b/mdk-stage1/newt/textbox.c
new file mode 100644
index 000000000..272c9b675
--- /dev/null
+++ b/mdk-stage1/newt/textbox.c
@@ -0,0 +1,409 @@
+#include <ctype.h>
+#include <slang.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "newt.h"
+#include "newt_pr.h"
+
+struct textbox {
+ char ** lines;
+ int numLines;
+ int linesAlloced;
+ int doWrap;
+ newtComponent sb;
+ int topLine;
+ int textWidth;
+};
+
+static char * expandTabs(const char * text);
+static void textboxDraw(newtComponent co);
+static void addLine(newtComponent co, const char * s, int len);
+static void doReflow(const char * text, char ** resultPtr, int width,
+ int * badness, int * heightPtr);
+static struct eventResult textboxEvent(newtComponent c,
+ struct event ev);
+static void textboxDestroy(newtComponent co);
+static void textboxPlace(newtComponent co, int newLeft, int newTop);
+static void textboxMapped(newtComponent co, int isMapped);
+
+static struct componentOps textboxOps = {
+ textboxDraw,
+ textboxEvent,
+ textboxDestroy,
+ textboxPlace,
+ textboxMapped,
+} ;
+
+static void textboxMapped(newtComponent co, int isMapped) {
+ struct textbox * tb = co->data;
+
+ co->isMapped = isMapped;
+ if (tb->sb)
+ tb->sb->ops->mapped(tb->sb, isMapped);
+}
+
+static void textboxPlace(newtComponent co, int newLeft, int newTop) {
+ struct textbox * tb = co->data;
+
+ co->top = newTop;
+ co->left = newLeft;
+
+ if (tb->sb)
+ tb->sb->ops->place(tb->sb, co->left + co->width - 1, co->top);
+}
+
+void newtTextboxSetHeight(newtComponent co, int height) {
+ co->height = height;
+}
+
+int newtTextboxGetNumLines(newtComponent co) {
+ struct textbox * tb = co->data;
+
+ return (tb->numLines);
+}
+
+newtComponent newtTextboxReflowed(int left, int top, char * text, int width,
+ int flexDown, int flexUp, int flags) {
+ newtComponent co;
+ char * reflowedText;
+ int actWidth, actHeight;
+
+ reflowedText = newtReflowText(text, width, flexDown, flexUp,
+ &actWidth, &actHeight);
+
+ co = newtTextbox(left, top, actWidth, actHeight, NEWT_FLAG_WRAP);
+ newtTextboxSetText(co, reflowedText);
+ free(reflowedText);
+
+ return co;
+}
+
+newtComponent newtTextbox(int left, int top, int width, int height, int flags) {
+ newtComponent co;
+ struct textbox * tb;
+
+ co = malloc(sizeof(*co));
+ tb = malloc(sizeof(*tb));
+ co->data = tb;
+
+ co->ops = &textboxOps;
+
+ co->height = height;
+ co->top = top;
+ co->left = left;
+ co->takesFocus = 0;
+ co->width = width;
+
+ tb->doWrap = flags & NEWT_FLAG_WRAP;
+ tb->numLines = 0;
+ tb->linesAlloced = 0;
+ tb->lines = NULL;
+ tb->topLine = 0;
+ tb->textWidth = width;
+
+ if (flags & NEWT_FLAG_SCROLL) {
+ co->width += 2;
+ tb->sb = newtVerticalScrollbar(co->left + co->width - 1, co->top,
+ co->height, COLORSET_TEXTBOX, COLORSET_TEXTBOX);
+ } else {
+ tb->sb = NULL;
+ }
+
+ return co;
+}
+
+static char * expandTabs(const char * text) {
+ int bufAlloced = strlen(text) + 40;
+ char * buf, * dest;
+ const char * src;
+ int bufUsed = 0;
+ int linePos = 0;
+ int i;
+
+ buf = malloc(bufAlloced + 1);
+ for (src = text, dest = buf; *src; src++) {
+ if ((bufUsed + 10) > bufAlloced) {
+ bufAlloced += strlen(text) / 2;
+ buf = realloc(buf, bufAlloced + 1);
+ dest = buf + bufUsed;
+ }
+ if (*src == '\t') {
+ i = 8 - (linePos & 8);
+ memset(dest, ' ', i);
+ dest += i, bufUsed += i, linePos += i;
+ } else {
+ if (*src == '\n')
+ linePos = 0;
+ else
+ linePos++;
+
+ *dest++ = *src;
+ bufUsed++;
+ }
+ }
+
+ *dest = '\0';
+ return buf;
+}
+
+#define iseuckanji(c) (0xa1 <= (unsigned char)(c&0xff) && (unsigned char)(c&0xff) <= 0xfe)
+
+static void doReflow(const char * text, char ** resultPtr, int width,
+ int * badness, int * heightPtr) {
+ char * result = NULL;
+ const char * chptr, * end;
+ int i;
+ int howbad = 0;
+ int height = 0;
+ int kanji = 0;
+
+ if (resultPtr) {
+ /* XXX I think this will work */
+ result = malloc(strlen(text) + (strlen(text) / width) + 50);
+ *result = '\0';
+ }
+
+ while (*text) {
+ kanji = 0;
+ end = strchr(text, '\n');
+ if (!end)
+ end = text + strlen(text);
+
+ while (*text && text < end) {
+ if (end - text < width) {
+ if (result) {
+ strncat(result, text, end - text + 1);
+ strcat(result, "\n");
+ height++;
+ }
+
+ if (end - text < (width / 2))
+ howbad += ((width / 2) - (end - text)) / 2;
+ text = end;
+ if (*text) text++;
+ } else {
+ chptr = text;
+ kanji = 0;
+ for ( i = 0; i < width - 1; i++ ) {
+ if ( !iseuckanji(*chptr)) {
+ kanji = 0;
+ } else if ( kanji == 1 ) {
+ kanji = 2;
+ } else {
+ kanji = 1;
+ }
+ chptr++;
+ }
+ if (kanji == 0) {
+ while (chptr > text && !isspace(*chptr)) chptr--;
+ while (chptr > text && isspace(*chptr)) chptr--;
+ chptr++;
+ }
+
+ if (chptr-text == 1 && !isspace(*chptr))
+ chptr = text + width - 1;
+
+ if (chptr > text)
+ howbad += width - (chptr - text) + 1;
+ if (result) {
+ if (kanji == 1) {
+ strncat(result, text, chptr - text + 1);
+ chptr++;
+ kanji = 0;
+ } else {
+ strncat(result, text, chptr - text + 1);
+ }
+ strcat(result, "\n");
+ height++;
+ }
+
+ if (isspace(*chptr))
+ text = chptr + 1;
+ else
+ text = chptr;
+ while (isspace(*text)) text++;
+ }
+ }
+ }
+
+// if (result) printf("result: %s\n", result);
+
+ if (badness) *badness = howbad;
+ if (resultPtr) *resultPtr = result;
+ if (heightPtr) *heightPtr = height;
+}
+
+char * newtReflowText(char * text, int width, int flexDown, int flexUp,
+ int * actualWidth, int * actualHeight) {
+ int min, max;
+ int i;
+ char * result;
+ int minbad, minbadwidth, howbad;
+ char * expandedText;
+
+ expandedText = expandTabs(text);
+
+ if (flexDown || flexUp) {
+ min = width - flexDown;
+ max = width + flexUp;
+
+ minbad = -1;
+ minbadwidth = width;
+
+ for (i = min; i <= max; i++) {
+ doReflow(expandedText, NULL, i, &howbad, NULL);
+
+ if (minbad == -1 || howbad < minbad) {
+ minbad = howbad;
+ minbadwidth = i;
+ }
+ }
+
+ width = minbadwidth;
+ }
+
+ doReflow(expandedText, &result, width, NULL, actualHeight);
+ free(expandedText);
+ if (actualWidth) *actualWidth = width;
+ return result;
+}
+
+void newtTextboxSetText(newtComponent co, const char * text) {
+ const char * start, * end;
+ struct textbox * tb = co->data;
+ char * reflowed, * expanded;
+ int badness, height;
+
+ if (tb->lines) {
+ free(tb->lines);
+ tb->linesAlloced = tb->numLines = 0;
+ }
+
+ expanded = expandTabs(text);
+
+ if (tb->doWrap) {
+ doReflow(expanded, &reflowed, tb->textWidth, &badness, &height);
+ free(expanded);
+ expanded = reflowed;
+ }
+
+ for (start = expanded; *start; start++)
+ if (*start == '\n') tb->linesAlloced++;
+
+ /* This ++ leaves room for an ending line w/o a \n */
+ tb->linesAlloced++;
+ tb->lines = malloc(sizeof(char *) * tb->linesAlloced);
+
+ start = expanded;
+ while ((end = strchr(start, '\n'))) {
+ addLine(co, start, end - start);
+ start = end + 1;
+ }
+
+ if (*start)
+ addLine(co, start, strlen(start));
+
+ free(expanded);
+}
+
+/* This assumes the buffer is allocated properly! */
+static void addLine(newtComponent co, const char * s, int len) {
+ struct textbox * tb = co->data;
+
+ if (len > tb->textWidth) len = tb->textWidth;
+
+ tb->lines[tb->numLines] = malloc(tb->textWidth + 1);
+ memset(tb->lines[tb->numLines], ' ', tb->textWidth);
+ memcpy(tb->lines[tb->numLines], s, len);
+ tb->lines[tb->numLines++][tb->textWidth] = '\0';
+}
+
+static void textboxDraw(newtComponent c) {
+ int i;
+ struct textbox * tb = c->data;
+ int size;
+
+ if (tb->sb) {
+ size = tb->numLines - c->height;
+ newtScrollbarSet(tb->sb, tb->topLine, size ? size : 0);
+ tb->sb->ops->draw(tb->sb);
+ }
+
+ SLsmg_set_color(NEWT_COLORSET_TEXTBOX);
+
+ for (i = 0; (i + tb->topLine) < tb->numLines && i < c->height; i++) {
+ newtGotorc(c->top + i, c->left);
+ SLsmg_write_string(tb->lines[i + tb->topLine]);
+ }
+}
+
+static struct eventResult textboxEvent(newtComponent co,
+ struct event ev) {
+ struct textbox * tb = co->data;
+ struct eventResult er;
+
+ er.result = ER_IGNORED;
+
+ if (ev.when == EV_EARLY && ev.event == EV_KEYPRESS && tb->sb) {
+ switch (ev.u.key) {
+ case NEWT_KEY_UP:
+ if (tb->topLine) tb->topLine--;
+ textboxDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case NEWT_KEY_DOWN:
+ if (tb->topLine < (tb->numLines - co->height)) tb->topLine++;
+ textboxDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case NEWT_KEY_PGDN:
+ tb->topLine += co->height;
+ if (tb->topLine > (tb->numLines - co->height)) {
+ tb->topLine = tb->numLines - co->height;
+ if (tb->topLine < 0) tb->topLine = 0;
+ }
+ textboxDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+
+ case NEWT_KEY_PGUP:
+ tb->topLine -= co->height;
+ if (tb->topLine < 0) tb->topLine = 0;
+ textboxDraw(co);
+ er.result = ER_SWALLOWED;
+ break;
+ }
+ }
+ if (ev.when == EV_EARLY && ev.event == EV_MOUSE && tb->sb) {
+ /* Top scroll arrow */
+ if (ev.u.mouse.x == co->width && ev.u.mouse.y == co->top) {
+ if (tb->topLine) tb->topLine--;
+ textboxDraw(co);
+
+ er.result = ER_SWALLOWED;
+ }
+ /* Bottom scroll arrow */
+ if (ev.u.mouse.x == co->width &&
+ ev.u.mouse.y == co->top + co->height - 1) {
+ if (tb->topLine < (tb->numLines - co->height)) tb->topLine++;
+ textboxDraw(co);
+
+ er.result = ER_SWALLOWED;
+ }
+ }
+ return er;
+}
+
+static void textboxDestroy(newtComponent co) {
+ int i;
+ struct textbox * tb = co->data;
+
+ for (i = 0; i < tb->numLines; i++)
+ free(tb->lines[i]);
+ free(tb->lines);
+ free(tb);
+ free(co);
+}
diff --git a/mdk-stage1/newt/windows.c b/mdk-stage1/newt/windows.c
new file mode 100644
index 000000000..792d3ed76
--- /dev/null
+++ b/mdk-stage1/newt/windows.c
@@ -0,0 +1,275 @@
+#include <errno.h>
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "errno.h"
+#include "newt.h"
+
+static void * newtvwindow(char * title, char * button1, char * button2,
+ char * button3, char * message, va_list args) {
+ newtComponent b1, b2 = NULL, b3 = NULL, t, f, answer;
+ char * buf = NULL;
+ int size = 0;
+ int i = 0;
+ int scroll = 0;
+ int width, height;
+ char * flowedText;
+ newtGrid grid, buttonGrid;
+
+ do {
+ size += 1000;
+ if (buf) free(buf);
+ buf = malloc(size);
+ i = vsnprintf(buf, size, message, args);
+ } while (i >= size || i == -1);
+
+ flowedText = newtReflowText(buf, 35, 5, 5, &width, &height);
+ if (height > 6) {
+ free(flowedText);
+ flowedText = newtReflowText(buf, 60, 5, 5, &width, &height);
+ }
+ free(buf);
+
+ if (height > 12) {
+ height = 12;
+ scroll = NEWT_FLAG_SCROLL;
+ }
+ t = newtTextbox(-1, -1, width, height, NEWT_TEXTBOX_WRAP | scroll);
+ newtTextboxSetText(t, flowedText);
+ free(flowedText);
+
+ if (button3) {
+ buttonGrid = newtButtonBar(button1, &b1, button2, &b2,
+ button3, &b3, NULL);
+ } else if (button2) {
+ buttonGrid = newtButtonBar(button1, &b1, button2, &b2, NULL);
+ } else {
+ buttonGrid = newtButtonBar(button1, &b1, NULL);
+ }
+
+ newtGridSetField(buttonGrid, 0, 0, NEWT_GRID_COMPONENT, b1,
+ 0, 0, button2 ? 1 : 0, 0, 0, 0);
+
+ grid = newtCreateGrid(1, 2);
+ newtGridSetField(grid, 0, 0, NEWT_GRID_COMPONENT, t, 0, 0, 0, 0, 0, 0);
+ newtGridSetField(grid, 0, 1, NEWT_GRID_SUBGRID, buttonGrid,
+ 0, 1, 0, 0, 0, NEWT_GRID_FLAG_GROWX);
+ newtGridWrappedWindow(grid, title);
+
+ f = newtForm(NULL, NULL, 0);
+ newtFormAddComponents(f, t, b1, NULL);
+
+ if (button2)
+ newtFormAddComponent(f, b2);
+ if (button3)
+ newtFormAddComponent(f, b3);
+
+ answer = newtRunForm(f);
+ newtGridFree(grid, 1);
+
+ newtFormDestroy(f);
+ newtPopWindow();
+
+ if (answer == f)
+ return NULL;
+ else if (answer == b1)
+ return button1;
+ else if (answer == b2)
+ return button2;
+
+ return button3;
+}
+
+int newtWinChoice(char * title, char * button1, char * button2,
+ char * message, ...) {
+ va_list args;
+ void * rc;
+
+ va_start(args, message);
+ rc = newtvwindow(title, button1, button2, NULL, message, args);
+ va_end(args);
+
+ if (rc == button1)
+ return 1;
+ else if (rc == button2)
+ return 2;
+
+ return 0;
+}
+
+void newtWinMessage(char * title, char * buttonText, char * text, ...) {
+ va_list args;
+
+ va_start(args, text);
+ newtvwindow(title, buttonText, NULL, NULL, text, args);
+ va_end(args);
+}
+
+void newtWinMessagev(char * title, char * buttonText, char * text,
+ va_list argv) {
+ newtvwindow(title, buttonText, NULL, NULL, text, argv);
+}
+
+int newtWinTernary(char * title, char * button1, char * button2,
+ char * button3, char * message, ...) {
+ va_list args;
+ void * rc;
+
+ va_start(args, message);
+ rc = newtvwindow(title, button1, button2, button3, message, args);
+ va_end(args);
+
+ if (rc == button1)
+ return 1;
+ else if (rc == button2)
+ return 2;
+ else if (rc == button3)
+ return 3;
+
+ return 0;
+}
+
+/* only supports up to 50 buttons -- shucks! */
+int newtWinMenu(char * title, char * text, int suggestedWidth, int flexDown,
+ int flexUp, int maxListHeight, char ** items, int * listItem,
+ char * button1, ...) {
+ newtComponent textbox, listbox, result, form;
+ va_list args;
+ newtComponent buttons[50];
+ newtGrid grid, buttonBar;
+ int numButtons;
+ int i, rc;
+ int needScroll;
+ char * buttonName;
+
+ textbox = newtTextboxReflowed(-1, -1, text, suggestedWidth, flexDown,
+ flexUp, 0);
+
+ for (i = 0; items[i]; i++) ;
+ if (i < maxListHeight) maxListHeight = i;
+ needScroll = i > maxListHeight;
+
+ listbox = newtListbox(-1, -1, maxListHeight,
+ (needScroll ? NEWT_FLAG_SCROLL : 0) | NEWT_FLAG_RETURNEXIT);
+ for (i = 0; items[i]; i++) {
+ newtListboxAddEntry(listbox, items[i], (void *) i);
+ }
+
+ newtListboxSetCurrent(listbox, *listItem);
+
+ buttonName = button1, numButtons = 0;
+ va_start(args, button1);
+ while (buttonName) {
+ buttons[numButtons] = newtButton(-1, -1, buttonName);
+ numButtons++;
+ buttonName = va_arg(args, char *);
+ }
+
+ va_end(args);
+
+ buttonBar = newtCreateGrid(numButtons, 1);
+ for (i = 0; i < numButtons; i++) {
+ newtGridSetField(buttonBar, i, 0, NEWT_GRID_COMPONENT,
+ buttons[i],
+ i ? 1 : 0, 0, 0, 0, 0, 0);
+ }
+
+ grid = newtGridSimpleWindow(textbox, listbox, buttonBar);
+ newtGridWrappedWindow(grid, title);
+
+ form = newtForm(NULL, 0, 0);
+ newtGridAddComponentsToForm(grid, form, 1);
+ newtGridFree(grid, 1);
+
+ result = newtRunForm(form);
+
+ *listItem = ((long) newtListboxGetCurrent(listbox));
+
+ for (rc = 0; result != buttons[rc] && rc < numButtons; rc++);
+ if (rc == numButtons)
+ rc = 0; /* F12 or return-on-exit (which are the same for us) */
+ else
+ rc++;
+
+ newtFormDestroy(form);
+ newtPopWindow();
+
+ return rc;
+}
+
+/* only supports up to 50 buttons and entries -- shucks! */
+int newtWinEntries(char * title, char * text, int suggestedWidth, int flexDown,
+ int flexUp, int dataWidth,
+ struct newtWinEntry * items, char * button1, ...) {
+ newtComponent buttons[50], result, form, textw;
+ newtGrid grid, buttonBar, subgrid;
+ int numItems;
+ int rc, i;
+ int numButtons;
+ char * buttonName;
+ va_list args;
+
+ textw = newtTextboxReflowed(-1, -1, text, suggestedWidth, flexDown,
+ flexUp, 0);
+
+ for (numItems = 0; items[numItems].text; numItems++);
+
+ buttonName = button1, numButtons = 0;
+ va_start(args, button1);
+ while (buttonName) {
+ buttons[numButtons] = newtButton(-1, -1, buttonName);
+ numButtons++;
+ buttonName = va_arg(args, char *);
+ }
+
+ va_end(args);
+
+ buttonBar = newtCreateGrid(numButtons, 1);
+ for (i = 0; i < numButtons; i++) {
+ newtGridSetField(buttonBar, i, 0, NEWT_GRID_COMPONENT,
+ buttons[i],
+ i ? 1 : 0, 0, 0, 0, 0, 0);
+ }
+
+ subgrid = newtCreateGrid(2, numItems);
+ for (i = 0; i < numItems; i++) {
+ newtGridSetField(subgrid, 0, i, NEWT_GRID_COMPONENT,
+ newtLabel(-1, -1, items[i].text),
+ 0, 0, 0, 0, NEWT_ANCHOR_LEFT, 0);
+ newtGridSetField(subgrid, 1, i, NEWT_GRID_COMPONENT,
+ newtEntry(-1, -1, items[i].value ?
+ *items[i].value : NULL, dataWidth,
+ items[i].value, items[i].flags),
+ 1, 0, 0, 0, 0, 0);
+ }
+
+ grid = newtCreateGrid(1, 3);
+ form = newtForm(NULL, 0, 0);
+ newtGridSetField(grid, 0, 0, NEWT_GRID_COMPONENT, textw,
+ 0, 0, 0, 0, NEWT_ANCHOR_LEFT, 0);
+ newtGridSetField(grid, 0, 1, NEWT_GRID_SUBGRID, subgrid,
+ 0, 1, 0, 0, 0, 0);
+ newtGridSetField(grid, 0, 2, NEWT_GRID_SUBGRID, buttonBar,
+ 0, 1, 0, 0, 0, NEWT_GRID_FLAG_GROWX);
+ newtGridAddComponentsToForm(grid, form, 1);
+ newtGridWrappedWindow(grid, title);
+ newtGridFree(grid, 1);
+
+ result = newtRunForm(form);
+
+ for (rc = 0; rc < numItems; rc++)
+ *items[rc].value = strdup(*items[rc].value);
+
+ for (rc = 0; result != buttons[rc] && rc < numButtons; rc++);
+ if (rc == numButtons)
+ rc = 0; /* F12 */
+ else
+ rc++;
+
+ newtFormDestroy(form);
+ newtPopWindow();
+
+ return rc;
+}
diff --git a/mdk-stage1/slang/Makefile b/mdk-stage1/slang/Makefile
new file mode 100644
index 000000000..c78ee4668
--- /dev/null
+++ b/mdk-stage1/slang/Makefile
@@ -0,0 +1,48 @@
+ #******************************************************************************
+ #
+ # Guillaume Cottenceau (gc@mandrakesoft.com)
+ #
+ # Copyright 2000 MandrakeSoft
+ #
+ # This software may be freely redistributed under the terms of the GNU
+ # public license.
+ #
+ # 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.
+ #
+ #*****************************************************************************
+
+top_dir = ..
+
+include $(top_dir)/Makefile.common
+
+
+all: libslang.a libslang-DIET.a
+
+clean:
+ rm -f *.o *.a
+
+FLAGS = -Wall -Werror -Os -fomit-frame-pointer -Dunix -DSLANG -c
+
+
+OBJS = sltermin.o sldisply.o slutty.o slang.o slarray.o slclass.o slcmd.o slerr.o slgetkey.o slkeymap.o slmalloc.o slmath.o slmemchr.o slmemcmp.o slmemcpy.o slmemset.o slmisc.o slparse.o slprepr.o slregexp.o slrline.o slsearch.o slsmg.o slstd.o sltoken.o sltypes.o slxstrng.o slcurses.o slscroll.o slsignal.o slkeypad.o slerrno.o slstring.o slstruct.o slcmplex.o slarrfun.o slimport.o slpath.o slarith.o slassoc.o slcompat.o slposdir.o slstdio.o slproc.o sltime.o slstrops.o slbstr.o slpack.o slintall.o slistruc.o slposio.o slnspace.o slarrmis.o slospath.o slscanf.o
+
+OBJS-DIET = $(subst .o,-DIET.o,$(OBJS))
+
+
+libslang.a: $(OBJS)
+ ar -cru $@ $^
+ ranlib $@
+
+libslang-DIET.a: $(OBJS-DIET)
+ ar -cru $@ $^
+ ranlib $@
+
+
+$(OBJS): %.o: %.c
+ gcc $(FLAGS) $(GLIBC_INCLUDES) -c $< -o $@
+
+$(OBJS-DIET): %-DIET.o: %.c
+ gcc $(FLAGS) $(DIETLIBC_INCLUDES) -c $< -o $@
+
diff --git a/mdk-stage1/slang/_slang.h b/mdk-stage1/slang/_slang.h
new file mode 100644
index 000000000..02ee13505
--- /dev/null
+++ b/mdk-stage1/slang/_slang.h
@@ -0,0 +1,743 @@
+#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 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_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_CALL_DIRECT 0x24
+#define _SLANG_BC_CALL_DIRECT_FRAME 0x25
+#define _SLANG_BC_UNARY 0x26
+#define _SLANG_BC_UNARY_FUNC 0x27
+
+#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_LINE_NUM 0x40
+
+#define _SLANG_BC_TMP 0x50
+#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_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
+
+
+/* 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
+{
+ unsigned char data_type; /* SLANG_INT_TYPE, ... */
+ _SL_Object_Union_Type v;
+}
+SLang_Object_Type;
+
+struct _SLang_MMT_Type
+{
+ unsigned char 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 (unsigned char, 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);
+
+extern int _SLang_pop_datatype (unsigned char *);
+extern int _SLang_push_datatype (unsigned char);
+
+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 (unsigned char, VOID_STAR, unsigned int,
+ unsigned char, 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 *_SLRun_Stack;
+extern SLang_Object_Type *_SLStack_Pointer;
+
+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 int _SLang_Trace;
+extern int _SLstack_depth(void);
+extern char *_SLang_Current_Function_Name;
+
+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 unsigned char _SLarith_promote_type (unsigned char);
+extern int _SLarith_get_precedence (unsigned char);
+extern int _SLarith_typecast (unsigned char, VOID_STAR, unsigned int,
+ unsigned char, 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 (unsigned char);
+extern VOID_STAR _SLclass_get_ptr_to_value (SLang_Class_Type *, SLang_Object_Type *);
+extern void _SLclass_type_mismatch_error (unsigned char, unsigned char);
+extern int _SLclass_init (void);
+extern int _SLclass_copy_class (unsigned char, unsigned char);
+
+extern unsigned char _SLclass_Class_Type [256];
+
+extern int (*_SLclass_get_typecast (unsigned char, unsigned char, int))
+(unsigned char, VOID_STAR, unsigned int,
+ unsigned char, VOID_STAR);
+
+extern int (*_SLclass_get_binary_fun (int, SLang_Class_Type *, SLang_Class_Type *, SLang_Class_Type **, int))
+(int,
+ unsigned char, VOID_STAR, unsigned int,
+ unsigned char, VOID_STAR, unsigned int,
+ VOID_STAR);
+
+extern int (*_SLclass_get_unary_fun (int, SLang_Class_Type *, SLang_Class_Type **, int))
+(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR);
+
+extern int _SLarith_register_types (void);
+extern unsigned char _SLarith_Arith_Types [];
+extern unsigned char _SLarith_Is_Arith_Type [256];
+extern int _SLarith_bin_op (SLang_Object_Type *, SLang_Object_Type *, int);
+
+extern int _SLarray_add_bin_op (unsigned char);
+
+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 (unsigned char, VOID_STAR, unsigned int,
+ unsigned char, 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 (unsigned char, unsigned int);
+extern void _SLarray_cl_foreach_close (unsigned char, SLang_Foreach_Context_Type *);
+extern int _SLarray_cl_foreach (unsigned char, SLang_Foreach_Context_Type *);
+
+extern int _SLarray_matrix_multiply (void);
+extern void (*_SLang_Matrix_Multiply)(void);
+
+extern int _SLarray_init_slarray (void);
+extern SLang_Array_Type *
+SLang_create_array1 (unsigned char, int, VOID_STAR, int *, unsigned int, 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
+ unsigned char type;
+}
+_SLang_Token_Type;
+
+extern void _SLcompile (_SLang_Token_Type *);
+extern void (*_SLcompile_ptr)(_SLang_Token_Type *);
+
+/* *** 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 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 IS_LVALUE_TOKEN (((t) <= DOT_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
+
+#undef _INLINE_
+#if defined(__GNUC__) && _SLANG_USE_INLINE_CODE
+# define _INLINE_ __inline__
+#else
+# define _INLINE_
+#endif
+
+
+#endif /* _PRIVATE_SLANG_H_ */
diff --git a/mdk-stage1/slang/config.h b/mdk-stage1/slang/config.h
new file mode 100644
index 000000000..a5ab3273c
--- /dev/null
+++ b/mdk-stage1/slang/config.h
@@ -0,0 +1,163 @@
+/* src/sysconf.h. Generated automatically by configure. */
+/* -*- c -*- */
+/* Note: this is for unix only. */
+
+#ifndef SL_CONFIG_H
+#define SL_CONFIG_H
+
+/* define if you have stdlib.h */
+#define HAVE_STDLIB_H 1
+
+/* define if you have unistd.h */
+#define HAVE_UNISTD_H 1
+
+/* define if you have termios.h */
+#define HAVE_TERMIOS_H 1
+
+/* define if you have memory.h */
+#define HAVE_MEMORY_H 1
+
+/* define if you have malloc.h */
+#define HAVE_MALLOC_H 1
+
+/* define if you have memset */
+#define HAVE_MEMSET 1
+
+/* define if you have memcpy */
+#define HAVE_MEMCPY 1
+
+//#define HAVE_SETLOCALE 1
+//#define HAVE_LOCALE_H 1
+
+#define HAVE_VFSCANF 1
+
+/* define if you have fcntl.h */
+#define HAVE_FCNTL_H 1
+
+/* Define if you have the vsnprintf, snprintf functions and they return
+ * EOF upon failure.
+ */
+#define HAVE_VSNPRINTF 1
+#define HAVE_SNPRINTF 1
+
+/* define if you have sys/fcntl.h */
+#define HAVE_SYS_FCNTL_H 1
+
+#define HAVE_SYS_TYPES_H 1
+#define HAVE_SYS_WAIT_H 1
+#define HAVE_SYS_TIMES_H 1
+
+/* Set these to the appropriate values */
+#define SIZEOF_SHORT 2
+#define SIZEOF_INT 4
+#define SIZEOF_LONG 4
+#define SIZEOF_FLOAT 4
+#define SIZEOF_DOUBLE 8
+
+/* define if you have these. */
+#define HAVE_ATEXIT 1
+#define HAVE_ON_EXIT 1
+#define HAVE_PUTENV 1
+#define HAVE_GETCWD 1
+#define HAVE_TCGETATTR 1
+#define HAVE_TCSETATTR 1
+#define HAVE_CFGETOSPEED 1
+#define HAVE_LSTAT 1
+#define HAVE_KILL 1
+#define HAVE_CHOWN 1
+#define HAVE_VSNPRINTF 1
+#define HAVE_POPEN 1
+#define HAVE_UMASK 1
+#define HAVE_READLINK 1
+#define HAVE_TIMES 1
+#define HAVE_GMTIME 1
+#define HAVE_MKFIFO 1
+
+#define HAVE_GETPPID 1
+#define HAVE_GETGID 1
+#define HAVE_GETEGID 1
+#define HAVE_GETEUID 1
+/* #undef HAVE_GETUID */
+
+#define HAVE_SETGID 1
+#define HAVE_SETPGID 1
+#define HAVE_SETUID 1
+
+#define HAVE_ACOSH 1
+#define HAVE_ASINH 1
+#define HAVE_ATANH 1
+
+#define HAVE_DIRENT_H 1
+/* #undef HAVE_SYS_NDIR_H */
+/* #undef HAVE_SYS_DIR_H */
+/* #undef HAVE_NDIR_H */
+
+#define HAVE_DLFCN_H 1
+
+#define HAVE_SYS_UTSNAME_H 1
+#define HAVE_UNAME 1
+
+/* 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? */
+#define HAVE_SIGACTION 1
+#define HAVE_SIGPROCMASK 1
+#define HAVE_SIGEMPTYSET 1
+#define HAVE_SIGADDSET 1
+
+#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/mdk-stage1/slang/jdmacros.h b/mdk-stage1/slang/jdmacros.h
new file mode 100644
index 000000000..70d491b78
--- /dev/null
+++ b/mdk-stage1/slang/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/mdk-stage1/slang/keywhash.c b/mdk-stage1/slang/keywhash.c
new file mode 100644
index 000000000..17d94d5a3
--- /dev/null
+++ b/mdk-stage1/slang/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 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 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/mdk-stage1/slang/sl-feat.h b/mdk-stage1/slang/sl-feat.h
new file mode 100644
index 000000000..511d72451
--- /dev/null
+++ b/mdk-stage1/slang/sl-feat.h
@@ -0,0 +1,60 @@
+/* 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 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/mdk-stage1/slang/slang.c b/mdk-stage1/slang/slang.c
new file mode 100644
index 000000000..6edc7df37
--- /dev/null
+++ b/mdk-stage1/slang/slang.c
@@ -0,0 +1,5547 @@
+/* -*- mode: C; mode: fold; -*- */
+/* slang.c --- guts of S-Lang interpreter */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#if SLANG_HAS_FLOAT
+# include <math.h>
+#endif
+
+#include "slang.h"
+#include "_slang.h"
+
+#define USE_COMBINED_BYTECODES 0
+
+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;
+
+/* 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; */
+
+SLang_Object_Type *_SLRun_Stack;
+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 *);
+
+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;
+}
+
+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);
+}
+
+_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;
+}
+
+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 == _SLclass_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;
+}
+
+_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 (_SLarith_Is_Arith_Type [type]
+ && _SLarith_Is_Arith_Type [y->data_type]
+ && (_SLarith_Is_Arith_Type [type] >= _SLarith_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 == _SLclass_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 (_SLarith_Is_Arith_Type[a_data_type]
+ && _SLarith_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 == _SLclass_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 == _SLclass_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 != _SLclass_Class_Type [c_data_type])
+#endif
+ (*c_cl->cl_adestroy)(c_data_type, pc);
+
+ 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 != _SLclass_Class_Type [obja.data_type])
+#endif
+ SLang_free_object (&obja);
+ }
+#if _SLANG_OPTIMIZE_FOR_SPEED
+ if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [objb.data_type])
+#endif
+ SLang_free_object (&objb);
+}
+
+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 == _SLclass_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 != _SLclass_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 != _SLclass_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 != _SLclass_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 != _SLclass_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 != _SLclass_Class_Type [y.data_type])
+#endif
+ SLang_free_object (&y);
+
+#if _SLANG_OPTIMIZE_FOR_SPEED
+ if (SLANG_CLASS_TYPE_SCALAR != _SLclass_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 = _SLclass_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) SLang_push_double (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)
+ {
+ 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.
+ */
+ if ((-1 == SLroll_stack (-(Next_Function_Num_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_Function_Num_Args + 1);
+ goto return_error;
+ }
+
+ if (NULL == (foreach_context = (*cl->cl_foreach_open) ((unsigned char)type, Next_Function_Num_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;
+char *_SLang_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 = _SLang_Current_Function_Name;
+ _SLang_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",
+ _SLang_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",
+ _SLang_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)(_SLang_Current_Function_Name);
+
+ if (_SLang_Trace)
+ {
+ int stack_depth;
+
+ stack_depth = _SLstack_depth ();
+
+ if ((Trace_Function != NULL)
+ && (0 == strcmp (Trace_Function, _SLang_Current_Function_Name))
+ && (Trace_Mode == 0))
+ Trace_Mode = 1;
+
+ if (Trace_Mode)
+ {
+ /* The local variable frame grows backwards */
+ trace_dump (">>%s (%d args)\n",
+ _SLang_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",
+ _SLang_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)(_SLang_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 != _SLclass_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;
+ _SLang_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 == _SLclass_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 == _SLclass_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:
+ SLang_push_double (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:
+#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;
+
+ 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;
+#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 SLBlock_Type SLShort_Blocks[6];
+/* These are initialized in add_table below. I cannot init a Union!! */
+
+static int Lang_Defining_Function;
+static void (*Default_Variable_Mode) (_SLang_Token_Type *);
+static void (*Default_Define_Function) (char *, unsigned long);
+
+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:
+ /* 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;
+}
+
+int _SLcompile_push_context (SLang_Load_Type *load_object)
+{
+ if (-1 == push_compile_context (load_object->name))
+ return -1;
+
+ if (NULL == (This_Static_NameSpace = _SLns_allocate_namespace (load_object->name, SLSTATIC_HASH_TABLE_SIZE)))
+ {
+ 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 optimize_block (SLBlock_Type *b)
+{
+ while (1)
+ {
+ switch (b->bc_main_type)
+ {
+ case 0:
+ return;
+
+ default:
+ 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-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LINT;
+ b++;
+ break;
+ case _SLANG_BC_LVARIABLE:
+ (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 == try_compressed_bytecode (_SLANG_BC_LITERAL_INT, bc))
+ return;
+#else
+ (void) bc;
+#endif
+ 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)
+ 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 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 = _SLANG_BC_LITERAL;
+ 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_DOUBLE_TYPE);
+ break;
+#endif
+#if SLANG_HAS_COMPLEX
+ case COMPLEX_TOKEN:
+ compile_double (t->v.s_val, 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[0].bc_main_type = _SLANG_BC_RETURN;
+ SLShort_Blocks[2].bc_main_type = _SLANG_BC_BREAK;
+ SLShort_Blocks[4].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;
+
+ Default_Variable_Mode = compile_public_variable_mode;
+ Default_Define_Function = define_public_function;
+ 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;
+
+ 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
+
+/* 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)
+{
+ if (This_Static_NameSpace == NULL)
+ {
+ SLang_verror (SL_INTRINSIC_ERROR, "No namespace available");
+ return;
+ }
+
+ (void) _SLns_set_namespace_name (This_Static_NameSpace, name);
+
+ Default_Define_Function = define_static_function;
+ Default_Variable_Mode = compile_static_variable_mode;
+}
+
+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;
+ if (Global_NameSpace == ns)
+ {
+ 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;
+ }
+}
+
+
+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;
+}
diff --git a/mdk-stage1/slang/slang.h b/mdk-stage1/slang/slang.h
new file mode 100644
index 000000000..900b14043
--- /dev/null
+++ b/mdk-stage1/slang/slang.h
@@ -0,0 +1,1930 @@
+#ifndef DAVIS_SLANG_H_
+#define DAVIS_SLANG_H_
+/* -*- mode: C; mode: fold; -*- */
+/* Copyright (c) 1992, 1999, 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.
+ */
+#define SLANG_VERSION 10404
+#define SLANG_VERSION_STRING "1.4.4"
+
+/*{{{ 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 <stdio.h>
+#include <stdarg.h>
+#if defined(__STDC__) || defined(__BORLANDC__) || defined(__cplusplus)
+# include <stddef.h> /* 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 <dos.h>
+#endif
+
+#if defined(__BORLANDC__)
+# include <alloc.h>
+#endif
+
+#if defined (__cplusplus) || defined(__STDC__) || defined(IBMPC_SYSTEM)
+ typedef void *VOID_STAR;
+#else
+ typedef unsigned char *VOID_STAR;
+#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 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
+ unsigned char arg_types [SLANG_MAX_INTRIN_ARGS];
+ unsigned char num_args;
+ unsigned char return_type;
+}
+SLang_Intrin_Fun_Type;
+
+typedef struct
+{
+ char *name;
+ SLang_Name_Type *next;
+ char name_type;
+
+ VOID_STAR addr;
+ unsigned char 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;
+ unsigned int offset;
+ unsigned char type;
+ unsigned char read_only;
+}
+SLang_IStruct_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 *);
+
+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.
+ */
+
+ unsigned long reserved[4];
+ /* For future expansion */
+} SLang_Load_Type;
+
+extern SLang_Load_Type *SLallocate_load_type (char *);
+extern void SLdeallocate_load_type (SLang_Load_Type *);
+
+/* 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
+{
+ unsigned char data_type; /* partner type for binary op */
+
+ int (*binary_function)_PROTO((int,
+ unsigned char, VOID_STAR, unsigned int,
+ unsigned char, VOID_STAR, unsigned int,
+ VOID_STAR));
+
+ int (*binary_result) _PROTO((int, unsigned char, unsigned char, unsigned char *));
+ struct SL_OOBinary_Type *next;
+}
+SL_OOBinary_Type;
+
+typedef struct _SL_Typecast_Type
+{
+ unsigned char data_type; /* to_type */
+ int allow_implicit;
+
+ int (*typecast)_PROTO((unsigned char, VOID_STAR, unsigned int,
+ unsigned char, VOID_STAR));
+ struct _SL_Typecast_Type *next;
+}
+SL_Typecast_Type;
+
+typedef struct _SLang_Struct_Type SLang_Struct_Type;
+
+#if defined(SL_APP_WANTS_FOREACH)
+/* It is up to the application to define struct _SLang_Foreach_Context_Type */
+typedef struct _SLang_Foreach_Context_Type SLang_Foreach_Context_Type;
+#else
+typedef int SLang_Foreach_Context_Type;
+#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 (unsigned char 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((unsigned char, VOID_STAR));
+ /* Prototype: void destroy(unsigned type, VOID_STAR val)
+ * Called to delete/free the object */
+
+ char *(*cl_string)_PROTO((unsigned char, VOID_STAR));
+ /* Prototype: char *to_string (unsigned char 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(unsigned char type, VOID_STAR v);
+ * Push a copy of the object of type @type@ at address @v@ onto the
+ * stack.
+ */
+ int (*cl_push)_PROTO((unsigned char, VOID_STAR));
+
+ /* Prototype: int pop(unsigned char type, VOID_STAR v);
+ * Pops value from stack and assign it to object, whose address is @v@.
+ */
+ int (*cl_pop)_PROTO((unsigned char, VOID_STAR));
+
+ int (*cl_unary_op_result_type)_PROTO((int, unsigned char, unsigned char *));
+ int (*cl_unary_op)_PROTO((int, unsigned char, VOID_STAR, unsigned int, VOID_STAR));
+
+ int (*cl_app_unary_op_result_type)_PROTO((int, unsigned char, unsigned char *));
+ int (*cl_app_unary_op)_PROTO((int, unsigned char, 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, unsigned char, VOID_STAR, unsigned int, VOID_STAR));
+ int (*cl_math_op_result_type)_PROTO((int, unsigned char, unsigned char *));
+
+ SL_OOBinary_Type *cl_binary_ops;
+ SL_Typecast_Type *cl_typecast_funs;
+
+ void (*cl_byte_code_destroy)_PROTO((unsigned char, VOID_STAR));
+ void (*cl_user_destroy_fun)_PROTO((unsigned char, VOID_STAR));
+ int (*cl_init_array_object)_PROTO((unsigned char, VOID_STAR));
+ int (*cl_datatype_deref)_PROTO((unsigned char));
+ SLang_Struct_Type *cl_struct_def;
+ int (*cl_dereference) _PROTO((unsigned char, VOID_STAR));
+ int (*cl_acopy) (unsigned char, VOID_STAR, VOID_STAR);
+ int (*cl_apop) _PROTO((unsigned char, VOID_STAR));
+ int (*cl_apush) _PROTO((unsigned char, VOID_STAR));
+ int (*cl_push_literal) _PROTO((unsigned char, VOID_STAR));
+ void (*cl_adestroy)_PROTO((unsigned char, VOID_STAR));
+ int (*cl_push_intrinsic)_PROTO((unsigned char, VOID_STAR));
+ int (*cl_void_typecast)_PROTO((unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR));
+
+ int (*cl_anytype_typecast)_PROTO((unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR));
+
+ /* Array access functions */
+ int (*cl_aput) (unsigned char, unsigned int);
+ int (*cl_aget) (unsigned char, unsigned int);
+ int (*cl_anew) (unsigned char, unsigned int);
+
+ /* length method */
+ int (*cl_length) (unsigned char, VOID_STAR, unsigned int *);
+
+ /* foreach */
+ SLang_Foreach_Context_Type *(*cl_foreach_open) (unsigned char, unsigned int);
+ void (*cl_foreach_close) (unsigned char, SLang_Foreach_Context_Type *);
+ int (*cl_foreach) (unsigned char, SLang_Foreach_Context_Type *);
+
+ /* Structure access: get and put (assign to) fields */
+ int (*cl_sput) (unsigned char, char *);
+ int (*cl_sget) (unsigned char, char *);
+
+ /* File I/O */
+ int (*cl_fread) (unsigned char, FILE *, VOID_STAR, unsigned int, unsigned int *);
+ int (*cl_fwrite) (unsigned char, FILE *, VOID_STAR, unsigned int, unsigned int *);
+ int (*cl_fdread) (unsigned char, int, VOID_STAR, unsigned int, unsigned int *);
+ int (*cl_fdwrite) (unsigned char, int, VOID_STAR, unsigned int, unsigned int *);
+
+ int (*cl_to_bool) (unsigned char, int *);
+
+ int (*cl_cmp)(unsigned char, 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 (unsigned char, double);
+extern int SLclass_push_float_obj (unsigned char, float);
+extern int SLclass_push_long_obj (unsigned char, long);
+extern int SLclass_push_int_obj (unsigned char, int);
+extern int SLclass_push_short_obj (unsigned char, short);
+extern int SLclass_push_char_obj (unsigned char, char);
+extern int SLclass_push_ptr_obj (unsigned char, VOID_STAR);
+extern int SLclass_pop_double_obj (unsigned char, double *);
+extern int SLclass_pop_float_obj (unsigned char, float *);
+extern int SLclass_pop_long_obj (unsigned char, long *);
+extern int SLclass_pop_int_obj (unsigned char, int *);
+extern int SLclass_pop_short_obj (unsigned char, short *);
+extern int SLclass_pop_char_obj (unsigned char, char *);
+extern int SLclass_pop_ptr_obj (unsigned char, 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 *, unsigned char);
+extern int SLclass_is_class_defined (unsigned char);
+
+extern int SLclass_register_class (SLang_Class_Type *, unsigned char, unsigned int, unsigned char);
+extern int SLclass_set_string_function (SLang_Class_Type *, char *(*)(unsigned char, VOID_STAR));
+extern int SLclass_set_destroy_function (SLang_Class_Type *, void (*)(unsigned char, VOID_STAR));
+extern int SLclass_set_push_function (SLang_Class_Type *, int (*)(unsigned char, VOID_STAR));
+extern int SLclass_set_pop_function (SLang_Class_Type *, int (*)(unsigned char, VOID_STAR));
+
+extern int SLclass_set_aget_function (SLang_Class_Type *, int (*)(unsigned char, unsigned int));
+extern int SLclass_set_aput_function (SLang_Class_Type *, int (*)(unsigned char, unsigned int));
+extern int SLclass_set_anew_function (SLang_Class_Type *, int (*)(unsigned char, unsigned int));
+
+extern int SLclass_set_sget_function (SLang_Class_Type *, int (*)(unsigned char, char *));
+extern int SLclass_set_sput_function (SLang_Class_Type *, int (*)(unsigned char, char *));
+
+/* Typecast object on the stack to type p1. p2 and p3 should be set to 1 */
+extern int SLclass_typecast (unsigned char, int, int);
+
+extern int SLclass_add_unary_op (unsigned char,
+ int (*) (int,
+ unsigned char, VOID_STAR, unsigned int,
+ VOID_STAR),
+ int (*) (int, unsigned char, unsigned char *));
+
+extern int
+SLclass_add_app_unary_op (unsigned char,
+ int (*) (int,
+ unsigned char, VOID_STAR, unsigned int,
+ VOID_STAR),
+ int (*) (int, unsigned char, unsigned char *));
+
+extern 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 *));
+
+extern int
+SLclass_add_math_op (unsigned char,
+ int (*)(int,
+ unsigned char, VOID_STAR, unsigned int,
+ VOID_STAR),
+ int (*)(int, unsigned char, unsigned char *));
+
+extern int
+SLclass_add_typecast (unsigned char /* from */, unsigned char /* to */,
+ int (*)_PROTO((unsigned char, VOID_STAR, unsigned int,
+ unsigned char, VOID_STAR)),
+ int /* allow implicit typecasts */
+ );
+
+extern char *SLclass_get_datatype_name (unsigned char);
+
+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 (unsigned char, VOID_STAR);
+extern int SLang_push_mmt (SLang_MMT_Type *);
+extern SLang_MMT_Type *SLang_pop_mmt (unsigned char);
+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
+{
+ unsigned char 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;
+}
+SLang_Array_Type;
+
+extern int SLang_pop_array_of_type (SLang_Array_Type **, unsigned char);
+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 (unsigned char, 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);
+
+
+/*}}}*/
+
+/*{{{ 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 *, ...);
+
+ 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 *, ...);
+ 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... */
+
+/* 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_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 (unsigned char *);
+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 (unsigned char);
+
+ 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 (unsigned char type, VOID_STAR);
+extern int SLang_pop_value (unsigned char type, VOID_STAR);
+extern void SLang_free_value (unsigned char 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 *, unsigned char, 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);
+
+ 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 *, ...);
+
+extern void SLang_doerror(char *);
+ /* set SLang_Error and display p1 as error message */
+
+extern int SLang_add_intrinsic_array (char *, /* name */
+ unsigned char, /* 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 **,
+ unsigned char *,
+ 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 (unsigned char, 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. This routine calls define_key1.
+ */
+
+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
+}
+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 *, ...);
+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);
+
+/* This function uses SLang_getkey and assumes that what ever initialization
+ * is required for SLang_getkey has been performed.
+ */
+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
+
+/* 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,...);
+
+extern void SLadd_at_handler (long *, char *);
+
+#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 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}
+
+
+
+/*}}}*/
+
+/*{{{ 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 *);
+
+/* 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/mdk-stage1/slang/slarith.c b/mdk-stage1/slang/slarith.c
new file mode 100644
index 000000000..07ad68687
--- /dev/null
+++ b/mdk-stage1/slang/slarith.c
@@ -0,0 +1,1656 @@
+
+/* Copyright (c) 1998, 1999, 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 "slinclud.h"
+
+#include <math.h>
+
+#ifdef HAVE_LOCALE_H
+# include <locale.h>
+#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_Is_Arith_Type [256];
+
+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
+DEFUN_1(copy_char_to_float,char,float)
+DEFUN_1(copy_char_to_double,char,double)
+
+#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
+DEFUN_1(copy_uchar_to_float,unsigned char,float)
+DEFUN_1(copy_uchar_to_double,unsigned char,double)
+
+#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)
+DEFUN_1(copy_short_to_float,short,float)
+DEFUN_1(copy_short_to_double,short,double)
+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)
+DEFUN_1(copy_ushort_to_float,unsigned short,float)
+DEFUN_1(copy_ushort_to_double,unsigned short,double)
+#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
+# define copy_short_to_float copy_int_to_float
+# define copy_short_to_double copy_int_to_double
+# 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
+# define copy_ushort_to_float copy_uint_to_float
+# define copy_ushort_to_double copy_uint_to_double
+#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
+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)
+
+#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_long_to_float,long,float)
+DEFUN_1(copy_long_to_double,long,double)
+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)
+DEFUN_1(copy_ulong_to_float,unsigned long,float)
+DEFUN_1(copy_ulong_to_double,unsigned long,double)
+#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
+
+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)
+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)
+
+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
+DEFUN_2(char_to_float,char,float,copy_char_to_float)
+DEFUN_2(char_to_double,char,double,copy_char_to_double)
+
+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
+DEFUN_2(uchar_to_float,unsigned char,float,copy_uchar_to_float)
+DEFUN_2(uchar_to_double,unsigned char,double,copy_uchar_to_double)
+
+#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)
+DEFUN_2(short_to_float,short,float,copy_short_to_float)
+DEFUN_2(short_to_double,short,double,copy_short_to_double)
+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)
+DEFUN_2(ushort_to_float,unsigned short,float,copy_ushort_to_float)
+DEFUN_2(ushort_to_double,unsigned short,double,copy_ushort_to_double)
+#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
+# define short_to_float int_to_float
+# define short_to_double int_to_double
+# define ushort_to_int NULL
+# define ushort_to_uint NULL
+# define ushort_to_long uint_to_long
+# define ushort_to_ulong uint_to_ulong
+# define ushort_to_float uint_to_float
+# define ushort_to_double uint_to_double
+#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
+DEFUN_2(int_to_float,int,float,copy_int_to_float)
+DEFUN_2(int_to_double,int,double,copy_int_to_double)
+
+#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
+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;
+}
+
+/* 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},
+ {(FVOID_STAR) copy_char_to_float, char_to_float},
+ {(FVOID_STAR) copy_char_to_double, char_to_double},
+ },
+
+ {
+ {(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},
+ {(FVOID_STAR) copy_uchar_to_float, uchar_to_float},
+ {(FVOID_STAR) copy_uchar_to_double, uchar_to_double},
+ },
+
+ {
+ {(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},
+ {(FVOID_STAR) copy_short_to_float, short_to_float},
+ {(FVOID_STAR) copy_short_to_double, short_to_double},
+ },
+
+ {
+ {(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},
+ {(FVOID_STAR) copy_ushort_to_float, ushort_to_float},
+ {(FVOID_STAR) copy_ushort_to_double, ushort_to_double},
+ },
+
+ {
+ {(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},
+ {(FVOID_STAR) copy_int_to_float, int_to_float},
+ {(FVOID_STAR) copy_int_to_double, int_to_double},
+ },
+
+ {
+ {(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},
+ {(FVOID_STAR) copy_uint_to_float, uint_to_float},
+ {(FVOID_STAR) copy_uint_to_double, uint_to_double},
+ },
+
+ {
+ {(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},
+ {(FVOID_STAR) copy_long_to_float, long_to_float},
+ {(FVOID_STAR) copy_long_to_double, long_to_double},
+ },
+
+ {
+ {(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},
+ {(FVOID_STAR) copy_ulong_to_float, ulong_to_float},
+ {(FVOID_STAR) copy_ulong_to_double, ulong_to_double},
+ },
+
+ {
+ {(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},
+ }
+};
+
+#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))
+#define SCALAR_BINARY_FUNCTION int_int_scalar_bin_op
+#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)
+#define SCALAR_BINARY_FUNCTION uint_uint_scalar_bin_op
+#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))
+#define SCALAR_BINARY_FUNCTION long_long_scalar_bin_op
+#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)
+#define SCALAR_BINARY_FUNCTION ulong_ulong_scalar_bin_op
+#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 */
+
+#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))
+#define SCALAR_BINARY_FUNCTION float_float_scalar_bin_op
+#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))
+#define SCALAR_BINARY_FUNCTION double_double_scalar_bin_op
+#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"
+
+#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 */
+ 9, /* SLANG_DOUBLE_TYPE */
+ 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 */
+ 8 /* SLANG_FLOAT_TYPE */
+};
+
+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;
+
+ 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;
+
+ 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,
+ float_float_bin_op,
+ double_double_bin_op
+};
+
+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 = (int) obj.v.long_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 (unsigned char unused, VOID_STAR ptr)
+{
+ (void) unused;
+ SLang_push_double (*(double *) ptr);
+ return 0;
+}
+
+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);
+}
+
+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;
+
+ _SLarith_Is_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;
+ _SLarith_Is_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;
+ _SLarith_Is_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 ((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);
+
+ /* 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
+ 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);
+ }
+
+ return 1;
+}
+#endif
diff --git a/mdk-stage1/slang/slarith.inc b/mdk-stage1/slang/slarith.inc
new file mode 100644
index 000000000..efa8a5e04
--- /dev/null
+++ b/mdk-stage1/slang/slarith.inc
@@ -0,0 +1,783 @@
+/* -*- 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;
+
+#ifdef POW_FUNCTION
+ case SLANG_POW:
+ return PUSH_POW_OBJ_FUN(POW_FUNCTION(a, b));
+#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/mdk-stage1/slang/slarray.c b/mdk-stage1/slang/slarray.c
new file mode 100644
index 000000000..0b9a1406c
--- /dev/null
+++ b/mdk-stage1/slang/slarray.c
@@ -0,0 +1,3139 @@
+/* Array manipulation routines for S-Lang */
+/* Copyright (c) 1997, 1999, 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 "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);
+}
+
+static int 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 == next_index (dims, max_dims, num_dims));
+
+ return 0;
+}
+
+void SLang_free_array (SLang_Array_Type *at)
+{
+ VOID_STAR data;
+ unsigned int flags;
+
+ if (at == NULL) return;
+
+ if (at->num_refs > 1)
+ {
+ at->num_refs -= 1;
+ return;
+ }
+
+ data = at->data;
+ 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);
+
+ SLfree ((char *) 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_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)
+ {
+ if ((num_indices == 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.
+ */
+ 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 == 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 (index_objs, num_indices, &is_index_array))
+ {
+ SLang_free_array (at);
+ return -1;
+ }
+
+ if (is_index_array == 0)
+ 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 2-d array of indices. The 2-d 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;
+
+ 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;
+ SLang_Array_Type *at;
+
+ *at_ptr = NULL;
+
+ data_type = cl->cl_data_type;
+ if (-1 == SLclass_typecast (data_type, 1, allow_array))
+ return -1;
+
+ 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 == 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;
+
+ 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 (index_objs, num_indices, &is_index_array))
+ {
+ SLang_free_array (at);
+ return -1;
+ }
+
+ if (is_index_array == 0)
+ 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;
+
+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
+ {
+ sort_fun = builtin_sort_cmp_fun;
+ if (-1 == SLang_pop_array (&at, 1))
+ return;
+ 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];
+#endif
+ int has_vals[3];
+ unsigned int i, count;
+ SLang_Array_Type *at;
+ int precedence;
+ unsigned char type;
+ int is_int;
+
+ 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;
+ double_vals[i] = (double) int_vals[i];
+ }
+ }
+
+#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 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.
+ */
+ 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;
+ }
+
+ 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;
+ unsigned char type, this_type;
+ unsigned int count;
+ SLang_Array_Type *at;
+
+ obj = _SLStack_Pointer;
+
+ count = SLang_Num_Function_Args;
+ type = 0;
+
+ while ((count > 0) && (--obj >= _SLRun_Stack))
+ {
+ 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;
+
+ case SLANG_INT_TYPE:
+ switch (type)
+ {
+#if SLANG_HAS_FLOAT
+ case SLANG_DOUBLE_TYPE:
+ break;
+#endif
+#if SLANG_HAS_COMPLEX
+ case SLANG_COMPLEX_TYPE:
+ break;
+#endif
+ default:
+ goto type_mismatch;
+ }
+ break;
+#if SLANG_HAS_FLOAT
+ case SLANG_DOUBLE_TYPE:
+ switch (type)
+ {
+ case SLANG_INT_TYPE:
+ type = SLANG_DOUBLE_TYPE;
+ break;
+# if SLANG_HAS_COMPLEX
+ case SLANG_COMPLEX_TYPE:
+ break;
+# endif
+ default:
+ goto type_mismatch;
+ }
+ break;
+#endif
+#if SLANG_HAS_COMPLEX
+ case SLANG_COMPLEX_TYPE:
+ switch (type)
+ {
+ case SLANG_INT_TYPE:
+ case SLANG_DOUBLE_TYPE:
+ type = SLANG_COMPLEX_TYPE;
+ break;
+
+ default:
+ goto type_mismatch;
+ }
+ break;
+#endif
+ default:
+ type_mismatch:
+ _SLclass_type_mismatch_error (type, this_type);
+ return -1;
+ }
+ 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);
+}
+
+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 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 */
+
+ 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("array_info", array_info, SLANG_VOID_TYPE, 0),
+ MAKE_INTRINSIC("where", array_where, SLANG_VOID_TYPE, 0),
+ 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))
+ || (-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 (unsigned char 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 (unsigned char type, SLang_Foreach_Context_Type *c)
+{
+ (void) type;
+ if (c == NULL) return;
+ SLang_free_array (c->at);
+ SLfree ((char *) c);
+}
+
+int _SLarray_cl_foreach (unsigned char 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/mdk-stage1/slang/slarrfun.c b/mdk-stage1/slang/slarrfun.c
new file mode 100644
index 000000000..bfa6ec5e5
--- /dev/null
+++ b/mdk-stage1/slang/slarrfun.c
@@ -0,0 +1,464 @@
+/* Advanced array manipulation routines for S-Lang */
+/* Copyright (c) 1998, 1999, 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 "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;
+}
+
+#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
+#include "slarrfun.inc"
+
+#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
+#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
+#define GENERIC_TYPE int
+#define TRANSPOSE_2D_ARRAY transpose_ints
+#include "slarrfun.inc"
+
+#if SIZEOF_LONG != SIZEOF_INT
+# define GENERIC_TYPE long
+# define TRANSPOSE_2D_ARRAY transpose_longs
+# include "slarrfun.inc"
+#else
+# define transpose_longs transpose_ints
+#endif
+
+#if SIZEOF_SHORT != SIZEOF_INT
+# define GENERIC_TYPE short
+# define TRANSPOSE_2D_ARRAY transpose_shorts
+# include "slarrfun.inc"
+#else
+# define transpose_shorts transpose_ints
+#endif
+
+#define GENERIC_TYPE char
+#define TRANSPOSE_2D_ARRAY transpose_chars
+#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);
+ case SLANG_DOUBLE_TYPE:
+ return transpose_doubles (at, bt);
+ case SLANG_FLOAT_TYPE:
+ return transpose_floats (at, bt);
+ 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);
+}
+
+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 exceed max 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);
+}
+
+
+
+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
+};
+
+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;
+}
+
diff --git a/mdk-stage1/slang/slarrfun.inc b/mdk-stage1/slang/slarrfun.inc
new file mode 100644
index 000000000..348473a6f
--- /dev/null
+++ b/mdk-stage1/slang/slarrfun.inc
@@ -0,0 +1,257 @@
+/* -*- 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 GENERIC_TYPE
+# undef GENERIC_TYPE
+#endif
diff --git a/mdk-stage1/slang/slarrmis.c b/mdk-stage1/slang/slarrmis.c
new file mode 100644
index 000000000..330dcb53f
--- /dev/null
+++ b/mdk-stage1/slang/slarrmis.c
@@ -0,0 +1,38 @@
+/* Misc Array Functions */
+/* Copyright (c) 1997, 1999, 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 "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/mdk-stage1/slang/slassoc.c b/mdk-stage1/slang/slassoc.c
new file mode 100644
index 000000000..5997458d2
--- /dev/null
+++ b/mdk-stage1/slang/slassoc.c
@@ -0,0 +1,713 @@
+/* Copyright (c) 1998, 1999, 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 "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;
+}
+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 (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;
+}
+
+static int assoc_aget (unsigned char 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 (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type[obj->data_type])
+ ret = SLang_push (obj);
+#endif
+ else
+ ret = _SLpush_slang_obj (obj);
+ }
+
+ SLang_free_slstring (str);
+ SLang_free_mmt (mmt);
+ return ret;
+}
+
+static int assoc_aput (unsigned char 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 i, 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;
+
+ i = 0;
+ 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;
+ i++;
+ }
+ }
+ (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;
+};
+
+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);
+
+ 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)
+ && (-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, assoc_aput);
+ (void) SLclass_set_aget_function (cl, assoc_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/mdk-stage1/slang/slbstr.c b/mdk-stage1/slang/slbstr.c
new file mode 100644
index 000000000..b4b8c4c51
--- /dev/null
+++ b/mdk-stage1/slang/slbstr.c
@@ -0,0 +1,615 @@
+/* Copyright (c) 1998, 1999, 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 "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_BSTRING_TYPE, SLANG_BSTRING_TYPE, bstring_bstring_bin_op, bstring_bstring_bin_op_result))
+ || (-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)))
+
+ return -1;
+
+ if (-1 == SLadd_intrin_fun_table (BString_Table, NULL))
+ return -1;
+
+ return 0;
+}
+
diff --git a/mdk-stage1/slang/slclass.c b/mdk-stage1/slang/slclass.c
new file mode 100644
index 000000000..733888cb8
--- /dev/null
+++ b/mdk-stage1/slang/slclass.c
@@ -0,0 +1,1391 @@
+/* User defined objects */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#include "slang.h"
+#include "_slang.h"
+
+#if _SLANG_OPTIMIZE_FOR_SPEED
+unsigned char _SLclass_Class_Type [256];
+#endif
+
+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 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)
+ _SLclass_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 = 0; i < 256; i++)
+ {
+ if ((Registered_Types[i] == NULL)
+ && (i != SLANG_VOID_TYPE))
+ {
+ 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;
+
+ 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;
+ 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)
+ _SLclass_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)(unsigned char, VOID_STAR))
+{
+ if (cl == NULL) return -1;
+ cl->cl_push = 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 "??";
+ 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)
+ {
+ if (-1 == (*cl_to->cl_apush)(to_type, bp))
+ {
+ (*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_double_obj (unsigned char type, double x)
+{
+ SLang_Object_Type obj;
+ obj.data_type = type;
+ obj.v.double_val = x;
+ return SLang_push (&obj);
+}
+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/mdk-stage1/slang/slcmd.c b/mdk-stage1/slang/slcmd.c
new file mode 100644
index 000000000..4a00a90fc
--- /dev/null
+++ b/mdk-stage1/slang/slcmd.c
@@ -0,0 +1,351 @@
+/* cmd line facility for slang */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#if SLANG_HAS_FLOAT
+# include <math.h>
+#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, *b = NULL, *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)
+ {
+ 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/mdk-stage1/slang/slcmplex.c b/mdk-stage1/slang/slcmplex.c
new file mode 100644
index 000000000..b210dfc04
--- /dev/null
+++ b/mdk-stage1/slang/slcmplex.c
@@ -0,0 +1,1142 @@
+/* Complex Data Type definition for S-Lang */
+/* Copyright (c) 1997, 1999, 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 "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 <math.h>
+#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/mdk-stage1/slang/slcompat.c b/mdk-stage1/slang/slcompat.c
new file mode 100644
index 000000000..5aa122483
--- /dev/null
+++ b/mdk-stage1/slang/slcompat.c
@@ -0,0 +1,34 @@
+/* These functions are provided for backward compatibility and are obsolete.
+ * Copyright (c) 1992, 1999, 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 "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/mdk-stage1/slang/slcurses.c b/mdk-stage1/slang/slcurses.c
new file mode 100644
index 000000000..f1212afc8
--- /dev/null
+++ b/mdk-stage1/slang/slcurses.c
@@ -0,0 +1,972 @@
+/* Copyright (c) 1998, 1999, 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 "slinclud.h"
+
+#include <signal.h>
+#include <errno.h>
+
+#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;
+}
+
+int SLcurses_wgetch (SLcurses_Window_Type *w)
+{
+ if (w == NULL)
+ return ERR;
+
+ SLcurses_wrefresh (w);
+
+ if ((w->delay_off == -1) ||
+ SLang_input_pending (w->delay_off))
+ {
+ if (w->use_keypad)
+ {
+ int ch = SLang_getkey ();
+ if (ch == '\033')
+ {
+ if (0 == SLang_input_pending (ESCDELAY / 100))
+ return ch;
+ }
+ else if (ch == 0xFFFF) return ERR;
+ SLang_ungetkey (ch);
+ return SLkp_getkey ();
+ }
+ 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;
+ }
+
+#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/mdk-stage1/slang/slcurses.h b/mdk-stage1/slang/slcurses.h
new file mode 100644
index 000000000..fa082304f
--- /dev/null
+++ b/mdk-stage1/slang/slcurses.h
@@ -0,0 +1,353 @@
+/* Copyright (c) 1998, 1999, 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 <stdio.h>
+
+#ifndef SLANG_VERSION
+# include <slang.h>
+#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)
+#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/mdk-stage1/slang/sldisply.c b/mdk-stage1/slang/sldisply.c
new file mode 100644
index 000000000..1e1161774
--- /dev/null
+++ b/mdk-stage1/slang/sldisply.c
@@ -0,0 +1,2596 @@
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#include <time.h>
+#include <ctype.h>
+
+#if !defined(VMS) || (__VMS_VER >= 70000000)
+# include <sys/time.h>
+# ifdef __QNX__
+# include <sys/select.h>
+# endif
+# include <sys/types.h>
+#endif
+
+#ifdef __BEOS__
+/* Prototype for select */
+# include <net/socket.h>
+#endif
+
+#ifdef HAVE_TERMIOS_H
+# include <termios.h>
+#endif
+
+#ifdef VMS
+# include <unixlib.h>
+# include <unixio.h>
+# include <dvidef.h>
+# include <descrip.h>
+# include <lib$routines.h>
+# include <starlet.h>
+#else
+# if !defined(sun)
+# include <sys/ioctl.h>
+# endif
+#endif
+
+#ifdef SYSV
+# include <sys/termio.h>
+# include <sys/stream.h>
+# include <sys/ptem.h>
+# include <sys/tty.h>
+#endif
+
+#if defined (_AIX) && !defined (FD_SET)
+# include <sys/select.h> /* for FD_ISSET, FD_SET, FD_ZERO */
+#endif
+
+#include <errno.h>
+
+#if defined(__DECC) && defined(VMS)
+/* These get prototypes for write an sleep */
+# include <unixio.h>
+#endif
+#include <signal.h>
+
+#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}
+};
+
+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();
+}
+
+/* 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 del_eol (void)
+{
+ int c;
+
+ if (Del_Eol_Str != NULL)
+ {
+ tt_write_string(Del_Eol_Str);
+ return;
+ }
+
+ 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 for for a space into that corner.
+ */
+ if (Cursor_r + 1 < SLtt_Screen_Rows)
+ c++;
+
+ while (c < SLtt_Screen_Cols)
+ {
+ tt_write (" ", 1);
+ c++;
+ }
+}
+
+void SLtt_del_eol (void)
+{
+ if (Current_Fgbg != 0xFFFFFFFFU) SLtt_normal_video ();
+ del_eol ();
+}
+
+typedef 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;
+ char *s = color;
+
+ i = 0;
+ while ((ich = (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 spplication 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 paramter 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)
+ {
+ ch = (unsigned char) *color++;
+ if (ch == 0)
+ break;
+ if ((ch > '9') || (ch < '0'))
+ return -1;
+ i = 10 * i + (ch - '0');
+ }
+
+ *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;
+ 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, fg0, 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, bg0, 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
+
+#if SLTT_HAS_NON_BCE_SUPPORT
+static int bce_color_eqs (unsigned int a, unsigned int b)
+{
+ a = (a & COLOR_MASK) >> 8;
+ b = (b & COLOR_MASK) >> 8;
+
+ 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_OF(x) (((unsigned int)(x) & COLOR_MASK) >> 8)
+# 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))\
+ || ((((a) & ~COLOR_MASK) == ((b) & ~COLOR_MASK))\
+ && 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[256], 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 & BGALL_MASK) != (Current_Fgbg & BGALL_MASK))
+ {
+ 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 (n <= 4)
+ {
+ SLtt_normal_video ();
+ 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));
+}
+
+
+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[256];
+ 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
+
+ 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 ((*(pmax-1) & 0xFF) == ' ')
+ {
+ /* 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) && ((*neww & 0xFF) == 32))
+ {
+ 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 = 32;
+
+ 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 (blank >> 8);
+ 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, 32) && CHAR_EQS(*p, 32))
+ {
+ /* 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, 32)
+ && CHAR_EQS(*p, 32))
+ {
+ 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;
+
+ if (buf != buffer) send_attr_str (buffer);
+ buf = buffer;
+
+ if (n_spaces
+ && ((p < pmax) /* erase to eol will achieve this effect*/
+ || (space_char != 32)))/* 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.
+ */
+#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;
+ }
+ }
+
+ 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 (space_char >> 8);
+ 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 *s)
+{
+ if (Termcap_Initalized == 0)
+ return NULL;
+
+#ifdef USE_TERMCAP
+ s = tgetstr (s, &Termcap_String_Ptr);
+#else
+ s = _SLtt_tigetstr (Terminfo, s);
+#endif
+ 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;
+ }
+
+ 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);
+ 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_Bol_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");
+ Color_Fg_Str = SLtt_tgetstr ("AF"); /* ANSI setaf */
+ Color_Bg_Str = SLtt_tgetstr ("AB"); /* ANSI setbf */
+ if ((Color_Fg_Str == NULL) || (Color_Bg_Str == NULL))
+ {
+ Color_Fg_Str = SLtt_tgetstr ("Sf"); /* setf */
+ Color_Bg_Str = SLtt_tgetstr ("Sb"); /* setb */
+ }
+
+ 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;
+
+ 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 = 24;
+ if (c <= 0) c = 80;
+#if 0
+ if ((r <= 0) || (r > 200)) r = 24;
+ if ((c <= 0) || (c > 250)) c = 80;
+#endif
+ 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/mdk-stage1/slang/slerr.c b/mdk-stage1/slang/slerr.c
new file mode 100644
index 000000000..139b3859b
--- /dev/null
+++ b/mdk-stage1/slang/slerr.c
@@ -0,0 +1,181 @@
+/* error handling common to all routines. */
+/* Copyright (c) 1992, 1999, 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 "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/mdk-stage1/slang/slerrno.c b/mdk-stage1/slang/slerrno.c
new file mode 100644
index 000000000..662fadde1
--- /dev/null
+++ b/mdk-stage1/slang/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 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 <errno.h>
+#include "slang.h"
+#include "_slang.h"
+
+typedef 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/mdk-stage1/slang/slgetkey.c b/mdk-stage1/slang/slgetkey.c
new file mode 100644
index 000000000..2f2914f07
--- /dev/null
+++ b/mdk-stage1/slang/slgetkey.c
@@ -0,0 +1,306 @@
+/* Copyright (c) 1992, 1999, 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 "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/mdk-stage1/slang/slimport.c b/mdk-stage1/slang/slimport.c
new file mode 100644
index 000000000..44b4b25e1
--- /dev/null
+++ b/mdk-stage1/slang/slimport.c
@@ -0,0 +1,281 @@
+/* Copyright (c) 1998, 1999, 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 "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 <dlfcn.h>
+#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;
+
+ if (NULL != find_handle (name))
+ return 0; /* already loaded */
+
+ 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)
+ break;
+
+ if (NULL == strchr (file, '/'))
+ {
+ _SLsnprintf (filebuf, sizeof (filebuf), "./%s", file);
+ file = filebuf;
+ continue;
+ }
+
+ if (NULL == (err = (char *) dlerror ()))
+ err = "UNKNOWN";
+
+ SLang_verror (SL_INTRINSIC_ERROR,
+ "Error linking to %s: %s", file, err);
+ return -1;
+ }
+
+ fun_name = ns_init_fun_name;
+ ns_init_fun = (int (*)(char *)) dlsym (handle, fun_name);
+ if (ns_init_fun == NULL)
+ {
+ if ((ns != NULL)
+ && (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)
+{
+ char module_name[256];
+ char symbol_name[256];
+ char deinit_name[256];
+ char ns_init_name[256];
+ 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;
+ }
+
+ _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 = 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 = 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/mdk-stage1/slang/slinclud.h b/mdk-stage1/slang/slinclud.h
new file mode 100644
index 000000000..d60a4423e
--- /dev/null
+++ b/mdk-stage1/slang/slinclud.h
@@ -0,0 +1,26 @@
+#ifndef _SLANG_INCLUDE_H_
+#define _SLANG_INCLUDE_H_
+
+#include "config.h"
+#include "sl-feat.h"
+
+#include <stdio.h>
+#include <string.h>
+
+#ifdef HAVE_STDLIB_H
+# include <stdlib.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+
+#ifdef HAVE_MALLOC_H
+# include <malloc.h>
+#endif
+
+#ifdef HAVE_MEMORY_H
+# include <memory.h>
+#endif
+
+#endif /* _SLANG_INCLUDE_H_ */
diff --git a/mdk-stage1/slang/slintall.c b/mdk-stage1/slang/slintall.c
new file mode 100644
index 000000000..a66b9d6d2
--- /dev/null
+++ b/mdk-stage1/slang/slintall.c
@@ -0,0 +1,27 @@
+/* Copyright (c) 1998, 1999, 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 "slinclud.h"
+
+#include "slang.h"
+#include "_slang.h"
+
+int SLang_init_all (void)
+{
+ if ((-1 == SLang_init_slang ())
+ || (-1 == SLang_init_slmath ())
+ || (-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/mdk-stage1/slang/slistruc.c b/mdk-stage1/slang/slistruc.c
new file mode 100644
index 000000000..06b8fd6ff
--- /dev/null
+++ b/mdk-stage1/slang/slistruc.c
@@ -0,0 +1,218 @@
+/* Intrinsic Structure type implementation */
+/* Copyright (c) 1998, 1999, 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 "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 SLadd_istruct_table (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 == SLadd_intrinsic_variable (name, (VOID_STAR) s, SLANG_ISTRUCT_TYPE, 1))
+ {
+ SLang_free_slstring (s->name);
+ SLfree ((char *) s);
+ return -1;
+ }
+
+ return 0;
+}
diff --git a/mdk-stage1/slang/slkeymap.c b/mdk-stage1/slang/slkeymap.c
new file mode 100644
index 000000000..dff65433e
--- /dev/null
+++ b/mdk-stage1/slang/slkeymap.c
@@ -0,0 +1,596 @@
+/* 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 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, chlow;
+ 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 */
+ chlow = LOWER_CASE_KEY(input_ch);
+ if (input_ch == chlow)
+ 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); chlow = LOWER_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/mdk-stage1/slang/slkeypad.c b/mdk-stage1/slang/slkeypad.c
new file mode 100644
index 000000000..524dc80fa
--- /dev/null
+++ b/mdk-stage1/slang/slkeypad.c
@@ -0,0 +1,163 @@
+/* Copyright (c) 1998, 1999, 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 "slinclud.h"
+
+#include "slang.h"
+#include "_slang.h"
+
+static SLKeyMap_List_Type *Keymap_List;
+
+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[2~", SL_KEY_IC, Keymap_List);
+ SLkm_define_keysym ("\033[7~", SL_KEY_HOME, 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[8~", SL_KEY_END, Keymap_List);
+ SLkm_define_keysym ("\033[3~", SL_KEY_DELETE, 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 ("^(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;
+
+ key = SLang_do_key (Keymap_List, (int (*)(void)) SLang_getkey);
+ 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;
+}
+
+#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/mdk-stage1/slang/sllimits.h b/mdk-stage1/slang/sllimits.h
new file mode 100644
index 000000000..c4ae03b83
--- /dev/null
+++ b/mdk-stage1/slang/sllimits.h
@@ -0,0 +1,64 @@
+/* Copyright (c) 1998, 1999, 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.
+ */
+/* 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 250
+#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 1024
+#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
diff --git a/mdk-stage1/slang/slmalloc.c b/mdk-stage1/slang/slmalloc.c
new file mode 100644
index 000000000..914e1e0ef
--- /dev/null
+++ b/mdk-stage1/slang/slmalloc.c
@@ -0,0 +1,165 @@
+/* Copyright (c) 1992, 1999, 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 "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/mdk-stage1/slang/slmath.c b/mdk-stage1/slang/slmath.c
new file mode 100644
index 000000000..1d61e14d3
--- /dev/null
+++ b/mdk-stage1/slang/slmath.c
@@ -0,0 +1,565 @@
+/* sin, cos, etc, for S-Lang */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#include <math.h>
+
+#include "slang.h"
+#include "_slang.h"
+
+#ifdef PI
+# undef PI
+#endif
+#define PI 3.14159265358979323846264338327950288
+
+#if defined(__unix__)
+#include <signal.h>
+#include <errno.h>
+
+#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
+
+ 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;
+}
+
diff --git a/mdk-stage1/slang/slmemchr.c b/mdk-stage1/slang/slmemchr.c
new file mode 100644
index 000000000..1417bc549
--- /dev/null
+++ b/mdk-stage1/slang/slmemchr.c
@@ -0,0 +1,47 @@
+/* Copyright (c) 1992, 1999, 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.
+ */
+
+/* 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/mdk-stage1/slang/slmemcmp.c b/mdk-stage1/slang/slmemcmp.c
new file mode 100644
index 000000000..c5ed50095
--- /dev/null
+++ b/mdk-stage1/slang/slmemcmp.c
@@ -0,0 +1,76 @@
+/* Copyright (c) 1992, 1999, 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.
+ */
+
+/* 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/mdk-stage1/slang/slmemcpy.c b/mdk-stage1/slang/slmemcpy.c
new file mode 100644
index 000000000..e8665e4c6
--- /dev/null
+++ b/mdk-stage1/slang/slmemcpy.c
@@ -0,0 +1,49 @@
+/* Copyright (c) 1992, 1999, 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.
+ */
+
+/* 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/mdk-stage1/slang/slmemset.c b/mdk-stage1/slang/slmemset.c
new file mode 100644
index 000000000..3851663c5
--- /dev/null
+++ b/mdk-stage1/slang/slmemset.c
@@ -0,0 +1,39 @@
+/* Copyright (c) 1992, 1999, 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.
+ */
+
+/* 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/mdk-stage1/slang/slmisc.c b/mdk-stage1/slang/slmisc.c
new file mode 100644
index 000000000..ccc7a9bdf
--- /dev/null
+++ b/mdk-stage1/slang/slmisc.c
@@ -0,0 +1,330 @@
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#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;
+
+ 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;
+}
+
+/* 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;
+}
+
diff --git a/mdk-stage1/slang/slnspace.c b/mdk-stage1/slang/slnspace.c
new file mode 100644
index 000000000..174ba7c81
--- /dev/null
+++ b/mdk-stage1/slang/slnspace.c
@@ -0,0 +1,242 @@
+/* -*- mode: C; mode: fold; -*- */
+/* slnspace.c --- Name Space implementation */
+/* Copyright (c) 1992, 1999, 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 "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;
+
+ 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 (t1 == NULL)
+ t1 = t;
+
+ if ((t != t1) || (*name == 0))
+ {
+ SLang_verror (SL_INTRINSIC_ERROR, "Namespace \"%s\" already exists",
+ 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;
+ static int num;
+ char name[64];
+
+ if (namespace_name == NULL)
+ namespace_name = "Global";
+
+ ns = _SLns_find_namespace (namespace_name);
+ if (ns != NULL)
+ return ns;
+
+ sprintf (name, " *** internal ns <%d> *** ", num);
+
+ if (NULL == (ns = _SLns_allocate_namespace (name, SLSTATIC_HASH_TABLE_SIZE)))
+ return NULL;
+
+ num++;
+ 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 */
+}
diff --git a/mdk-stage1/slang/slospath.c b/mdk-stage1/slang/slospath.c
new file mode 100644
index 000000000..644931e81
--- /dev/null
+++ b/mdk-stage1/slang/slospath.c
@@ -0,0 +1,73 @@
+/* Pathname intrinsic functions */
+/* Copyright (c) 1999, 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 "slinclud.h"
+
+#include "slang.h"
+#include "_slang.h"
+
+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 SLang_Intrin_Fun_Type Path_Name_Table [] =
+{
+ 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/mdk-stage1/slang/slpack.c b/mdk-stage1/slang/slpack.c
new file mode 100644
index 000000000..53ef63643
--- /dev/null
+++ b/mdk-stage1/slang/slpack.c
@@ -0,0 +1,785 @@
+/* Pack objects as a binary string */
+/* Copyright (c) 1998, 1999, 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 "slinclud.h"
+
+#include <ctype.h>
+
+#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/mdk-stage1/slang/slparse.c b/mdk-stage1/slang/slparse.c
new file mode 100644
index 000000000..bc709d1fb
--- /dev/null
+++ b/mdk-stage1/slang/slparse.c
@@ -0,0 +1,1970 @@
+/* Copyright (c) 1998, 1999, 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 "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:
+ * . <end of line>
+ * . <end of line>
+ */
+ 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
+ * <none>
+ */
+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/mdk-stage1/slang/slpath.c b/mdk-stage1/slang/slpath.c
new file mode 100644
index 000000000..831bd34df
--- /dev/null
+++ b/mdk-stage1/slang/slpath.c
@@ -0,0 +1,344 @@
+/* Pathname and filename functions */
+/* Copyright (c) 1998, 1999, 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 "slinclud.h"
+
+#ifdef HAVE_IO_H
+# include <io.h>
+#endif
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <signal.h>
+#include <time.h>
+
+#include <errno.h>
+#include <string.h>
+
+#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
+
+/* 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)
+{
+#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;
+}
+
+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;
+
+ max_path_len = 0;
+ this_path_len = 0;
+ p = path;
+ while (*p != 0)
+ {
+ if (*p++ == SEARCH_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, SEARCH_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;
+}
+
diff --git a/mdk-stage1/slang/slposdir.c b/mdk-stage1/slang/slposdir.c
new file mode 100644
index 000000000..33799e574
--- /dev/null
+++ b/mdk-stage1/slang/slposdir.c
@@ -0,0 +1,1057 @@
+/* file intrinsics for S-Lang */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#if defined(__unix__) || (defined (__os2__) && defined (__EMX__))
+# include <sys/types.h>
+#endif
+
+#ifdef HAVE_IO_H
+# include <io.h> /* for chmod */
+#endif
+
+#if defined(__BORLANDC__)
+# include <process.h>
+# include <dos.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+#ifdef HAVE_SYS_FCNTL_H
+# include <sys/fcntl.h>
+#endif
+
+#ifdef __unix__
+# include <sys/file.h>
+#endif
+
+#if defined(__BORLANDC__)
+# include <dir.h>
+#endif
+
+#if defined(_MSC_VER)
+# include <io.h>
+#endif
+
+#if defined(__DECC) && defined(VMS)
+# include <unixio.h>
+# include <unixlib.h>
+#endif
+
+#ifdef VMS
+# include <stat.h>
+#else
+# include <sys/stat.h>
+#endif
+
+#if defined(VMS)
+# define USE_LISTDIR_INTRINSIC 0
+#else
+# define USE_LISTDIR_INTRINSIC 1
+#endif
+
+#if USE_LISTDIR_INTRINSIC
+
+#if defined(__WIN32__)
+# include <windows.h>
+#else
+# if defined(__OS2__) && defined(__IBMC__)
+# define INCL_DOS
+# define INCL_ERRORS
+# include <os2.h>
+# include <direct.h>
+# include <ctype.h>
+# else
+# ifdef HAVE_DIRENT_H
+# include <dirent.h>
+# else
+# ifdef HAVE_DIRECT_H
+# include <direct.h>
+# else
+# define dirent direct
+# define NEED_D_NAMLEN
+# if HAVE_SYS_NDIR_H
+# include <sys/ndir.h>
+# endif
+# if HAVE_SYS_DIR_H
+# include <sys/dir.h>
+# endif
+# if HAVE_NDIR_H
+# include <ndir.h>
+# endif
+# endif
+# endif
+# endif
+#endif
+
+#endif /* USE_LISTDIR_INTRINSIC */
+
+#include <errno.h>
+
+#include "slang.h"
+#include "_slang.h"
+
+static int push_stat_struct (struct stat *st, int opt_attrs)
+{
+ char *field_names [12];
+ unsigned char field_types[12];
+ VOID_STAR field_values [12];
+ int int_values [12];
+ unsigned int i;
+
+ field_names [0] = "st_dev"; int_values [0] = (int) st->st_dev;
+ field_names [1] = "st_ino"; int_values [1] = (int) st->st_ino;
+ field_names [2] = "st_mode"; int_values [2] = (int) st->st_mode;
+ field_names [3] = "st_nlink"; int_values [3] = (int) st->st_nlink;
+ field_names [4] = "st_uid"; int_values [4] = (int) st->st_uid;
+ field_names [5] = "st_gid"; int_values [5] = (int) st->st_gid;
+ field_names [6] = "st_rdev"; int_values [6] = (int) st->st_rdev;
+ field_names [7] = "st_size"; int_values [7] = (int) st->st_size;
+ field_names [8] = "st_atime"; int_values [8] = (int) st->st_atime;
+ field_names [9] = "st_mtime"; int_values [9] = (int) st->st_mtime;
+ field_names [10] = "st_ctime"; int_values [10] = (int) st->st_ctime;
+
+ field_names [11] = "st_opt_attrs"; int_values[11] = opt_attrs;
+
+ for (i = 0; i < 12; i++)
+ {
+ field_types [i] = SLANG_INT_TYPE;
+ field_values [i] = (VOID_STAR) (int_values + i);
+ }
+
+ return SLstruct_create_struct (12, field_names, field_types, field_values);
+}
+
+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/mdk-stage1/slang/slposio.c b/mdk-stage1/slang/slposio.c
new file mode 100644
index 000000000..ab1e9f689
--- /dev/null
+++ b/mdk-stage1/slang/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 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 <sys/types.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+#ifdef HAVE_SYS_FCNTL_H
+# include <sys/fcntl.h>
+#endif
+
+#ifdef __unix__
+# include <sys/file.h>
+#endif
+
+#ifdef HAVE_IO_H
+# include <io.h>
+#endif
+
+#if defined(__BORLANDC__)
+# include <dir.h>
+#endif
+
+#if defined(__DECC) && defined(VMS)
+# include <unixio.h>
+# include <unixlib.h>
+#endif
+
+#ifdef VMS
+# include <stat.h>
+#else
+# include <sys/stat.h>
+#endif
+
+#include <errno.h>
+
+#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/mdk-stage1/slang/slprepr.c b/mdk-stage1/slang/slprepr.c
new file mode 100644
index 000000000..358eeb874
--- /dev/null
+++ b/mdk-stage1/slang/slprepr.c
@@ -0,0 +1,427 @@
+/* Copyright (c) 1996, 1999, 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.
+ */
+
+/*--------------------------------*-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
+ * - always True
+ *
+ * #iffalse
+ * #ifntrue
+ * - always False
+ *
+ * #if$ENV
+ * - True if the enviroment variable ENV is set
+ *
+ * #ifn$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 ...
+ * - 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
+ *
+ * #elif...
+ * #else
+ * #endif
+ *
+ *
+ * mj olesen
+ *----------------------------------------------------------------------*/
+/*}}}*/
+/*{{{ includes: */
+#include "slinclud.h"
+
+#include "slang.h"
+#include "_slang.h"
+/*}}}*/
+
+int (*SLprep_exists_hook) (char *, char);
+int (*_SLprep_eval_hook) (char *);
+
+/*{{{ 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 <paulh@harlequin.co.uk>
+ * 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;
+
+ if ((buf == NULL) || (pt == NULL)) return 1;
+
+ if (*buf != pt->preprocess_char)
+ {
+ if (pt->this_level != pt->exec_level)
+ return 0;
+
+ if (*buf == '\n') return pt->flags & SLPREP_BLANK_LINES_OK;
+ if (*buf == pt->comment_char) return pt->flags & SLPREP_COMMENT_LINES_OK;
+
+ return 1;
+ }
+
+ level = pt->this_level;
+ exec_level = pt->exec_level;
+ prev_exec_level = pt->prev_exec_level;
+
+ buf++;
+
+ /* Allow '#!' to pass. This could be a shell script with something
+ like '#! /local/bin/slang' */
+ if ((*buf == '!') && (pt->preprocess_char == '#'))
+ return 0;
+
+ /* Allow whitespace as in '# ifdef' */
+ while ((*buf == ' ') || (*buf == '\t')) buf++;
+ if (*buf < 'a') return (level == exec_level);
+
+ 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 ifdef testing. First set variable
+ * to values appropriate for ifdef testing.
+ */
+ level--; /* now == to exec level */
+ }
+ else
+ {
+ if (level == exec_level)
+ {
+ exec_level--;
+ }
+ goto done;
+ }
+ }
+
+ if ((buf[0] == 'i') && (buf[1] == 'f'))
+ {
+ int truth;
+
+ if (level != exec_level)
+ {
+ /* Not interested */
+ level++;
+ goto done;
+ }
+
+ level++;
+
+ buf += 2;
+ if (buf[0] == 'n')
+ {
+ truth = 0;
+ buf++;
+ }
+ else truth = 1;
+
+ if (!strncmp (buf, "def", 3))
+ truth = (truth == is_any_defined(buf + 3, pt->comment_char));
+
+ else if (!strncmp (buf, "false", 5))
+ truth = !truth;
+
+ else if (*buf == '$')
+ truth = (truth == is_env_defined (buf + 1, pt->comment_char));
+
+ else if (!strncmp (buf, "exists", 6)
+ && (SLprep_exists_hook != NULL))
+ truth = (truth == (*SLprep_exists_hook)(buf + 6, pt->comment_char));
+
+ else if (!strncmp (buf, "eval", 4)
+ && (_SLprep_eval_hook != NULL))
+ truth = (truth == (*_SLprep_eval_hook) (buf + 4));
+
+ else if (0 != strncmp (buf, "true", 4))
+ return 1; /* let it bomb */
+
+ if (truth)
+ {
+ exec_level = level;
+ prev_exec_level = exec_level;
+ }
+ }
+ else return 1; /* let it bomb. */
+
+ done:
+
+ if (exec_level < 0) return 1;
+
+ 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 ()
+{
+ char buf[1024];
+ SLPreprocess_Type pt;
+
+ SLprep_open_prep (&pt);
+
+ SLdefine_for_ifdef ("UNIX");
+
+ 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/mdk-stage1/slang/slproc.c b/mdk-stage1/slang/slproc.c
new file mode 100644
index 000000000..8b266f28f
--- /dev/null
+++ b/mdk-stage1/slang/slproc.c
@@ -0,0 +1,155 @@
+/* Process specific system calls */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#ifdef HAVE_IO_H
+# include <io.h> /* for chmod */
+#endif
+
+#ifdef HAVE_PROCESS_H
+# include <process.h> /* for getpid */
+#endif
+
+#if defined(__BORLANDC__)
+# include <dos.h>
+#endif
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <signal.h>
+#include <time.h>
+
+#include <errno.h>
+
+#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/mdk-stage1/slang/slregexp.c b/mdk-stage1/slang/slregexp.c
new file mode 100644
index 000000000..6592a5a63
--- /dev/null
+++ b/mdk-stage1/slang/slregexp.c
@@ -0,0 +1,935 @@
+/* ed style regular expressions */
+/* Copyright (c) 1992, 1999, 2001 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 != *str))
+ {
+ n--;
+ str++;
+ }
+ if (n) return (NULL);
+
+ save_str = str;
+ n = n1 - n0;
+ while (n && (str < estr) && (p1 != *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 == *str))
+ {
+ n--;
+ str++;
+ }
+ if (n) return (NULL);
+
+ save_str = str;
+ n = n1 - n0;
+ while (n && (str < estr) && (p1 == *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 (str < estr)
+ {
+ 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;
+ }
+ 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(&reg)) 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), &reg)) continue;
+ }
+
+ fputs(buf, stdout);
+ }
+ return (0);
+}
+#endif
diff --git a/mdk-stage1/slang/slrline.c b/mdk-stage1/slang/slrline.c
new file mode 100644
index 000000000..1874be0bb
--- /dev/null
+++ b/mdk-stage1/slang/slrline.c
@@ -0,0 +1,836 @@
+/* SLang_read_line interface --- uses SLang tty stuff */
+/* Copyright (c) 1992, 1999, 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 "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 = 0, 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) want_cursor_pos = 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 = NULL;
+ 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/mdk-stage1/slang/slscanf.c b/mdk-stage1/slang/slscanf.c
new file mode 100644
index 000000000..5bd93ff41
--- /dev/null
+++ b/mdk-stage1/slang/slscanf.c
@@ -0,0 +1,718 @@
+/* sscanf function for S-Lang */
+/* Copyright (c) 1999, 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 "slinclud.h"
+#include <ctype.h>
+#include <math.h>
+#include <errno.h>
+
+#include "slang.h"
+#include "_slang.h"
+
+static char *skip_whitespace (char *s)
+{
+ while (isspace (*s))
+ s++;
+
+ return s;
+}
+
+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;
+#if 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 = skip_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 = skip_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 = skip_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/mdk-stage1/slang/slscroll.c b/mdk-stage1/slang/slscroll.c
new file mode 100644
index 000000000..358296116
--- /dev/null
+++ b/mdk-stage1/slang/slscroll.c
@@ -0,0 +1,450 @@
+/* SLang Scrolling Window Routines */
+/* Copyright (c) 1996, 1999, 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 "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/mdk-stage1/slang/slsearch.c b/mdk-stage1/slang/slsearch.c
new file mode 100644
index 000000000..a9a427a7d
--- /dev/null
+++ b/mdk-stage1/slang/slsearch.c
@@ -0,0 +1,239 @@
+/* Copyright (c) 1992, 1999, 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 "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/mdk-stage1/slang/slsignal.c b/mdk-stage1/slang/slsignal.c
new file mode 100644
index 000000000..30707dea5
--- /dev/null
+++ b/mdk-stage1/slang/slsignal.c
@@ -0,0 +1,336 @@
+/* Copyright (c) 1998, 1999, 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 "slinclud.h"
+
+#include <signal.h>
+
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+#endif
+#ifdef HAVE_SYS_WAIT_H
+# include <sys/wait.h>
+#endif
+
+#include <errno.h>
+
+#include "slang.h"
+#include "_slang.h"
+
+/* Do not trust these environments */
+#if defined(__CYGWIN32__) || 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 <windows.h>
+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/mdk-stage1/slang/slsmg.c b/mdk-stage1/slang/slsmg.c
new file mode 100644
index 000000000..088557f27
--- /dev/null
+++ b/mdk-stage1/slang/slsmg.c
@@ -0,0 +1,1584 @@
+/* SLang Screen management routines */
+/* Copyright (c) 1992, 1999, 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 "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;
+
+#if !defined(__MSDOS_16BIT__)
+# define MAX_SCREEN_SIZE 256
+#else
+# define MAX_SCREEN_SIZE 75
+#endif
+
+Screen_Type SL_Screen[MAX_SCREEN_SIZE];
+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)
+{
+ 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, ' ');
+ 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 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 char *p, *pmax, 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 char *) Fake_Alt_Char_Pairs;
+ pmax = p + strlen ((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 > MAX_SCREEN_SIZE)
+ Screen_Rows = MAX_SCREEN_SIZE;
+
+ 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/mdk-stage1/slang/slstd.c b/mdk-stage1/slang/slstd.c
new file mode 100644
index 000000000..b05dfcddb
--- /dev/null
+++ b/mdk-stage1/slang/slstd.c
@@ -0,0 +1,724 @@
+/* -*- mode: C; mode: fold; -*- */
+/* Standard intrinsic functions for S-Lang. Included here are string
+ and array operations */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+/*{{{ Include Files */
+
+#include <time.h>
+
+#ifndef __QNX__
+# if defined(__GO32__) || defined(__WATCOMC__)
+# include <dos.h>
+# include <bios.h>
+# endif
+#endif
+
+#if SLANG_HAS_FLOAT
+# include <math.h>
+#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 lang_print_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);
+ }
+}
+
+/*}}}*/
+
+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)
+{
+ if (NULL == _SLang_Current_Function_Name)
+ return "";
+ return _SLang_Current_Function_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_file (char *s)
+{
+ if (-1 == SLang_load_file (s))
+ return 0;
+ return 1;
+}
+
+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));
+}
+
+#ifdef HAVE_SYS_UTSNAME_H
+# include <sys/utsname.h>
+#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 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_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_S("evalfile", load_file, SLANG_INT_TYPE),
+ MAKE_INTRINSIC_I("char", char_cmd, SLANG_VOID_TYPE),
+ MAKE_INTRINSIC_S("eval", SLang_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_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_COMPLEX
+ || (-1 == _SLinit_slcomplex ())
+#endif
+#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/mdk-stage1/slang/slstdio.c b/mdk-stage1/slang/slstdio.c
new file mode 100644
index 000000000..05db1af77
--- /dev/null
+++ b/mdk-stage1/slang/slstdio.c
@@ -0,0 +1,1050 @@
+/* file stdio intrinsics for S-Lang */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#if defined(__unix__) || (defined (__os2__) && defined (__EMX__))
+# include <sys/types.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+#ifdef HAVE_SYS_FCNTL_H
+# include <sys/fcntl.h>
+#endif
+
+#ifdef __unix__
+# include <sys/file.h>
+#endif
+
+#if defined(__BORLANDC__)
+# include <io.h>
+# include <dir.h>
+#endif
+
+#if defined(__DECC) && defined(VMS)
+# include <unixio.h>
+# include <unixlib.h>
+#endif
+
+#ifdef VMS
+# include <stat.h>
+#else
+# include <sys/stat.h>
+#endif
+
+#include <errno.h>
+
+#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)
+{
+ 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;
+
+ *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);
+ 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);
+ 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
+ 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
+ {
+ 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:
+ status = read_one_line (c->fp, &s, &len);
+ 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/mdk-stage1/slang/slstring.c b/mdk-stage1/slang/slstring.c
new file mode 100644
index 000000000..529c41827
--- /dev/null
+++ b/mdk-stage1/slang/slstring.c
@@ -0,0 +1,546 @@
+/* Copyright (c) 1998, 1999, 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 "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)
+{
+ SLstring_Type *sls;
+
+#if _SLANG_OPTIMIZE_FOR_SPEED
+ 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);
+#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/mdk-stage1/slang/slstrops.c b/mdk-stage1/slang/slstrops.c
new file mode 100644
index 000000000..a57ef6389
--- /dev/null
+++ b/mdk-stage1/slang/slstrops.c
@@ -0,0 +1,1686 @@
+/* -*- mode: C; mode: fold; -*- */
+/* string manipulation functions for S-Lang. */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+/*{{{ Include Files */
+
+#include <time.h>
+
+#ifndef __QNX__
+# if defined(__GO32__) || defined(__WATCOMC__)
+# include <dos.h>
+# include <bios.h>
+# endif
+#endif
+
+#if SLANG_HAS_FLOAT
+#include <math.h>
+#endif
+
+#include <string.h>
+#include <stdarg.h>
+#include <ctype.h>
+
+#ifndef isdigit
+# define isdigit(x) (((x) >= '0') && ((x) <= '9'))
+#endif
+
+#include "slang.h"
+#include "_slang.h"
+
+/*}}}*/
+
+#define USE_ALLOC_STSTRING 1
+
+/*{{{ Utility Functions */
+
+static char Utility_Char_Table [256];
+static unsigned char WhiteSpace_Lut[256];
+
+static void set_utility_char_table (char *pos) /*{{{*/
+{
+ register char *t = Utility_Char_Table, *tmax;
+ register unsigned char ch;
+
+ tmax = t + 256;
+ while (t < tmax) *t++ = 0;
+
+ t = 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;
+
+ set_utility_char_table (white);
+
+ a = *beg;
+ len = strlen (a);
+ b = a + len;
+
+ if (do_beg)
+ while (Utility_Char_Table[(unsigned char) *a]) a++;
+
+ if (do_end)
+ {
+ b--;
+ while ((b >= a) && (Utility_Char_Table[(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 = " \t\f\r\n";
+
+ 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;
+ register char *t, *s, *q1;
+ register unsigned char ch;
+
+ 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) _SLStack_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 = _SLRun_Stack + ofs;
+
+ if (SLang_pop_slstring(&fmt))
+ return -1;
+
+ p = SLdo_sprintf (fmt);
+ SLang_free_slstring (fmt);
+
+ while (_SLStack_Pointer > ptr)
+ SLdo_pop ();
+
+ 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 (&regexp_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, &regexp_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/mdk-stage1/slang/slstruct.c b/mdk-stage1/slang/slstruct.c
new file mode 100644
index 000000000..33d182373
--- /dev/null
+++ b/mdk-stage1/slang/slstruct.c
@@ -0,0 +1,932 @@
+/* Structure type implementation */
+/* Copyright (c) 1998, 1999, 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 "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 *f;
+
+ f = find_field (s, name);
+ if (f == NULL)
+ SLang_verror (SL_SYNTAX_ERROR, "struct has no field named %s", name);
+ return f;
+}
+
+int SLstruct_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 -1;
+
+ 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_INVALID_PARM, "A struct field name cannot be NULL");
+ 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_push (type, value)))
+ || (-1 == SLang_pop (&f->obj)))
+ goto return_error;
+
+ f++;
+ }
+
+ if (0 == _SLang_push_struct (s))
+ return 0;
+ /* drop */
+
+ return_error:
+ _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)))
+ || (-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)))
+ {
+ _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 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)))
+ {
+ _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);
+ }
+}
diff --git a/mdk-stage1/slang/sltermin.c b/mdk-stage1/slang/sltermin.c
new file mode 100644
index 000000000..f9c64f0b2
--- /dev/null
+++ b/mdk-stage1/slang/sltermin.c
@@ -0,0 +1,1155 @@
+/* This file contains enough terminfo reading capabilities sufficient for
+ * the slang SLtt interface.
+ */
+
+/* Copyright (c) 1992, 1999, 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 "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
+ * <term.h>.
+ */
+
+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 ($<nn>) 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.
+ */
+
+#define MAX_TI_DIRS 7
+static char *Terminfo_Dirs [MAX_TI_DIRS] =
+{
+ NULL, /* $HOME/.terminfo */
+ NULL, /* $TERMINFO */
+ "/usr/share/terminfo",
+ "/usr/lib/terminfo",
+ "/usr/share/lib/terminfo",
+ "/etc/terminfo",
+ "/usr/local/lib/terminfo"
+};
+
+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 (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 = 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] = getenv ("TERMINFO");
+ i = 0;
+ while (i < MAX_TI_DIRS)
+ {
+ tidir = Terminfo_Dirs[i];
+ if ((tidir != NULL)
+ && (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 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;
+
+ /* 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/mdk-stage1/slang/sltime.c b/mdk-stage1/slang/sltime.c
new file mode 100644
index 000000000..14fc6ec16
--- /dev/null
+++ b/mdk-stage1/slang/sltime.c
@@ -0,0 +1,310 @@
+/* time related system calls */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#include <sys/types.h>
+#include <time.h>
+
+#if defined(__BORLANDC__)
+# include <dos.h>
+#endif
+#if defined(__GO32__) || defined(__WATCOMC__)
+# include <dos.h>
+# include <bios.h>
+#endif
+
+#include <errno.h>
+
+#include "slang.h"
+#include "_slang.h"
+
+#ifdef __WIN32__
+#include <windows.h>
+/* 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 int push_tm_struct (struct tm *tms)
+{
+ char *field_names [9];
+ unsigned char field_types[9];
+ VOID_STAR field_values [9];
+ int int_values [9];
+ unsigned int i;
+
+ if (tms == NULL)
+ return SLang_push_null ();
+
+ field_names [0] = "tm_sec"; int_values [0] = tms->tm_sec;
+ field_names [1] = "tm_min"; int_values [1] = tms->tm_min;
+ field_names [2] = "tm_hour"; int_values [2] = tms->tm_hour;
+ field_names [3] = "tm_mday"; int_values [3] = tms->tm_mday;
+ field_names [4] = "tm_mon"; int_values [4] = tms->tm_mon;
+ field_names [5] = "tm_year"; int_values [5] = tms->tm_year;
+ field_names [6] = "tm_wday"; int_values [6] = tms->tm_wday;
+ field_names [7] = "tm_yday"; int_values [7] = tms->tm_yday;
+ field_names [8] = "tm_isdst"; int_values [8] = tms->tm_isdst;
+
+ for (i = 0; i < 9; i++)
+ {
+ field_types [i] = SLANG_INT_TYPE;
+ field_values [i] = (VOID_STAR) (int_values + i);
+ }
+
+ return SLstruct_create_struct (9, field_names, field_types, field_values);
+}
+
+
+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 <sys/times.h>
+# endif
+
+#include <limits.h>
+
+#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
+
+static void times_cmd (void)
+{
+ double dvals[4];
+ struct tms t;
+ VOID_STAR field_values[4];
+ char *field_names[4];
+ unsigned int i;
+ unsigned char field_types[4];
+
+ (void) times (&t);
+
+ field_names[0] = "tms_utime"; dvals[0] = (double)t.tms_utime;
+ field_names[1] = "tms_stime"; dvals[1] = (double)t.tms_stime;
+ field_names[2] = "tms_cutime"; dvals[2] = (double)t.tms_cutime;
+ field_names[3] = "tms_cstime"; dvals[3] = (double)t.tms_cstime;
+
+ for (i = 0; i < 4; i++)
+ {
+ dvals[i] *= SECS_PER_TICK;
+ field_values[i] = (VOID_STAR) &dvals[i];
+ field_types[i] = SLANG_DOUBLE_TYPE;
+ }
+ (void) SLstruct_create_struct (4, field_names, field_types, field_values);
+}
+
+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/mdk-stage1/slang/sltoken.c b/mdk-stage1/slang/sltoken.c
new file mode 100644
index 000000000..d08967a24
--- /dev/null
+++ b/mdk-stage1/slang/sltoken.c
@@ -0,0 +1,1702 @@
+/* Copyright (c) 1998, 1999, 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 "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 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 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,
+ "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;
+ 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 = 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 (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;
+
+ if (0 != SLang_load_string (expr))
+ return -1;
+ if (-1 == SLang_pop_integer (&ret))
+ return -1;
+ return (ret != 0);
+}
+
+
+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 *SLallocate_load_type (char *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 = "";
+
+ x->name = SLang_create_slstring (name);
+ if (x->name == NULL)
+ {
+ SLfree ((char *) x);
+ return NULL;
+ }
+ return x;
+}
+
+void SLdeallocate_load_type (SLang_Load_Type *x)
+{
+ if (x != NULL)
+ {
+ SLang_free_slstring (x->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)
+{
+ 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 = SLallocate_load_type ("***string***")))
+ {
+ 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);
+}
+
+/* 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 SLang_load_file (char *f)
+{
+ File_Client_Data_Type client_data;
+ SLang_Load_Type *x;
+ char *name, *buf;
+ FILE *fp;
+
+ if (SLang_Load_File_Hook != NULL)
+ return (*SLang_Load_File_Hook) (f);
+
+ if (f == NULL) name = "<stdin>"; else name = f;
+
+ name = SLang_create_slstring (name);
+ if (name == NULL)
+ return -1;
+
+ if (NULL == (x = SLallocate_load_type (name)))
+ {
+ SLang_free_slstring (name);
+ return -1;
+ }
+
+ buf = NULL;
+
+ if (f != NULL)
+ fp = fopen (f, "r");
+ 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;
+}
+
+int SLang_guess_type (char *t)
+{
+ char *p;
+ register char ch;
+ int modifier = 0;
+
+ 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
+ {
+ while (WHITE_CHAR == CHAR_CLASS(*s))
+ s++;
+
+ value = 0;
+ while (DIGIT_CHAR == CHAR_CLASS(*s))
+ {
+ value = value * 10 + (unsigned long) (*s - '0');
+ s++;
+ }
+ }
+
+ if (sign == -1)
+ value = (unsigned long)-1L * value;
+
+ return value;
+}
+
+long SLatol (unsigned char *s)
+{
+ while (WHITE_CHAR == CHAR_CLASS(*s))
+ s++;
+
+ if (*s == '-')
+ {
+ long value = (long) SLatoul (s+1);
+ return -value;
+ }
+ return (long) SLatoul (s);
+}
+
+int SLatoi (unsigned char *s)
+{
+ return (int) SLatol (s);
+}
+
+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/mdk-stage1/slang/sltypes.c b/mdk-stage1/slang/sltypes.c
new file mode 100644
index 000000000..05b8741b1
--- /dev/null
+++ b/mdk-stage1/slang/sltypes.c
@@ -0,0 +1,966 @@
+/* Basic type operations for S-Lang */
+/* Copyright (c) 1992, 1996, 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 "slinclud.h"
+
+#if SLANG_HAS_FLOAT
+# include <math.h>
+#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;
+ 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++)
+ {
+ ic [n] = (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++)
+ {
+ ic [n] = (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;
+}
+
+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, unsigned char 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";
+ * 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 = _SLStack_Pointer;
+ if (0 == _SLang_deref_assign (ref))
+ return 0;
+
+ if (stkptr != _SLStack_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);
+}
+
+/* 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;
+
+ /* 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");
+
+ 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);
+ 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);
+ 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/mdk-stage1/slang/slutty.c b/mdk-stage1/slang/slutty.c
new file mode 100644
index 000000000..636c1bb90
--- /dev/null
+++ b/mdk-stage1/slang/slutty.c
@@ -0,0 +1,596 @@
+/* slutty.c --- Unix Low level terminal (tty) functions for S-Lang */
+/* Copyright (c) 1992, 1999, 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 "slinclud.h"
+
+#include <signal.h>
+/* sequent support thanks to Kenneth Lorber <keni@oasys.dt.navy.mil> */
+/* 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 <sys/types.h> */
+#endif
+
+#include <sys/time.h>
+#include <sys/types.h>
+
+#ifdef SYSV
+# include <fcntl.h>
+# ifndef CRAY
+# include <sys/termio.h>
+# include <sys/stream.h>
+# include <sys/ptem.h>
+# include <sys/tty.h>
+# endif
+#endif
+
+#ifdef __BEOS__
+/* Prototype for select */
+# include <net/socket.h>
+#endif
+
+#include <sys/file.h>
+
+#ifndef sun
+# include <sys/ioctl.h>
+#endif
+
+#ifdef __QNX__
+# include <sys/select.h>
+#endif
+
+#include <sys/stat.h>
+#include <errno.h>
+
+#if defined (_AIX) && !defined (FD_SET)
+# include <sys/select.h> /* for FD_ISSET, FD_SET, FD_ZERO */
+#endif
+
+#ifndef O_RDWR
+# include <fcntl.h>
+#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 <sys/ioctl.h>
+# endif
+
+typedef struct
+ {
+ struct tchars t;
+ struct ltchars lt;
+ struct sgttyb s;
+ }
+TTY_Termio_Type;
+#else
+# include <termios.h>
+typedef struct termios TTY_Termio_Type;
+#endif
+
+static TTY_Termio_Type Old_TTY;
+
+#ifdef HAVE_TERMIOS_H
+typedef 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
+# ifndef __BEOS__ /* 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
+ 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) 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/mdk-stage1/slang/slxstrng.c b/mdk-stage1/slang/slxstrng.c
new file mode 100644
index 000000000..3f8a4dffa
--- /dev/null
+++ b/mdk-stage1/slang/slxstrng.c
@@ -0,0 +1,43 @@
+/* Copyright (c) 1992, 1999, 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.
+ */
+
+/* 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);
+}