summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorThierry Vignaud <tv@mageia.org>2012-06-01 17:25:22 +0000
committerThierry Vignaud <tv@mageia.org>2012-06-01 17:25:22 +0000
commitcebb882bbb82549f1798b8fc4b37d76be90a869b (patch)
treeaa04026f1b22781d668ed02d04688e1f48cd008c
parentf8b5c22e2584741f2c522ffc86486bc073f943ce (diff)
downloaddrakx-cebb882bbb82549f1798b8fc4b37d76be90a869b.tar
drakx-cebb882bbb82549f1798b8fc4b37d76be90a869b.tar.gz
drakx-cebb882bbb82549f1798b8fc4b37d76be90a869b.tar.bz2
drakx-cebb882bbb82549f1798b8fc4b37d76be90a869b.tar.xz
drakx-cebb882bbb82549f1798b8fc4b37d76be90a869b.zip
link against system libraries for newt & slang too (from mdv)
-rw-r--r--mdk-stage1/Makefile9
-rw-r--r--mdk-stage1/NEWS2
-rw-r--r--mdk-stage1/newt-frontend.c4
-rw-r--r--mdk-stage1/newt/Makefile42
-rw-r--r--mdk-stage1/newt/button.c192
-rw-r--r--mdk-stage1/newt/buttonbar.c46
-rw-r--r--mdk-stage1/newt/checkbox.c292
-rw-r--r--mdk-stage1/newt/checkboxtree.c714
-rw-r--r--mdk-stage1/newt/entry.c378
-rw-r--r--mdk-stage1/newt/form.c713
-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/Makefile42
-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
87 files changed, 9 insertions, 52614 deletions
diff --git a/mdk-stage1/Makefile b/mdk-stage1/Makefile
index 586596bb4..a4ef5d428 100644
--- a/mdk-stage1/Makefile
+++ b/mdk-stage1/Makefile
@@ -70,16 +70,19 @@ INITOBJS = $(subst .c,.o,$(INITSRC))
#- frontends
NEWT_FRONTEND_SRC = newt-frontend.c
-NEWT_FRONTEND_LIBS = newt/libnewt.a slang/libslang.a
+NEWT_FRONTEND_LIBS = libnewt.a libslang.a
STDIO_FRONTEND_SRC = stdio-frontend.c
STDIO_FRONTEND_LIBS =
STDIO_FRONTEND_LIBS =
-
FRONTEND_OBJS = $(subst .c,.o,$($(F)_FRONTEND_SRC))
+ifeq (DIETLIBC, $(L))
+FRONTEND_LINK = $(FRONTEND_OBJS) $(patsubst %,/usr/lib/dietlibc/lib-$(ARCH)/%,$($(F)_FRONTEND_LIBS))
+else
FRONTEND_LINK = $(FRONTEND_OBJS) $($(F)_FRONTEND_LIBS)
+endif
STAGE1_STATIC_LIBS =
STAGE1_STATIC_USR_LIBS = libz.a libldetect.a libkmod.a libpci.a liblzma.a libsysfs.a
@@ -127,7 +130,7 @@ STAGE1OBJS-FULL = $(subst .c,-FULL.o,$(STAGE1_ALLSRC))
BINS = init stage1 dhcp-client rescue-gui probe-modules
-DIRS += pci-resource usb-resource slang newt
+DIRS += pci-resource usb-resource
ifeq (i386, $(ARCH))
DIRS += pcmcia pcmcia-resource
endif
diff --git a/mdk-stage1/NEWS b/mdk-stage1/NEWS
index 6f44e4e7e..8b3d476f4 100644
--- a/mdk-stage1/NEWS
+++ b/mdk-stage1/NEWS
@@ -3,7 +3,7 @@
- hide "KA server" option (mga#5944)
- switch from gethostbyname() to getaddrinfo() (mga#4056)
- switch from gethostbyaddr() to getnameinfo()
-- use system library for sysfs (mdv)
+- use system libraries for newtw, slang & sysfs (mdv)
1.65
- load btrfs module to mount btrfs
diff --git a/mdk-stage1/newt-frontend.c b/mdk-stage1/newt-frontend.c
index e8a6ef6d3..6bdded9d3 100644
--- a/mdk-stage1/newt-frontend.c
+++ b/mdk-stage1/newt-frontend.c
@@ -32,7 +32,7 @@
#include <stdio.h>
#include <stdarg.h>
#include <sys/time.h>
-#include "newt/newt.h"
+#include <newt.h>
#include <probing.h>
@@ -299,7 +299,7 @@ static int mynewtWinEntries(char * title, char * text, int suggestedWidth, int f
for (i = 0; i < numItems; i++) {
newtComponent entr = newtEntry(-1, -1, items[i].value ?
*items[i].value : NULL, dataWidth,
- items[i].value, items[i].flags);
+ (const char**)items[i].value, items[i].flags);
newtGridSetField(subgrid, 0, i, NEWT_GRID_COMPONENT,
newtLabel(-1, -1, items[i].text),
diff --git a/mdk-stage1/newt/Makefile b/mdk-stage1/newt/Makefile
deleted file mode 100644
index 9f6bd845a..000000000
--- a/mdk-stage1/newt/Makefile
+++ /dev/null
@@ -1,42 +0,0 @@
- #******************************************************************************
- #
- # Guillaume Cottenceau (gc)
- #
- # Copyright 2000 Mandriva
- #
- # 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
-
-
-LIBNAME = libnewt
-
-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
-
-DEFS = -DVERSION=\"0.50.19\"
-
-INCS = -I../slang
-
-
-TARGETS = $(LIBNAME).a
-
-all: $(TARGETS)
-
-clean:
- rm -f *.o *.a
-
-$(LIBNAME).a: $(OBJS)
- ar -cru $@ $^
- ranlib $@
-
-$(OBJS): %.o: %.c
- $(DIET) gcc $(CFLAGS) $(DEFS) $(INCS) $(INCLUDES) -c $< -o $@
diff --git a/mdk-stage1/newt/button.c b/mdk-stage1/newt/button.c
deleted file mode 100644
index d7da58175..000000000
--- a/mdk-stage1/newt/button.c
+++ /dev/null
@@ -1,192 +0,0 @@
-#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;
- er.result = ER_IGNORED;
- er.u.focus = NULL;
-
- 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
deleted file mode 100644
index 45473c9d2..000000000
--- a/mdk-stage1/newt/buttonbar.c
+++ /dev/null
@@ -1,46 +0,0 @@
-#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
deleted file mode 100644
index 643609d34..000000000
--- a/mdk-stage1/newt/checkbox.c
+++ /dev/null
@@ -1,292 +0,0 @@
-#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;
- er.result = ER_IGNORED;
- er.u.focus = NULL;
-
- 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
deleted file mode 100644
index 00113f23e..000000000
--- a/mdk-stage1/newt/checkboxtree.c
+++ /dev/null
@@ -1,714 +0,0 @@
-#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) > (size_t)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) > (size_t)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
deleted file mode 100644
index 0ee449cf9..000000000
--- a/mdk-stage1/newt/entry.c
+++ /dev/null
@@ -1,378 +0,0 @@
-#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;
- er.result = ER_IGNORED;
- er.u.focus = NULL;
-
- 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) >= (size_t) (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
deleted file mode 100644
index ad7520e95..000000000
--- a/mdk-stage1/newt/form.c
+++ /dev/null
@@ -1,713 +0,0 @@
-#include <unistd.h>
-#include <slang.h>
-#include <stdarg.h>
-#include <stdlib.h>
-#include <string.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
deleted file mode 100644
index 37d2b2e74..000000000
--- a/mdk-stage1/newt/grid.c
+++ /dev/null
@@ -1,389 +0,0 @@
-#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 ((size_t)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
deleted file mode 100644
index f1a9cebbf..000000000
--- a/mdk-stage1/newt/label.c
+++ /dev/null
@@ -1,81 +0,0 @@
-#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
deleted file mode 100644
index 0048c3782..000000000
--- a/mdk-stage1/newt/listbox.c
+++ /dev/null
@@ -1,752 +0,0 @@
-/* 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) > (size_t)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) > (size_t)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) > (size_t)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->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
deleted file mode 100644
index 8ff5e39a5..000000000
--- a/mdk-stage1/newt/newt.c
+++ /dev/null
@@ -1,672 +0,0 @@
-#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 __attribute__ ((unused))) {
- 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 */
- (void) 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((SLsmg_Char_Type *)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((SLsmg_Char_Type *)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 __attribute__ ((unused)),
- struct event ev __attribute__ ((unused))) {
- 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
deleted file mode 100644
index d3fd8bedc..000000000
--- a/mdk-stage1/newt/newt.h
+++ /dev/null
@@ -1,362 +0,0 @@
-#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
deleted file mode 100644
index 76f5e2f6f..000000000
--- a/mdk-stage1/newt/newt_pr.h
+++ /dev/null
@@ -1,82 +0,0 @@
-#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
deleted file mode 100644
index 800958580..000000000
--- a/mdk-stage1/newt/scale.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#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
deleted file mode 100644
index cb4bc2757..000000000
--- a/mdk-stage1/newt/scrollbar.c
+++ /dev/null
@@ -1,124 +0,0 @@
-#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
deleted file mode 100644
index 8eb4ae4db..000000000
--- a/mdk-stage1/newt/textbox.c
+++ /dev/null
@@ -1,409 +0,0 @@
-#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 __attribute__ ((unused))) {
- 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);
- 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);
- }
- 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
deleted file mode 100644
index 30a8d526c..000000000
--- a/mdk-stage1/newt/windows.c
+++ /dev/null
@@ -1,275 +0,0 @@
-#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, 50, 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 *) (long)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
deleted file mode 100644
index 85246f27e..000000000
--- a/mdk-stage1/slang/Makefile
+++ /dev/null
@@ -1,42 +0,0 @@
- #******************************************************************************
- #
- # Guillaume Cottenceau (gc)
- #
- # Copyright 2000 Mandriva
- #
- # 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
-
-
-LIBNAME = libslang
-
-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
-
-DEFS = -Dunix -DSLANG
-
-INCS =
-
-
-TARGETS = $(LIBNAME).a
-
-all: $(TARGETS)
-
-clean:
- rm -f *.o *.a
-
-$(LIBNAME).a: $(OBJS)
- ar -cru $@ $^
- ranlib $@
-
-$(OBJS): %.o: %.c
- $(DIET) gcc $(CFLAGS) $(DEFS) $(INCS) $(INCLUDES) -c $< -o $@
diff --git a/mdk-stage1/slang/_slang.h b/mdk-stage1/slang/_slang.h
deleted file mode 100644
index 02ee13505..000000000
--- a/mdk-stage1/slang/_slang.h
+++ /dev/null
@@ -1,743 +0,0 @@
-#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
deleted file mode 100644
index a5ab3273c..000000000
--- a/mdk-stage1/slang/config.h
+++ /dev/null
@@ -1,163 +0,0 @@
-/* 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
deleted file mode 100644
index 70d491b78..000000000
--- a/mdk-stage1/slang/jdmacros.h
+++ /dev/null
@@ -1,53 +0,0 @@
-#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
deleted file mode 100644
index 17d94d5a3..000000000
--- a/mdk-stage1/slang/keywhash.c
+++ /dev/null
@@ -1,190 +0,0 @@
-/* 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
deleted file mode 100644
index 511d72451..000000000
--- a/mdk-stage1/slang/sl-feat.h
+++ /dev/null
@@ -1,60 +0,0 @@
-/* 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
deleted file mode 100644
index 6edc7df37..000000000
--- a/mdk-stage1/slang/slang.c
+++ /dev/null
@@ -1,5547 +0,0 @@
-/* -*- 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
deleted file mode 100644
index 900b14043..000000000
--- a/mdk-stage1/slang/slang.h
+++ /dev/null
@@ -1,1930 +0,0 @@
-#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
deleted file mode 100644
index 07ad68687..000000000
--- a/mdk-stage1/slang/slarith.c
+++ /dev/null
@@ -1,1656 +0,0 @@
-
-/* 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
deleted file mode 100644
index efa8a5e04..000000000
--- a/mdk-stage1/slang/slarith.inc
+++ /dev/null
@@ -1,783 +0,0 @@
-/* -*- 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
deleted file mode 100644
index 0b9a1406c..000000000
--- a/mdk-stage1/slang/slarray.c
+++ /dev/null
@@ -1,3139 +0,0 @@
-/* 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
deleted file mode 100644
index bfa6ec5e5..000000000
--- a/mdk-stage1/slang/slarrfun.c
+++ /dev/null
@@ -1,464 +0,0 @@
-/* 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
deleted file mode 100644
index 348473a6f..000000000
--- a/mdk-stage1/slang/slarrfun.inc
+++ /dev/null
@@ -1,257 +0,0 @@
-/* -*- 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
deleted file mode 100644
index 330dcb53f..000000000
--- a/mdk-stage1/slang/slarrmis.c
+++ /dev/null
@@ -1,38 +0,0 @@
-/* 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
deleted file mode 100644
index 5997458d2..000000000
--- a/mdk-stage1/slang/slassoc.c
+++ /dev/null
@@ -1,713 +0,0 @@
-/* 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
deleted file mode 100644
index b4b8c4c51..000000000
--- a/mdk-stage1/slang/slbstr.c
+++ /dev/null
@@ -1,615 +0,0 @@
-/* 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
deleted file mode 100644
index 733888cb8..000000000
--- a/mdk-stage1/slang/slclass.c
+++ /dev/null
@@ -1,1391 +0,0 @@
-/* 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
deleted file mode 100644
index 4a00a90fc..000000000
--- a/mdk-stage1/slang/slcmd.c
+++ /dev/null
@@ -1,351 +0,0 @@
-/* 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
deleted file mode 100644
index b210dfc04..000000000
--- a/mdk-stage1/slang/slcmplex.c
+++ /dev/null
@@ -1,1142 +0,0 @@
-/* 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
deleted file mode 100644
index 5aa122483..000000000
--- a/mdk-stage1/slang/slcompat.c
+++ /dev/null
@@ -1,34 +0,0 @@
-/* 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
deleted file mode 100644
index f1212afc8..000000000
--- a/mdk-stage1/slang/slcurses.c
+++ /dev/null
@@ -1,972 +0,0 @@
-/* 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
deleted file mode 100644
index fa082304f..000000000
--- a/mdk-stage1/slang/slcurses.h
+++ /dev/null
@@ -1,353 +0,0 @@
-/* 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
deleted file mode 100644
index 1e1161774..000000000
--- a/mdk-stage1/slang/sldisply.c
+++ /dev/null
@@ -1,2596 +0,0 @@
-/* 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
deleted file mode 100644
index 139b3859b..000000000
--- a/mdk-stage1/slang/slerr.c
+++ /dev/null
@@ -1,181 +0,0 @@
-/* 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
deleted file mode 100644
index 662fadde1..000000000
--- a/mdk-stage1/slang/slerrno.c
+++ /dev/null
@@ -1,219 +0,0 @@
-/* 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
deleted file mode 100644
index 2f2914f07..000000000
--- a/mdk-stage1/slang/slgetkey.c
+++ /dev/null
@@ -1,306 +0,0 @@
-/* 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
deleted file mode 100644
index 44b4b25e1..000000000
--- a/mdk-stage1/slang/slimport.c
+++ /dev/null
@@ -1,281 +0,0 @@
-/* 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
deleted file mode 100644
index d60a4423e..000000000
--- a/mdk-stage1/slang/slinclud.h
+++ /dev/null
@@ -1,26 +0,0 @@
-#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
deleted file mode 100644
index a66b9d6d2..000000000
--- a/mdk-stage1/slang/slintall.c
+++ /dev/null
@@ -1,27 +0,0 @@
-/* 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
deleted file mode 100644
index 06b8fd6ff..000000000
--- a/mdk-stage1/slang/slistruc.c
+++ /dev/null
@@ -1,218 +0,0 @@
-/* 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
deleted file mode 100644
index dff65433e..000000000
--- a/mdk-stage1/slang/slkeymap.c
+++ /dev/null
@@ -1,596 +0,0 @@
-/* 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
deleted file mode 100644
index 524dc80fa..000000000
--- a/mdk-stage1/slang/slkeypad.c
+++ /dev/null
@@ -1,163 +0,0 @@
-/* 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
deleted file mode 100644
index c4ae03b83..000000000
--- a/mdk-stage1/slang/sllimits.h
+++ /dev/null
@@ -1,64 +0,0 @@
-/* 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
deleted file mode 100644
index be4ed6cae..000000000
--- a/mdk-stage1/slang/slmalloc.c
+++ /dev/null
@@ -1,165 +0,0 @@
-/* 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, (void*)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, (void*)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, (void*)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
deleted file mode 100644
index 1d61e14d3..000000000
--- a/mdk-stage1/slang/slmath.c
+++ /dev/null
@@ -1,565 +0,0 @@
-/* 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
deleted file mode 100644
index 1417bc549..000000000
--- a/mdk-stage1/slang/slmemchr.c
+++ /dev/null
@@ -1,47 +0,0 @@
-/* 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
deleted file mode 100644
index c5ed50095..000000000
--- a/mdk-stage1/slang/slmemcmp.c
+++ /dev/null
@@ -1,76 +0,0 @@
-/* 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
deleted file mode 100644
index e8665e4c6..000000000
--- a/mdk-stage1/slang/slmemcpy.c
+++ /dev/null
@@ -1,49 +0,0 @@
-/* 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
deleted file mode 100644
index 3851663c5..000000000
--- a/mdk-stage1/slang/slmemset.c
+++ /dev/null
@@ -1,39 +0,0 @@
-/* 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
deleted file mode 100644
index ccc7a9bdf..000000000
--- a/mdk-stage1/slang/slmisc.c
+++ /dev/null
@@ -1,330 +0,0 @@
-/* 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
deleted file mode 100644
index 174ba7c81..000000000
--- a/mdk-stage1/slang/slnspace.c
+++ /dev/null
@@ -1,242 +0,0 @@
-/* -*- 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
deleted file mode 100644
index 644931e81..000000000
--- a/mdk-stage1/slang/slospath.c
+++ /dev/null
@@ -1,73 +0,0 @@
-/* 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
deleted file mode 100644
index 53ef63643..000000000
--- a/mdk-stage1/slang/slpack.c
+++ /dev/null
@@ -1,785 +0,0 @@
-/* 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
deleted file mode 100644
index bc709d1fb..000000000
--- a/mdk-stage1/slang/slparse.c
+++ /dev/null
@@ -1,1970 +0,0 @@
-/* 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
deleted file mode 100644
index 831bd34df..000000000
--- a/mdk-stage1/slang/slpath.c
+++ /dev/null
@@ -1,344 +0,0 @@
-/* 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
deleted file mode 100644
index 33799e574..000000000
--- a/mdk-stage1/slang/slposdir.c
+++ /dev/null
@@ -1,1057 +0,0 @@
-/* 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
deleted file mode 100644
index ab1e9f689..000000000
--- a/mdk-stage1/slang/slposio.c
+++ /dev/null
@@ -1,568 +0,0 @@
-/* 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
deleted file mode 100644
index 358eeb874..000000000
--- a/mdk-stage1/slang/slprepr.c
+++ /dev/null
@@ -1,427 +0,0 @@
-/* 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
deleted file mode 100644
index 8b266f28f..000000000
--- a/mdk-stage1/slang/slproc.c
+++ /dev/null
@@ -1,155 +0,0 @@
-/* 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
deleted file mode 100644
index 6592a5a63..000000000
--- a/mdk-stage1/slang/slregexp.c
+++ /dev/null
@@ -1,935 +0,0 @@
-/* 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
deleted file mode 100644
index 1874be0bb..000000000
--- a/mdk-stage1/slang/slrline.c
+++ /dev/null
@@ -1,836 +0,0 @@
-/* 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
deleted file mode 100644
index 5bd93ff41..000000000
--- a/mdk-stage1/slang/slscanf.c
+++ /dev/null
@@ -1,718 +0,0 @@
-/* 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
deleted file mode 100644
index 358296116..000000000
--- a/mdk-stage1/slang/slscroll.c
+++ /dev/null
@@ -1,450 +0,0 @@
-/* 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
deleted file mode 100644
index a9a427a7d..000000000
--- a/mdk-stage1/slang/slsearch.c
+++ /dev/null
@@ -1,239 +0,0 @@
-/* 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
deleted file mode 100644
index 30707dea5..000000000
--- a/mdk-stage1/slang/slsignal.c
+++ /dev/null
@@ -1,336 +0,0 @@
-/* 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
deleted file mode 100644
index 088557f27..000000000
--- a/mdk-stage1/slang/slsmg.c
+++ /dev/null
@@ -1,1584 +0,0 @@
-/* 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
deleted file mode 100644
index b05dfcddb..000000000
--- a/mdk-stage1/slang/slstd.c
+++ /dev/null
@@ -1,724 +0,0 @@
-/* -*- 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
deleted file mode 100644
index 05db1af77..000000000
--- a/mdk-stage1/slang/slstdio.c
+++ /dev/null
@@ -1,1050 +0,0 @@
-/* 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
deleted file mode 100644
index 529c41827..000000000
--- a/mdk-stage1/slang/slstring.c
+++ /dev/null
@@ -1,546 +0,0 @@
-/* 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
deleted file mode 100644
index a57ef6389..000000000
--- a/mdk-stage1/slang/slstrops.c
+++ /dev/null
@@ -1,1686 +0,0 @@
-/* -*- 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
deleted file mode 100644
index 33d182373..000000000
--- a/mdk-stage1/slang/slstruct.c
+++ /dev/null
@@ -1,932 +0,0 @@
-/* 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
deleted file mode 100644
index f9c64f0b2..000000000
--- a/mdk-stage1/slang/sltermin.c
+++ /dev/null
@@ -1,1155 +0,0 @@
-/* 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
deleted file mode 100644
index 14fc6ec16..000000000
--- a/mdk-stage1/slang/sltime.c
+++ /dev/null
@@ -1,310 +0,0 @@
-/* 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
deleted file mode 100644
index c9852e68a..000000000
--- a/mdk-stage1/slang/sltoken.c
+++ /dev/null
@@ -1,1702 +0,0 @@
-/* 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
deleted file mode 100644
index 05b8741b1..000000000
--- a/mdk-stage1/slang/sltypes.c
+++ /dev/null
@@ -1,966 +0,0 @@
-/* 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
deleted file mode 100644
index 636c1bb90..000000000
--- a/mdk-stage1/slang/slutty.c
+++ /dev/null
@@ -1,596 +0,0 @@
-/* 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
deleted file mode 100644
index 3f8a4dffa..000000000
--- a/mdk-stage1/slang/slxstrng.c
+++ /dev/null
@@ -1,43 +0,0 @@
-/* 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);
-}