diff options
Diffstat (limited to 'mdk-stage1')
86 files changed, 52622 insertions, 13 deletions
diff --git a/mdk-stage1/Makefile b/mdk-stage1/Makefile index 9a3ecae43..96eade486 100644 --- a/mdk-stage1/Makefile +++ b/mdk-stage1/Makefile @@ -47,22 +47,17 @@ INITOBJS = $(subst .c,.o,$(INITSRC)) #- frontends NEWT_FRONTEND_SRC = newt-frontend.c -NEWT_FRONTEND_LIBS = /usr/lib/libnewt.a /usr/lib/libslang.a +GLIBC_NEWT_FRONTEND_LIBS = newt/libnewt.a slang/libslang.a +DIETLIBC_NEWT_FRONTEND_LIBS = $(subst .a,-DIET.a,$(GLIBC_NEWT_FRONTEND_LIBS)) STDIO_FRONTEND_SRC = stdio-frontend.c -STDIO_FRONTEND_LIBS = +GLIBC_STDIO_FRONTEND_LIBS = +DIETLIBC_STDIO_FRONTEND_LIBS = FRONTEND_OBJS = $(subst .c,.o,$($(F)_FRONTEND_SRC)) -FRONTEND_LIBS = $($(F)_FRONTEND_LIBS) -FRONTEND_LINK = $(FRONTEND_OBJS) $(FRONTEND_LIBS) - -ifeq (DIETLIBC, $(L)) -ifeq (NEWT, $(F)) -FRONTEND_LINK = $(subst .c,.o,$(STDIO_FRONTEND_SRC)) $(STDIO_FRONTEND_LIBS) -endif -endif +FRONTEND_LINK = $(FRONTEND_OBJS) $($(L)_$(F)_FRONTEND_LIBS) ifeq (i386, $(ARCH)) INSMOD = insmod-busybox @@ -71,7 +66,7 @@ INSMOD = insmod-modutils endif GLIBC_STAGE1_OWN_LIBS = $(INSMOD)/libinsmod.a mar/libmar.a bzlib/libbzlib.a -DIETLIBC_STAGE1_OWN_LIBS = $(INSMOD)/libinsmod-DIET.a mar/libmar-DIET.a bzlib/libbzlib-DIET.a +DIETLIBC_STAGE1_OWN_LIBS = $(subst .a,-DIET.a,$(GLIBC_STAGE1_OWN_LIBS)) STAGE1_OWN_LIBS = $($(L)_STAGE1_OWN_LIBS) @@ -125,7 +120,7 @@ BINS += stage1-cdrom stage1-disk stage1-network endif -DIRS = dietlibc mar pci-resource bzlib $(INSMOD) +DIRS = dietlibc mar pci-resource bzlib $(INSMOD) slang newt ifeq (i386,$(ARCH)) DIRS += pcmcia endif diff --git a/mdk-stage1/newt-frontend.c b/mdk-stage1/newt-frontend.c index 85f56ec10..867a6d7f1 100644 --- a/mdk-stage1/newt-frontend.c +++ b/mdk-stage1/newt-frontend.c @@ -33,7 +33,7 @@ #include <sys/time.h> #include "stage1.h" #include "log.h" -#include "newt.h" +#include "newt/newt.h" #include "frontend.h" diff --git a/mdk-stage1/newt/Makefile b/mdk-stage1/newt/Makefile new file mode 100644 index 000000000..c4e6a7207 --- /dev/null +++ b/mdk-stage1/newt/Makefile @@ -0,0 +1,49 @@ + #****************************************************************************** + # + # Guillaume Cottenceau (gc@mandrakesoft.com) + # + # Copyright 2000 MandrakeSoft + # + # This software may be freely redistributed under the terms of the GNU + # public license. + # + # You should have received a copy of the GNU General Public License + # along with this program; if not, write to the Free Software + # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + # + #***************************************************************************** + +top_dir = .. + +include $(top_dir)/Makefile.common + + +all: libnewt.a libnewt-DIET.a + +clean: + rm -f *.o *.a + +FLAGS = -Wall -Werror -Os -fomit-frame-pointer -DVERSION=\"0.50.19\" -c + +INCS = -I../slang + + +OBJS = newt.o button.o form.o checkbox.o entry.o label.o listbox.o scrollbar.o textbox.o scale.o grid.o windows.o buttonbar.o checkboxtree.o +OBJS-DIET = $(subst .o,-DIET.o,$(OBJS)) + + +libnewt.a: $(OBJS) + ar -cru $@ $^ + ranlib $@ + +libnewt-DIET.a: $(OBJS-DIET) + ar -cru $@ $^ + ranlib $@ + + +$(OBJS): %.o: %.c + gcc $(FLAGS) $(GLIBC_INCLUDES) $(INCS) -c $< -o $@ + +$(OBJS-DIET): %-DIET.o: %.c + gcc $(FLAGS) $(DIETLIBC_INCLUDES) $(INCS) -c $< -o $@ + diff --git a/mdk-stage1/newt/button.c b/mdk-stage1/newt/button.c new file mode 100644 index 000000000..1ff360dc5 --- /dev/null +++ b/mdk-stage1/newt/button.c @@ -0,0 +1,190 @@ +#include <slang.h> +#include <stdlib.h> +#include <string.h> + +#include "newt.h" +#include "newt_pr.h" + +struct button { + char * text; + int compact; +}; + +static void buttonDrawIt(newtComponent co, int active, int pushed); +static void buttonDrawText(newtComponent co, int active, int pushed); + +static void buttonDraw(newtComponent c); +static void buttonDestroy(newtComponent co); +static struct eventResult buttonEvent(newtComponent c, + struct event ev); +static void buttonPlace(newtComponent co, int newLeft, int newTop); + +static struct componentOps buttonOps = { + buttonDraw, + buttonEvent, + buttonDestroy, + buttonPlace, + newtDefaultMappedHandler, +} ; + +static newtComponent createButton(int left, int row, const char * text, int compact) { + newtComponent co; + struct button * bu; + + co = malloc(sizeof(*co)); + bu = malloc(sizeof(struct button)); + co->data = bu; + + bu->text = strdup(text); + bu->compact = compact; + co->ops = &buttonOps; + + if (bu->compact) { + co->height = 1; + co->width = strlen(text) + 3; + } else { + co->height = 4; + co->width = strlen(text) + 5; + } + + co->top = row; + co->left = left; + co->takesFocus = 1; + co->isMapped = 0; + + newtGotorc(co->top, co->left); + + return co; +} + +newtComponent newtCompactButton(int left, int row, const char * text) { + return createButton(left, row, text, 1); +} + +newtComponent newtButton(int left, int row, const char * text) { + return createButton(left, row, text, 0); +} + +static void buttonDestroy(newtComponent co) { + struct button * bu = co->data; + + free(bu->text); + free(bu); + free(co); +} + +static void buttonPlace(newtComponent co, int newLeft, int newTop) { + co->top = newTop; + co->left = newLeft; + + newtGotorc(co->top, co->left); +} + +static void buttonDraw(newtComponent co) { + buttonDrawIt(co, 0, 0); +} + +static void buttonDrawIt(newtComponent co, int active, int pushed) { + struct button * bu = co->data; + + if (!co->isMapped) return; + + SLsmg_set_color(NEWT_COLORSET_BUTTON); + + if (bu->compact) { + if (active) + SLsmg_set_color(NEWT_COLORSET_COMPACTBUTTON); + else + SLsmg_set_color(NEWT_COLORSET_BUTTON); + newtGotorc(co->top+ pushed, co->left + 1 + pushed); + SLsmg_write_char('<'); + SLsmg_write_string(bu->text); + SLsmg_write_char('>'); + } else { + if (pushed) { + SLsmg_set_color(NEWT_COLORSET_BUTTON); + newtDrawBox(co->left + 1, co->top + 1, co->width - 1, 3, 0); + + SLsmg_set_color(NEWT_COLORSET_WINDOW); + newtClearBox(co->left, co->top, co->width, 1); + newtClearBox(co->left, co->top, 1, co->height); + } else { + newtDrawBox(co->left, co->top, co->width - 1, 3, 1); + } + + buttonDrawText(co, active, pushed); + } +} + +static void buttonDrawText(newtComponent co, int active, int pushed) { + struct button * bu = co->data; + + if (pushed) pushed = 1; + + if (active) + SLsmg_set_color(NEWT_COLORSET_ACTBUTTON); + else + SLsmg_set_color(NEWT_COLORSET_BUTTON); + + newtGotorc(co->top + 1 + pushed, co->left + 1 + pushed); + SLsmg_write_char(' '); + SLsmg_write_string(bu->text); + SLsmg_write_char(' '); +} + +static struct eventResult buttonEvent(newtComponent co, + struct event ev) { + struct eventResult er; + struct button * bu = co->data; + + if (ev.when == EV_NORMAL) { + switch (ev.event) { + case EV_FOCUS: + buttonDrawIt(co, 1, 0); + er.result = ER_SWALLOWED; + break; + + case EV_UNFOCUS: + buttonDrawIt(co, 0, 0); + er.result = ER_SWALLOWED; + break; + + case EV_KEYPRESS: + if (ev.u.key == ' ' || ev.u.key == '\r') { + if (!bu->compact) { + /* look pushed */ + buttonDrawIt(co, 1, 1); + newtRefresh(); + newtDelay(150000); + buttonDrawIt(co, 1, 0); + newtRefresh(); + newtDelay(150000); + } + + er.result = ER_EXITFORM; + } else + er.result = ER_IGNORED; + break; + case EV_MOUSE: + if (ev.u.mouse.type == MOUSE_BUTTON_DOWN && + co->top <= ev.u.mouse.y && + co->top + co->height - !bu->compact > ev.u.mouse.y && + co->left <= ev.u.mouse.x && + co->left + co->width - !bu->compact > ev.u.mouse.x) { + if (!bu->compact) { + buttonDrawIt(co, 1, 1); + newtRefresh(); + newtDelay(150000); + buttonDrawIt(co, 1, 0); + newtRefresh(); + newtDelay(150000); + } + er.result = ER_EXITFORM; + } + break; + } + } else + er.result = ER_IGNORED; + + return er; +} diff --git a/mdk-stage1/newt/buttonbar.c b/mdk-stage1/newt/buttonbar.c new file mode 100644 index 000000000..45473c9d2 --- /dev/null +++ b/mdk-stage1/newt/buttonbar.c @@ -0,0 +1,46 @@ +#include <stdarg.h> + +#include "newt.h" + +/* if they try and pack more then 50 buttons, screw 'em */ +newtGrid newtButtonBarv(char * button1, newtComponent * b1comp, va_list args) { + newtGrid grid; + struct buttonInfo { + char * name; + newtComponent * compPtr; + } buttons[50]; + int num; + int i; + + buttons[0].name = button1, buttons[0].compPtr = b1comp, num = 1; + while (1) { + buttons[num].name = va_arg(args, char *); + if (!buttons[num].name) break; + buttons[num].compPtr = va_arg(args, newtComponent *); + num++; + } + + grid = newtCreateGrid(num, 1); + + for (i = 0; i < num; i++) { + *buttons[i].compPtr = newtButton(-1, -1, buttons[i].name); + newtGridSetField(grid, i, 0, NEWT_GRID_COMPONENT, + *buttons[i].compPtr, + num ? 1 : 0, 0, 0, 0, 0, 0); + } + + return grid; +} + +newtGrid newtButtonBar(char * button1, newtComponent * b1comp, ...) { + va_list args; + newtGrid grid; + + va_start(args, b1comp); + + grid = newtButtonBarv(button1, b1comp, args); + + va_end(args); + + return grid; +} diff --git a/mdk-stage1/newt/checkbox.c b/mdk-stage1/newt/checkbox.c new file mode 100644 index 000000000..eee514c98 --- /dev/null +++ b/mdk-stage1/newt/checkbox.c @@ -0,0 +1,290 @@ +#include <slang.h> +#include <stdlib.h> +#include <string.h> + +#include "newt.h" +#include "newt_pr.h" + +enum type { CHECK, RADIO }; + +struct checkbox { + char * text; + char * seq; + char * result; + newtComponent prevButton, lastButton; + enum type type; + char value; + int active, inactive; + const void * data; + int flags; + int hasFocus; +}; + +static void makeActive(newtComponent co); + +static void cbDraw(newtComponent c); +static void cbDestroy(newtComponent co); +struct eventResult cbEvent(newtComponent co, struct event ev); + +static struct componentOps cbOps = { + cbDraw, + cbEvent, + cbDestroy, + newtDefaultPlaceHandler, + newtDefaultMappedHandler, +} ; + +newtComponent newtRadiobutton(int left, int top, const char * text, int isDefault, + newtComponent prevButton) { + newtComponent co; + newtComponent curr; + struct checkbox * rb; + char initialValue; + + if (isDefault) + initialValue = '*'; + else + initialValue = ' '; + + co = newtCheckbox(left, top, text, initialValue, " *", NULL); + rb = co->data; + rb->type = RADIO; + + rb->prevButton = prevButton; + + for (curr = co; curr; curr = rb->prevButton) { + rb = curr->data; + rb->lastButton = co; + } + + return co; +} + +newtComponent newtRadioGetCurrent(newtComponent setMember) { + struct checkbox * rb = setMember->data; + + setMember = rb->lastButton; + rb = setMember->data; + + while (rb && rb->value != '*') { + setMember = rb->prevButton; + if (!setMember) + return NULL; + rb = setMember->data; + } + + return setMember; +} + +char newtCheckboxGetValue(newtComponent co) { + struct checkbox * cb = co->data; + + return cb->value; +} + +void newtCheckboxSetValue(newtComponent co, char value) { + struct checkbox * cb = co->data; + + *cb->result = value; + cbDraw(co); +} + +newtComponent newtCheckbox(int left, int top, const char * text, char defValue, + const char * seq, char * result) { + newtComponent co; + struct checkbox * cb; + + if (!seq) seq = " *"; + + co = malloc(sizeof(*co)); + cb = malloc(sizeof(struct checkbox)); + co->data = cb; + cb->flags = 0; + if (result) + cb->result = result; + else + cb->result = &cb->value; + + cb->text = strdup(text); + cb->seq = strdup(seq); + cb->type = CHECK; + cb->hasFocus = 0; + cb->inactive = COLORSET_CHECKBOX; + cb->active = COLORSET_ACTCHECKBOX; + defValue ? (*cb->result = defValue) : (*cb->result = cb->seq[0]); + + co->ops = &cbOps; + + co->callback = NULL; + co->height = 1; + co->width = strlen(text) + 4; + co->top = top; + co->left = left; + co->takesFocus = 1; + + return co; +} + +void newtCheckboxSetFlags(newtComponent co, int flags, enum newtFlagsSense sense) { + struct checkbox * cb = co->data; + int row, col; + + cb->flags = newtSetFlags(cb->flags, flags, sense); + + if (!(cb->flags & NEWT_FLAG_DISABLED)) + co->takesFocus = 1; + else + co->takesFocus = 0; + + newtGetrc(&row, &col); + cbDraw(co); + newtGotorc(row, col); +} + +static void cbDraw(newtComponent c) { + struct checkbox * cb = c->data; + + if (c->top == -1 || !c->isMapped) return; + + if (cb->flags & NEWT_FLAG_DISABLED) { + cb->inactive = NEWT_COLORSET_DISENTRY; + cb->active = NEWT_COLORSET_DISENTRY; + } else { + cb->inactive = COLORSET_CHECKBOX; + cb->active = COLORSET_ACTCHECKBOX; + } + + SLsmg_set_color(cb->inactive); + + newtGotorc(c->top, c->left); + + switch (cb->type) { + case RADIO: + SLsmg_write_string("( ) "); + break; + + case CHECK: + SLsmg_write_string("[ ] "); + break; + + default: + break; + } + + SLsmg_write_string(cb->text); + + if (cb->hasFocus) + SLsmg_set_color(cb->active); + + newtGotorc(c->top, c->left + 1); + SLsmg_write_char(*cb->result); +} + +static void cbDestroy(newtComponent co) { + struct checkbox * cb = co->data; + + free(cb->text); + free(cb->seq); + free(cb); + free(co); +} + +struct eventResult cbEvent(newtComponent co, struct event ev) { + struct checkbox * cb = co->data; + struct eventResult er; + const char * cur; + + if (ev.when == EV_NORMAL) { + switch (ev.event) { + case EV_FOCUS: + cb->hasFocus = 1; + cbDraw(co); + er.result = ER_SWALLOWED; + break; + + case EV_UNFOCUS: + cb->hasFocus = 0; + cbDraw(co); + er.result = ER_SWALLOWED; + break; + + case EV_KEYPRESS: + if (ev.u.key == ' ') { + if (cb->type == RADIO) { + makeActive(co); + } else if (cb->type == CHECK) { + cur = strchr(cb->seq, *cb->result); + if (!cur) + *cb->result = *cb->seq; + else { + cur++; + if (! *cur) + *cb->result = *cb->seq; + else + *cb->result = *cur; + } + cbDraw(co); + er.result = ER_SWALLOWED; + + if (co->callback) + co->callback(co, co->callbackData); + } else { + er.result = ER_IGNORED; + } + } else if(ev.u.key == NEWT_KEY_ENTER) { + er.result = ER_IGNORED; + } else { + er.result = ER_IGNORED; + } + break; + case EV_MOUSE: + if (ev.u.mouse.type == MOUSE_BUTTON_DOWN) { + if (cb->type == RADIO) { + makeActive(co); + } else if (cb->type == CHECK) { + cur = strchr(cb->seq, *cb->result); + if (!cur) + *cb->result = *cb->seq; + else { + cur++; + if (! *cur) + *cb->result = *cb->seq; + else + *cb->result = *cur; + } + cbDraw(co); + er.result = ER_SWALLOWED; + + if (co->callback) + co->callback(co, co->callbackData); + } + } + } + } else + er.result = ER_IGNORED; + + return er; +} + +static void makeActive(newtComponent co) { + struct checkbox * cb = co->data; + struct checkbox * rb; + newtComponent curr; + + /* find the one that's turned off */ + curr = cb->lastButton; + rb = curr->data; + while (curr && rb->value == rb->seq[0]) { + curr = rb->prevButton; + if (curr) rb = curr->data; + } + if (curr) { + rb->value = rb->seq[0]; + cbDraw(curr); + } + cb->value = cb->seq[1]; + cbDraw(co); + + if (co->callback) + co->callback(co, co->callbackData); +} diff --git a/mdk-stage1/newt/checkboxtree.c b/mdk-stage1/newt/checkboxtree.c new file mode 100644 index 000000000..b56bd1e9f --- /dev/null +++ b/mdk-stage1/newt/checkboxtree.c @@ -0,0 +1,714 @@ +#include <slang.h> +#include <stdlib.h> +#include <string.h> + +#include "newt.h" +#include "newt_pr.h" + +struct items { + char * text; + const void *data; + unsigned char selected; + struct items *next; + struct items *prev; + struct items *branch; + int flags; + int depth; +}; + +struct CheckboxTree { + newtComponent sb; + int curWidth; /* size of text w/o scrollbar or border*/ + int curHeight; /* size of text w/o border */ + struct items * itemlist; + struct items ** flatList, ** currItem, ** firstItem; + int flatCount; + int flags; + int pad; + char * seq; + char * result; +}; + +static void ctDraw(newtComponent c); +static void ctDestroy(newtComponent co); +static void ctPlace(newtComponent co, int newLeft, int newTop); +struct eventResult ctEvent(newtComponent co, struct event ev); +static void ctMapped(newtComponent co, int isMapped); +static struct items * findItem(struct items * items, const void * data); +static void buildFlatList(newtComponent co); +static void doBuildFlatList(struct CheckboxTree * ct, struct items * item); +enum countWhat { COUNT_EXPOSED=0, COUNT_SELECTED=1 }; +static int countItems(struct items * item, enum countWhat justExposed); + +static struct componentOps ctOps = { + ctDraw, + ctEvent, + ctDestroy, + ctPlace, + ctMapped, +} ; + +static int countItems(struct items * item, enum countWhat what) { + int count = 0; + + while (item) { + if ((!item->branch && item->selected == what) || (what == COUNT_EXPOSED)) + count++; + if (item->branch || (what == COUNT_EXPOSED && item->selected)) + count += countItems(item->branch, what); + item = item->next; + } + + return count; +} + +static void doBuildFlatList(struct CheckboxTree * ct, struct items * item) { + while (item) { + ct->flatList[ct->flatCount++] = item; + if (item->branch && item->selected) doBuildFlatList(ct, item->branch); + item = item->next; + } +} + +static void buildFlatList(newtComponent co) { + struct CheckboxTree * ct = co->data; + + if (ct->flatList) free(ct->flatList); + ct->flatCount = countItems(ct->itemlist, COUNT_EXPOSED); + + ct->flatList = malloc(sizeof(*ct->flatList) * (ct->flatCount+1)); + ct->flatCount = 0; + doBuildFlatList(ct, ct->itemlist); + ct->flatList[ct->flatCount] = NULL; +} + +int newtCheckboxTreeAddItem(newtComponent co, + const char * text, const void * data, + int flags, int index, ...) { + va_list argList; + int numIndexes; + int * indexes; + int i; + + va_start(argList, index); + numIndexes = 0; + i = index; + while (i != NEWT_ARG_LAST) { + numIndexes++; + i = va_arg(argList, int); + } + + va_end(argList); + + indexes = alloca(sizeof(*indexes) * (numIndexes + 1)); + va_start(argList, index); + numIndexes = 0; + i = index; + va_start(argList, index); + while (i != NEWT_ARG_LAST) { + indexes[numIndexes++] = i; + i = va_arg(argList, int); + } + va_end(argList); + + indexes[numIndexes++] = NEWT_ARG_LAST; + + return newtCheckboxTreeAddArray(co, text, data, flags, indexes); +} + +static int doFindItemPath(struct items * items, void * data, int * path, + int * len) { + int where = 0; + + while (items) { + if (items->data == data) { + if (path) path[items->depth] = where; + if (len) *len = items->depth + 1; + return 1; + } + + if (items->branch && doFindItemPath(items->branch, data, path, len)) { + if (path) path[items->depth] = where; + return 1; + } + + items = items->next; + where++; + } + + return 0; +} + +int * newtCheckboxTreeFindItem(newtComponent co, void * data) { + int len; + int * path; + struct CheckboxTree * ct = co->data; + + if (!doFindItemPath(ct->itemlist, data, NULL, &len)) return NULL; + + path = malloc(sizeof(*path) * (len + 1)); + doFindItemPath(ct->itemlist, data, path, NULL); + path[len] = NEWT_ARG_LAST; + + return path; +} + +int newtCheckboxTreeAddArray(newtComponent co, + const char * text, const void * data, + int flags, int * indexes) { + struct items * curList, * newNode, * item = NULL; + struct items ** listPtr = NULL; + int i, index, numIndexes; + struct CheckboxTree * ct = co->data; + + numIndexes = 0; + while (indexes[numIndexes] != NEWT_ARG_LAST) numIndexes++; + + if (!ct->itemlist) { + if (numIndexes > 1) return -1; + + ct->itemlist = malloc(sizeof(*ct->itemlist)); + item = ct->itemlist; + item->prev = NULL; + item->next = NULL; + } else { + curList = ct->itemlist; + listPtr = &ct->itemlist; + + i = 0; + index = indexes[i]; + while (i < numIndexes) { + item = curList; + + if (index == NEWT_ARG_APPEND) { + item = NULL; + } else { + while (index && item) + item = item->next, index--; + } + + i++; + if (i < numIndexes) { + curList = item->branch; + listPtr = &item->branch; + if (!curList && (i + 1 != numIndexes)) return -1; + + index = indexes[i]; + } + } + + if (!curList) { /* create a new branch */ + item = malloc(sizeof(*curList->prev)); + item->next = item->prev = NULL; + *listPtr = item; + } else if (!item) { /* append to end */ + item = curList; + while (item->next) item = item->next; + item->next = malloc(sizeof(*curList->prev)); + item->next->prev = item; + item = item->next; + item->next = NULL; + } else { + newNode = malloc(sizeof(*newNode)); + newNode->prev = item->prev; + newNode->next = item; + + if (item->prev) item->prev->next = newNode; + item->prev = newNode; + item = newNode; + if (!item->prev) *listPtr = item; + } + } + + item->text = strdup(text); + item->data = data; + if (flags & NEWT_FLAG_SELECTED) { + item->selected = 1; + } else { + item->selected = 0; + } + item->flags = flags; + item->branch = NULL; + item->depth = numIndexes - 1; + + i = 4 + (3 * item->depth); + + if ((strlen(text) + i + ct->pad) > co->width) { + co->width = strlen(text) + i + ct->pad; + } + + return 0; +} + +static struct items * findItem(struct items * items, const void * data) { + struct items * i; + + while (items) { + if (items->data == data) return items; + if (items->branch) { + i = findItem(items->branch, data); + if (i) return i; + } + + items = items->next; + } + + return NULL; +} + +static void listSelected(struct items * items, int * num, const void ** list, int seqindex) { + while (items) { + if ((seqindex ? items->selected==seqindex : items->selected) && !items->branch) + list[(*num)++] = (void *) items->data; + if (items->branch) + listSelected(items->branch, num, list, seqindex); + items = items->next; + } +} + +const void ** newtCheckboxTreeGetSelection(newtComponent co, int *numitems) +{ + return newtCheckboxTreeGetMultiSelection(co, numitems, 0); +} + +const void ** newtCheckboxTreeGetMultiSelection(newtComponent co, int *numitems, char seqnum) +{ + struct CheckboxTree * ct; + const void **retval; + int seqindex=0; + + if(!co || !numitems) return NULL; + + ct = co->data; + + if (seqnum) { + while( ct->seq[seqindex] && ( ct->seq[seqindex] != seqnum )) seqindex++; + } else { + seqindex = 0; + } + + *numitems = countItems(ct->itemlist, (seqindex ? seqindex : COUNT_SELECTED)); + if (!*numitems) return NULL; + + retval = malloc(*numitems * sizeof(void *)); + *numitems = 0; + listSelected(ct->itemlist, numitems, retval, seqindex); + + return retval; +} + +newtComponent newtCheckboxTree(int left, int top, int height, int flags) { + return newtCheckboxTreeMulti(left, top, height, NULL, flags); +} + +newtComponent newtCheckboxTreeMulti(int left, int top, int height, char *seq, int flags) { + newtComponent co; + struct CheckboxTree * ct; + + co = malloc(sizeof(*co)); + ct = malloc(sizeof(struct CheckboxTree)); + co->callback = NULL; + co->data = ct; + co->ops = &ctOps; + co->takesFocus = 1; + co->height = height; + co->width = 0; + co->isMapped = 0; + ct->itemlist = NULL; + ct->firstItem = NULL; + ct->currItem = NULL; + ct->flatList = NULL; + if (seq) + ct->seq = strdup(seq); + else + ct->seq = strdup(" *"); + if (flags & NEWT_FLAG_SCROLL) { + ct->sb = newtVerticalScrollbar(left, top, height, + COLORSET_LISTBOX, COLORSET_ACTLISTBOX); + ct->pad = 2; + } else { + ct->sb = NULL; + ct->pad = 0; + } + + return co; +} + +static void ctMapped(newtComponent co, int isMapped) { + struct CheckboxTree * ct = co->data; + + co->isMapped = isMapped; + if (ct->sb) + ct->sb->ops->mapped(ct->sb, isMapped); +} + +static void ctPlace(newtComponent co, int newLeft, int newTop) { + struct CheckboxTree * ct = co->data; + + co->top = newTop; + co->left = newLeft; + + if (ct->sb) + ct->sb->ops->place(ct->sb, co->left + co->width - 1, co->top); +} + +int ctSetItem(newtComponent co, struct items *item, enum newtFlagsSense sense) +{ + struct CheckboxTree * ct = co->data; + struct items * currItem; + struct items * firstItem; + + if (!item) + return 1; + + switch(sense) { + case NEWT_FLAGS_RESET: + item->selected = 0; + break; + case NEWT_FLAGS_SET: + item->selected = 1; + break; + case NEWT_FLAGS_TOGGLE: + if (item->branch) + item->selected = !item->selected; + else { + item->selected++; + if (item->selected==strlen(ct->seq)) + item->selected = 0; + } + break; + } + + if (item->branch) { + currItem = *ct->currItem; + firstItem = *ct->firstItem; + + buildFlatList(co); + + ct->currItem = ct->flatList; + while (*ct->currItem != currItem) ct->currItem++; + + ct->firstItem = ct->flatList; + if (ct->flatCount > co->height) { + struct items ** last = ct->flatList + ct->flatCount - co->height; + while (*ct->firstItem != firstItem && ct->firstItem != last) + ct->firstItem++; + } + } + + return 0; +} + +static void ctSetItems(struct items *item, int selected) +{ + for (; item; item = item->next) { + if (!item->branch) + item->selected = selected; + else + ctSetItems(item->branch, selected); + } +} + +static void ctDraw(newtComponent co) { + struct CheckboxTree * ct = co->data; + struct items ** item; + int i, j; + char * spaces = NULL; + int currRow = -1; + + if (!co->isMapped) return ; + + if (!ct->firstItem) { + buildFlatList(co); + ct->firstItem = ct->currItem = ct->flatList; + } + + item = ct->firstItem; + + i = 0; + while (*item && i < co->height) { + newtGotorc(co->top + i, co->left); + if (*item == *ct->currItem) { + SLsmg_set_color(NEWT_COLORSET_ACTLISTBOX); + currRow = co->top + i; + } else + SLsmg_set_color(NEWT_COLORSET_LISTBOX); + + for (j = 0; j < (*item)->depth; j++) + SLsmg_write_string(" "); + + if ((*item)->branch) { + if ((*item)->selected) + SLsmg_write_string("<-> "); + else + SLsmg_write_string("<+> "); + } else { + char tmp[5]; + snprintf(tmp,5,"[%c] ",ct->seq[(*item)->selected]); + SLsmg_write_string(tmp); + } + + SLsmg_write_nstring((*item)->text, co->width - 4 - + (3 * (*item)->depth)); + item++; + i++; + } + + /* There could be empty lines left (i.e. if the user closes an expanded + list which is the last thing in the tree, and whose elements are + displayed at the bottom of the screen */ + if (i < co->height) { + spaces = alloca(co->width); + memset(spaces, ' ', co->width); + SLsmg_set_color(NEWT_COLORSET_LISTBOX); + } + while (i < co->height) { + newtGotorc(co->top + i, co->left); + SLsmg_write_nstring(spaces, co->width); + i++; + } + + if(ct->sb) { + newtScrollbarSet(ct->sb, ct->currItem - ct->flatList, + ct->flatCount - 1); + ct->sb->ops->draw(ct->sb); + } + + newtGotorc(currRow, co->left + 1); +} + +static void ctDestroy(newtComponent co) { + struct CheckboxTree * ct = co->data; + struct items * item, * nextitem; + + nextitem = item = ct->itemlist; + + while (item != NULL) { + nextitem = item->next; + free(item->text); + free(item); + item = nextitem; + } + + free(ct->seq); + free(ct); + free(co); +} + +struct eventResult ctEvent(newtComponent co, struct event ev) { + struct CheckboxTree * ct = co->data; + struct eventResult er; + struct items ** listEnd, ** lastItem; + int key, selnum = 1; + + er.result = ER_IGNORED; + + if(ev.when == EV_EARLY || ev.when == EV_LATE) { + return er; + } + + switch(ev.event) { + case EV_KEYPRESS: + key = ev.u.key; + if (key == (char) key && key != ' ') { + for (selnum = 0; ct->seq[selnum]; selnum++) + if (key == ct->seq[selnum]) + break; + if (!ct->seq[selnum]) + switch (key) { + case '-': selnum = 0; break; + case '+': + case '*': selnum = 1; break; + } + if (ct->seq[selnum]) + key = '*'; + } + switch(key) { + case ' ': + case NEWT_KEY_ENTER: + ctSetItem(co, *ct->currItem, NEWT_FLAGS_TOGGLE); + er.result = ER_SWALLOWED; + if (!(*ct->currItem)->branch || (*ct->currItem)->selected) + key = NEWT_KEY_DOWN; + else + key = '*'; + break; + case '*': + if ((*ct->currItem)->branch) { + ctSetItems((*ct->currItem)->branch, selnum); + if (!(*ct->currItem)->selected) + key = NEWT_KEY_DOWN; + } else { + (*ct->currItem)->selected = selnum; + key = NEWT_KEY_DOWN; + } + er.result = ER_SWALLOWED; + break; + } + switch (key) { + case '*': + ctDraw(co); + if(co->callback) co->callback(co, co->callbackData); + return er; + case NEWT_KEY_HOME: + ct->currItem = ct->flatList; + ct->firstItem = ct->flatList; + ctDraw(co); + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + return er; + case NEWT_KEY_END: + ct->currItem = ct->flatList + ct->flatCount - 1; + if (ct->flatCount <= co->height) + ct->firstItem = ct->flatList; + else + ct->firstItem = ct->flatList + ct->flatCount - co->height; + ctDraw(co); + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + return er; + case NEWT_KEY_DOWN: + if (ev.u.key != NEWT_KEY_DOWN) { + if(co->callback) co->callback(co, co->callbackData); + if (strlen(ct->seq) != 2) { + ctDraw(co); + return er; + } + } + if ((ct->currItem - ct->flatList + 1) < ct->flatCount) { + ct->currItem++; + + if (ct->currItem - ct->firstItem >= co->height) + ct->firstItem++; + + ctDraw(co); + } else if (ev.u.key != NEWT_KEY_DOWN) + ctDraw(co); + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + return er; + case NEWT_KEY_UP: + if (ct->currItem != ct->flatList) { + ct->currItem--; + + if (ct->currItem < ct->firstItem) + ct->firstItem = ct->currItem; + + ctDraw(co); + } + er.result = ER_SWALLOWED; + if(co->callback) co->callback(co, co->callbackData); + return er; + case NEWT_KEY_PGUP: + if (ct->firstItem - co->height < ct->flatList) { + ct->firstItem = ct->currItem = ct->flatList; + } else { + ct->currItem -= co->height; + ct->firstItem -= co->height; + } + + ctDraw(co); + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + return er; + case NEWT_KEY_PGDN: + listEnd = ct->flatList + ct->flatCount - 1; + lastItem = ct->firstItem + co->height - 1; + + if (lastItem + co->height > listEnd) { + ct->firstItem = listEnd - co->height + 1; + ct->currItem = listEnd; + } else { + ct->currItem += co->height; + ct->firstItem += co->height; + } + + ctDraw(co); + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + return er; + } + break; + + case EV_FOCUS: + ctDraw(co); + er.result = ER_SWALLOWED; + break; + + case EV_UNFOCUS: + ctDraw(co); + er.result = ER_SWALLOWED; + break; + default: + break; + } + + return er; +} + +const void * newtCheckboxTreeGetCurrent(newtComponent co) { + struct CheckboxTree * ct = co->data; + + if (!ct->currItem) return NULL; + return (*ct->currItem)->data; +} + +void newtCheckboxTreeSetEntry(newtComponent co, const void * data, const char * text) +{ + struct CheckboxTree * ct; + struct items * item; + int i; + + if (!co) return; + ct = co->data; + item = findItem(ct->itemlist, data); + if (!item) return; + + free(item->text); + item->text = strdup(text); + + i = 4 + (3 * item->depth); + + if ((strlen(text) + i + ct->pad) > co->width) { + co->width = strlen(text) + i + ct->pad; + } + + ctDraw(co); +} + +char newtCheckboxTreeGetEntryValue(newtComponent co, const void * data) +{ + struct CheckboxTree * ct; + struct items * item; + + if (!co) return -1; + ct = co->data; + item = findItem(ct->itemlist, data); + if (!item) return -1; + if (item->branch) + return item->selected ? NEWT_CHECKBOXTREE_EXPANDED : NEWT_CHECKBOXTREE_COLLAPSED; + else + return ct->seq[item->selected]; +} + +void newtCheckboxTreeSetEntryValue(newtComponent co, const void * data, char value) +{ + struct CheckboxTree * ct; + struct items * item; + int i; + + if (!co) return; + ct = co->data; + item = findItem(ct->itemlist, data); + if (!item || item->branch) return; + + for(i = 0; ct->seq[i]; i++) + if (value == ct->seq[i]) + break; + + if (!ct->seq[i]) return; + item->selected = i; + + ctDraw(co); +} + diff --git a/mdk-stage1/newt/entry.c b/mdk-stage1/newt/entry.c new file mode 100644 index 000000000..154edba71 --- /dev/null +++ b/mdk-stage1/newt/entry.c @@ -0,0 +1,376 @@ +#include <ctype.h> +#include <slang.h> +#include <stdlib.h> +#include <string.h> + +#include "newt.h" +#include "newt_pr.h" + +struct entry { + int flags; + char * buf; + char ** resultPtr; + int bufAlloced; + int bufUsed; /* amount of the buffer that's been used */ + int cursorPosition; /* cursor *in the string* on on screen */ + int firstChar; /* first character position being shown */ + newtEntryFilter filter; + void * filterData; +}; + +static void entryDraw(newtComponent co); +static void entryDestroy(newtComponent co); +static struct eventResult entryEvent(newtComponent co, + struct event ev); + +static struct eventResult entryHandleKey(newtComponent co, int key); + +static struct componentOps entryOps = { + entryDraw, + entryEvent, + entryDestroy, + newtDefaultPlaceHandler, + newtDefaultMappedHandler, +} ; + +void newtEntrySet(newtComponent co, const char * value, int cursorAtEnd) { + struct entry * en = co->data; + + if ((strlen(value) + 1) > (unsigned int)en->bufAlloced) { + free(en->buf); + en->bufAlloced = strlen(value) + 1; + en->buf = malloc(en->bufAlloced); + if (en->resultPtr) *en->resultPtr = en->buf; + } + memset(en->buf, 0, en->bufAlloced); /* clear the buffer */ + strcpy(en->buf, value); + en->bufUsed = strlen(value); + en->firstChar = 0; + if (cursorAtEnd) + en->cursorPosition = en->bufUsed; + else + en->cursorPosition = 0; + + entryDraw(co); +} ; + +newtComponent newtEntry(int left, int top, const char * initialValue, int width, + char ** resultPtr, int flags) { + newtComponent co; + struct entry * en; + + co = malloc(sizeof(*co)); + en = malloc(sizeof(struct entry)); + co->data = en; + + co->top = top; + co->left = left; + co->height = 1; + co->width = width; + co->isMapped = 0; + co->callback = NULL; + + co->ops = &entryOps; + + en->flags = flags; + en->cursorPosition = 0; + en->firstChar = 0; + en->bufUsed = 0; + en->bufAlloced = width + 1; + en->filter = NULL; + + if (!(en->flags & NEWT_FLAG_DISABLED)) + co->takesFocus = 1; + else + co->takesFocus = 0; + + if (initialValue && strlen(initialValue) > (unsigned int)width) { + en->bufAlloced = strlen(initialValue) + 1; + } + en->buf = malloc(en->bufAlloced); + en->resultPtr = resultPtr; + if (en->resultPtr) *en->resultPtr = en->buf; + + memset(en->buf, 0, en->bufAlloced); + if (initialValue) { + strcpy(en->buf, initialValue); + en->bufUsed = strlen(initialValue); + en->cursorPosition = en->bufUsed; + } else { + *en->buf = '\0'; + en->bufUsed = 0; + en->cursorPosition = 0; + } + + return co; +} + +static void entryDraw(newtComponent co) { + struct entry * en = co->data; + int i; + char * chptr; + int len; + + if (!co->isMapped) return; + + if (en->flags & NEWT_FLAG_DISABLED) + SLsmg_set_color(NEWT_COLORSET_DISENTRY); + else + SLsmg_set_color(NEWT_COLORSET_ENTRY); + + if (en->flags & NEWT_FLAG_HIDDEN) { + newtGotorc(co->top, co->left); + for (i = 0; i < co->width; i++) + SLsmg_write_char('_'); + newtGotorc(co->top, co->left); + + return; + } + + newtGotorc(co->top, co->left); + + if (en->cursorPosition < en->firstChar) { + /* scroll to the left */ + en->firstChar = en->cursorPosition; + } else if ((en->firstChar + co->width) <= en->cursorPosition) { + /* scroll to the right */ + en->firstChar = en->cursorPosition - co->width + 1; + } + + chptr = en->buf + en->firstChar; + + if (en->flags & NEWT_FLAG_PASSWORD) { + char *tmpptr, *p; + + tmpptr = alloca(strlen(chptr+2)); + strcpy(tmpptr, chptr); + for (p = tmpptr; *p; p++) + *p = '*'; + chptr = tmpptr; + } + + len = strlen(chptr); + + if (len <= co->width) { + i = len; + SLsmg_write_string(chptr); + while (i < co->width) { + SLsmg_write_char('_'); + i++; + } + } else { + SLsmg_write_nstring(chptr, co->width); + } + + if (en->flags & NEWT_FLAG_HIDDEN) + newtGotorc(co->top, co->left); + else + newtGotorc(co->top, co->left + (en->cursorPosition - en->firstChar)); +} + +void newtEntrySetFlags(newtComponent co, int flags, enum newtFlagsSense sense) { + struct entry * en = co->data; + int row, col; + + en->flags = newtSetFlags(en->flags, flags, sense); + + if (!(en->flags & NEWT_FLAG_DISABLED)) + co->takesFocus = 1; + else + co->takesFocus = 0; + + newtGetrc(&row, &col); + entryDraw(co); + newtGotorc(row, col); +} + +static void entryDestroy(newtComponent co) { + struct entry * en = co->data; + + free(en->buf); + free(en); + free(co); +} + +static struct eventResult entryEvent(newtComponent co, + struct event ev) { + struct entry * en = co->data; + struct eventResult er; + int ch; + + if (ev.when == EV_NORMAL) { + switch (ev.event) { + case EV_FOCUS: + newtCursorOn(); + if (en->flags & NEWT_FLAG_HIDDEN) + newtGotorc(co->top, co->left); + else + newtGotorc(co->top, co->left + + (en->cursorPosition - en->firstChar)); + er.result = ER_SWALLOWED; + break; + + case EV_UNFOCUS: + newtCursorOff(); + newtGotorc(0, 0); + er.result = ER_SWALLOWED; + if (co->callback) + co->callback(co, co->callbackData); + break; + + case EV_KEYPRESS: + ch = ev.u.key; + if (en->filter) + ch = en->filter(co, en->filterData, ch, en->cursorPosition); + if (ch) er = entryHandleKey(co, ch); + break; + + case EV_MOUSE: + if ((ev.u.mouse.type == MOUSE_BUTTON_DOWN) && + (en->flags ^ NEWT_FLAG_HIDDEN)) { + if (strlen(en->buf) >= ev.u.mouse.x - co->left) { + en->cursorPosition = ev.u.mouse.x - co->left; + newtGotorc(co->top, + co->left +(en->cursorPosition - en->firstChar)); + } else { + en->cursorPosition = strlen(en->buf); + newtGotorc(co->top, + co->left +(en->cursorPosition - en->firstChar)); + } + } + break; + } + } else + er.result = ER_IGNORED; + + return er; +} + +static struct eventResult entryHandleKey(newtComponent co, int key) { + struct entry * en = co->data; + struct eventResult er; + char * chptr, * insPoint; + + er.result = ER_SWALLOWED; + switch (key) { + case '\r': /* Return */ + if (en->flags & NEWT_FLAG_RETURNEXIT) { + er.result = ER_EXITFORM; + } else { + er.result = ER_NEXTCOMP; + } + break; + + case '\001': /* ^A */ + case NEWT_KEY_HOME: + en->cursorPosition = 0; + break; + + case '\005': /* ^E */ + case NEWT_KEY_END: + en->cursorPosition = en->bufUsed; + break; + + case '\013': /* ^K */ + en->bufUsed = en->cursorPosition; + memset(en->buf + en->bufUsed, 0, en->bufAlloced - en->bufUsed); + break; + + case '\002': /* ^B */ + case NEWT_KEY_LEFT: + if (en->cursorPosition) + en->cursorPosition--; + break; + + case '\004': + case NEWT_KEY_DELETE: + chptr = en->buf + en->cursorPosition; + if (*chptr) { + chptr++; + while (*chptr) { + *(chptr - 1) = *chptr; + chptr++; + } + *(chptr - 1) = '\0'; + en->bufUsed--; + } + break; + + case NEWT_KEY_BKSPC: + if (en->cursorPosition) { + /* if this isn't true, there's nothing to erase */ + chptr = en->buf + en->cursorPosition; + en->bufUsed--; + en->cursorPosition--; + while (*chptr) { + *(chptr - 1) = *chptr; + chptr++; + } + *(chptr - 1) = '\0'; + } + break; + + case '\006': /* ^B */ + case NEWT_KEY_RIGHT: + if (en->cursorPosition < en->bufUsed) + en->cursorPosition++; + break; + + default: + if ((key >= 0x20 && key <= 0x7e) || (key >= 0xa0 && key <= 0xff)) { + if (!(en->flags & NEWT_FLAG_SCROLL) && en->bufUsed >= co->width) { + SLtt_beep(); + break; + } + + if ((en->bufUsed + 1) == en->bufAlloced) { + en->bufAlloced += 20; + en->buf = realloc(en->buf, en->bufAlloced); + if (en->resultPtr) *en->resultPtr = en->buf; + memset(en->buf + en->bufUsed + 1, 0, 20); + } + + if (en->cursorPosition == en->bufUsed) { + en->bufUsed++; + } else { + /* insert the new character */ + + /* chptr is the last character in the string */ + chptr = (en->buf + en->bufUsed) - 1; + if ((en->bufUsed + 1) == en->bufAlloced) { + /* this string fills the buffer, so clip it */ + chptr--; + } else + en->bufUsed++; + + insPoint = en->buf + en->cursorPosition; + + while (chptr >= insPoint) { + *(chptr + 1) = *chptr; + chptr--; + } + + } + + en->buf[en->cursorPosition++] = key; + } else { + er.result = ER_IGNORED; + } + } + + entryDraw(co); + + return er; +} + +char * newtEntryGetValue(newtComponent co) { + struct entry * en = co->data; + + return en->buf; +} + +void newtEntrySetFilter(newtComponent co, newtEntryFilter filter, void * data) { + struct entry * en = co->data; + en->filter = filter; + en->filterData = data; +} diff --git a/mdk-stage1/newt/form.c b/mdk-stage1/newt/form.c new file mode 100644 index 000000000..4ad465e38 --- /dev/null +++ b/mdk-stage1/newt/form.c @@ -0,0 +1,712 @@ +#include <unistd.h> +#include <slang.h> +#include <stdarg.h> +#include <stdlib.h> +#include <sys/time.h> +#include <sys/types.h> + +#include "newt.h" +#include "newt_pr.h" + + +/**************************************************************************** + These forms handle vertical scrolling of components with a height of 1 + + Horizontal scrolling won't work, and scrolling large widgets will fail + miserably. It shouldn't be too hard to fix either of those if anyone + cares to. I only use scrolling for listboxes and text boxes though so + I didn't bother. +*****************************************************************************/ + +struct element { + int top, left; /* Actual, not virtual. These are translated */ + newtComponent co; /* into actual through vertOffset */ +}; + +struct fdInfo { + int fd; + int flags; +}; + +struct form { + int numCompsAlloced; + struct element * elements; + int numComps; + int currComp; + int fixedHeight; + int flags; + int vertOffset; + newtComponent vertBar, exitComp; + const char * help; + int numRows; + int * hotKeys; + int numHotKeys; + int background; + int beenSet; + int numFds; + struct fdInfo * fds; + int maxFd; + int timer; /* in milliseconds */ + struct timeval lastTimeout; + void * helpTag; + newtCallback helpCb; +}; + +static void gotoComponent(struct form * form, int newComp); +static struct eventResult formEvent(newtComponent co, struct event ev); +static struct eventResult sendEvent(newtComponent comp, struct event ev); +static void formPlace(newtComponent co, int left, int top); + +/* Global, ick */ +static newtCallback helpCallback; + +/* this isn't static as grid.c tests against it to find forms */ +struct componentOps formOps = { + newtDrawForm, + formEvent, + newtFormDestroy, + formPlace, + newtDefaultMappedHandler, +} ; + +static inline int componentFits(newtComponent co, int compNum) { + struct form * form = co->data; + struct element * el = form->elements + compNum; + + if ((co->top + form->vertOffset) > el->top) return 0; + if ((co->top + form->vertOffset + co->height) < + (el->top + el->co->height)) return 0; + + return 1; +} + +newtComponent newtForm(newtComponent vertBar, void * help, int flags) { + newtComponent co; + struct form * form; + + co = malloc(sizeof(*co)); + form = malloc(sizeof(*form)); + co->data = form; + co->width = 0; + co->height = 0; + co->top = -1; + co->left = -1; + co->isMapped = 0; + + co->takesFocus = 0; /* we may have 0 components */ + co->ops = &formOps; + + form->help = help; + form->flags = flags; + form->numCompsAlloced = 5; + form->numComps = 0; + form->currComp = -1; + form->vertOffset = 0; + form->fixedHeight = 0; + form->numRows = 0; + form->numFds = 0; + form->maxFd = 0; + form->fds = NULL; + form->beenSet = 0; + form->elements = malloc(sizeof(*(form->elements)) * form->numCompsAlloced); + + form->background = COLORSET_WINDOW; + form->hotKeys = malloc(sizeof(int)); + form->numHotKeys = 0; + form->timer = 0; + form->lastTimeout.tv_sec = form->lastTimeout.tv_usec = 0; + if (!(form->flags & NEWT_FLAG_NOF12)) { + newtFormAddHotKey(co, NEWT_KEY_F12); + } + + if (vertBar) + form->vertBar = vertBar; + else + form->vertBar = NULL; + + form->helpTag = help; + form->helpCb = helpCallback; + + return co; +} + +newtComponent newtFormGetCurrent(newtComponent co) { + struct form * form = co->data; + + return form->elements[form->currComp].co; +} + +void newtFormSetCurrent(newtComponent co, newtComponent subco) { + struct form * form = co->data; + int i, new; + + for (i = 0; i < form->numComps; i++) { + if (form->elements[i].co == subco) break; + } + + if (form->elements[i].co != subco) return; + new = i; + + if (co->isMapped && !componentFits(co, new)) { + gotoComponent(form, -1); + form->vertOffset = form->elements[new].top - co->top - 1; + if (form->vertOffset > (form->numRows - co->height)) + form->vertOffset = form->numRows - co->height; + } + + gotoComponent(form, new); +} + +void newtFormSetTimer(newtComponent co, int millisecs) { + struct form * form = co->data; + + form->timer = millisecs; + form->lastTimeout.tv_usec = 0; + form->lastTimeout.tv_sec = 0; +} + +void newtFormSetHeight(newtComponent co, int height) { + struct form * form = co->data; + + form->fixedHeight = 1; + co->height = height; +} + +void newtFormSetWidth(newtComponent co, int width) { + co->width = width; +} + +void newtFormAddComponent(newtComponent co, newtComponent newco) { + struct form * form = co->data; + + co->takesFocus = 1; + + if (form->numCompsAlloced == form->numComps) { + form->numCompsAlloced += 5; + form->elements = realloc(form->elements, + sizeof(*(form->elements)) * form->numCompsAlloced); + } + + /* we grab real values for these a bit later */ + form->elements[form->numComps].left = -2; + form->elements[form->numComps].top = -2; + form->elements[form->numComps].co = newco; + + if (newco->takesFocus && form->currComp == -1) + form->currComp = form->numComps; + + form->numComps++; +} + +void newtFormAddComponents(newtComponent co, ...) { + va_list ap; + newtComponent subco; + + va_start(ap, co); + + while ((subco = va_arg(ap, newtComponent))) + newtFormAddComponent(co, subco); + + va_end(ap); +} + +static void formPlace(newtComponent co, int left, int top) { + struct form * form = co->data; + int vertDelta, horizDelta; + struct element * el; + int i; + + newtFormSetSize(co); + + vertDelta = top - co->top; + horizDelta = left - co->left; + co->top = top; + co->left = left; + + for (i = 0, el = form->elements; i < form->numComps; i++, el++) { + el->co->top += vertDelta; + el->top += vertDelta; + el->co->left += horizDelta; + el->left += horizDelta; + } +} + +void newtDrawForm(newtComponent co) { + struct form * form = co->data; + struct element * el; + int i; + + newtFormSetSize(co); + + SLsmg_set_color(form->background); + newtClearBox(co->left, co->top, co->width, co->height); + for (i = 0, el = form->elements; i < form->numComps; i++, el++) { + /* the scrollbar *always* fits somewhere */ + if (el->co == form->vertBar) { + el->co->ops->mapped(el->co, 1); + el->co->ops->draw(el->co); + } else { + /* only draw it if it'll fit on the screen vertically */ + if (componentFits(co, i)) { + el->co->top = el->top - form->vertOffset; + el->co->ops->mapped(el->co, 1); + el->co->ops->draw(el->co); + } else { + el->co->ops->mapped(el->co, 0); + } + } + } + + if (form->vertBar) + newtScrollbarSet(form->vertBar, form->vertOffset, + form->numRows - co->height); +} + +static struct eventResult formEvent(newtComponent co, struct event ev) { + struct form * form = co->data; + newtComponent subco = form->elements[form->currComp].co; + int new, wrap = 0; + struct eventResult er; + int dir = 0, page = 0; + int i, num, found; + struct element * el; + + er.result = ER_IGNORED; + if (!form->numComps) return er; + + subco = form->elements[form->currComp].co; + + switch (ev.when) { + case EV_EARLY: + if (ev.event == EV_KEYPRESS) { + if (ev.u.key == NEWT_KEY_TAB) { + er.result = ER_SWALLOWED; + dir = 1; + wrap = 1; + } else if (ev.u.key == NEWT_KEY_UNTAB) { + er.result = ER_SWALLOWED; + dir = -1; + wrap = 1; + } + } + + if (form->numComps) { + i = form->currComp; + num = 0; + while (er.result == ER_IGNORED && num != form->numComps ) { + er = form->elements[i].co->ops->event(form->elements[i].co, ev); + + num++; + i++; + if (i == form->numComps) i = 0; + } + } + + break; + + case EV_NORMAL: + if (ev.event == EV_MOUSE) { + found = 0; + for (i = 0, el = form->elements; i < form->numComps; i++, el++) { + if ((el->co->top <= ev.u.mouse.y) && + (el->co->top + el->co->height > ev.u.mouse.y) && + (el->co->left <= ev.u.mouse.x) && + (el->co->left + el->co->width > ev.u.mouse.x)) { + found = 1; + if (el->co->takesFocus) { + gotoComponent(form, i); + subco = form->elements[form->currComp].co; + } + } + /* If we did not find a co to send this event to, we + should just swallow the event here. */ + } + if (!found) { + er.result = ER_SWALLOWED; + + return er; + } + } + er = subco->ops->event(subco, ev); + switch (er.result) { + case ER_NEXTCOMP: + er.result = ER_SWALLOWED; + dir = 1; + break; + + case ER_EXITFORM: + form->exitComp = subco; + break; + + default: + break; + } + break; + + case EV_LATE: + er = subco->ops->event(subco, ev); + + if (er.result == ER_IGNORED) { + switch (ev.u.key) { + case NEWT_KEY_UP: + case NEWT_KEY_LEFT: + case NEWT_KEY_BKSPC: + er.result = ER_SWALLOWED; + dir = -1; + break; + + case NEWT_KEY_DOWN: + case NEWT_KEY_RIGHT: + er.result = ER_SWALLOWED; + dir = 1; + break; + + case NEWT_KEY_PGUP: + er.result = ER_SWALLOWED; + dir = -1; + page = 1; + break; + + case NEWT_KEY_PGDN: + er.result = ER_SWALLOWED; + dir = 1; + page = 1; + break; + } + } + } + + if (dir) { + new = form->currComp; + + if (page) { + new += dir * co->height; + if (new < 0) + new = 0; + else if (new >= form->numComps) + new = (form->numComps - 1); + + while (!form->elements[new].co->takesFocus) + new = new - dir; + } else { + do { + new += dir; + + if (wrap) { + if (new < 0) + new = form->numComps - 1; + else if (new >= form->numComps) + new = 0; + } else if (new < 0 || new >= form->numComps) + return er; + } while (!form->elements[new].co->takesFocus); + } + + /* make sure this component is visible */ + if (!componentFits(co, new)) { + gotoComponent(form, -1); + + if (dir < 0) { + /* make the new component the first one */ + form->vertOffset = form->elements[new].top - co->top; + } else { + /* make the new component the last one */ + form->vertOffset = (form->elements[new].top + + form->elements[new].co->height) - + (co->top + co->height); + } + + if (form->vertOffset < 0) form->vertOffset = 0; + if (form->vertOffset > (form->numRows - co->height)) + form->vertOffset = form->numRows - co->height; + + newtDrawForm(co); + } + + gotoComponent(form, new); + er.result = ER_SWALLOWED; + } + + return er; +} + +/* this also destroys all of the components on the form */ +void newtFormDestroy(newtComponent co) { + newtComponent subco; + struct form * form = co->data; + int i; + + /* first, destroy all of the components */ + for (i = 0; i < form->numComps; i++) { + subco = form->elements[i].co; + if (subco->ops->destroy) { + subco->ops->destroy(subco); + } else { + if (subco->data) free(subco->data); + free(subco); + } + } + + if (form->hotKeys) free(form->hotKeys); + + free(form->elements); + free(form); + free(co); +} + +newtComponent newtRunForm(newtComponent co) { + struct newtExitStruct es; + + newtFormRun(co, &es); + if (es.reason == NEWT_EXIT_HOTKEY) { + if (es.u.key == NEWT_KEY_F12) { + es.reason = NEWT_EXIT_COMPONENT; + es.u.co = co; + } else { + return NULL; + } + } + + return es.u.co; +} + +void newtFormAddHotKey(newtComponent co, int key) { + struct form * form = co->data; + + form->numHotKeys++; + form->hotKeys = realloc(form->hotKeys, sizeof(int) * form->numHotKeys); + form->hotKeys[form->numHotKeys - 1] = key; +} + +void newtFormSetSize(newtComponent co) { + struct form * form = co->data; + int delta, i; + struct element * el; + + if (form->beenSet) return; + + form->beenSet = 1; + + if (!form->numComps) return; + + co->width = 0; + if (!form->fixedHeight) co->height = 0; + + co->top = form->elements[0].co->top; + co->left = form->elements[0].co->left; + for (i = 0, el = form->elements; i < form->numComps; i++, el++) { + if (el->co->ops == &formOps) + newtFormSetSize(el->co); + + el->left = el->co->left; + el->top = el->co->top; + + if (co->left > el->co->left) { + delta = co->left - el->co->left; + co->left -= delta; + co->width += delta; + } + + if (co->top > el->co->top) { + delta = co->top - el->co->top; + co->top -= delta; + if (!form->fixedHeight) + co->height += delta; + } + + if ((co->left + co->width) < (el->co->left + el->co->width)) + co->width = (el->co->left + el->co->width) - co->left; + + if (!form->fixedHeight) { + if ((co->top + co->height) < (el->co->top + el->co->height)) + co->height = (el->co->top + el->co->height) - co->top; + } + + if ((el->co->top + el->co->height - co->top) > form->numRows) { + form->numRows = el->co->top + el->co->height - co->top; + } + } +} + +void newtFormRun(newtComponent co, struct newtExitStruct * es) { + struct form * form = co->data; + struct event ev; + struct eventResult er; + int key, i, max; + int done = 0; + fd_set readSet, writeSet; + struct timeval nextTimeout, now, timeout; + + newtFormSetSize(co); + /* draw all of the components */ + newtDrawForm(co); + + if (form->currComp == -1) { + gotoComponent(form, 0); + } else + gotoComponent(form, form->currComp); + + while (!done) { + newtRefresh(); + + FD_ZERO(&readSet); + FD_ZERO(&writeSet); + FD_SET(0, &readSet); + max = form->maxFd; + + for (i = 0; i < form->numFds; i++) { + if (form->fds[i].flags & NEWT_FD_READ) + FD_SET(form->fds[i].fd, &readSet); + if (form->fds[i].flags & NEWT_FD_WRITE) + FD_SET(form->fds[i].fd, &writeSet); + } + + if (form->timer) { + /* Calculate when we next need to return with a timeout. Do + this inside the loop in case a callback resets the timer. */ + if (!form->lastTimeout.tv_sec && !form->lastTimeout.tv_usec) + gettimeofday(&form->lastTimeout, NULL); + + nextTimeout.tv_sec = form->lastTimeout.tv_sec + + (form->timer / 1000); + nextTimeout.tv_usec = form->lastTimeout.tv_usec + + (form->timer % 1000) * 1000; + + gettimeofday(&now, 0); + + if (now.tv_sec > nextTimeout.tv_sec) { + timeout.tv_sec = timeout.tv_usec = 0; + } else if (now.tv_sec == nextTimeout.tv_sec) { + timeout.tv_sec = 0; + if (now.tv_usec > nextTimeout.tv_usec) + timeout.tv_usec = 0; + else + timeout.tv_usec = nextTimeout.tv_usec - now.tv_usec; + } else if (now.tv_sec < nextTimeout.tv_sec) { + timeout.tv_sec = nextTimeout.tv_sec - now.tv_sec; + if (now.tv_usec > nextTimeout.tv_usec) + timeout.tv_sec--, + timeout.tv_usec = nextTimeout.tv_usec + 1000000 - + now.tv_usec; + else + timeout.tv_usec = nextTimeout.tv_usec - now.tv_usec; + } + } else { + timeout.tv_sec = timeout.tv_usec = 0; + } + + i = select(max + 1, &readSet, &writeSet, NULL, + form->timer ? &timeout : NULL); + if (i < 0) continue; /* ?? What should we do here? */ + + if (i == 0) { + done = 1; + es->reason = NEWT_EXIT_TIMER; + gettimeofday(&form->lastTimeout, NULL); + } else + { + if (FD_ISSET(0, &readSet)) { + + key = newtGetKey(); + + if (key == NEWT_KEY_RESIZE) { + /* newtResizeScreen(1); */ + continue; + } + + for (i = 0; i < form->numHotKeys; i++) { + if (form->hotKeys[i] == key) { + es->reason = NEWT_EXIT_HOTKEY; + es->u.key = key; + done = 1; + break; + } + } + + if (key == NEWT_KEY_F1 && form->helpTag && form->helpCb) + form->helpCb(co, form->helpTag); + + if (!done) { + ev.event = EV_KEYPRESS; + ev.u.key = key; + + er = sendEvent(co, ev); + + if (er.result == ER_EXITFORM) { + done = 1; + es->reason = NEWT_EXIT_COMPONENT; + es->u.co = form->exitComp; + } + } + } else { + es->reason = NEWT_EXIT_FDREADY; + done = 1; + } + } + } + newtRefresh(); +} + +static struct eventResult sendEvent(newtComponent co, struct event ev) { + struct eventResult er; + + ev.when = EV_EARLY; + er = co->ops->event(co, ev); + + if (er.result == ER_IGNORED) { + ev.when = EV_NORMAL; + er = co->ops->event(co, ev); + } + + if (er.result == ER_IGNORED) { + ev.when = EV_LATE; + er = co->ops->event(co, ev); + } + + return er; +} + +static void gotoComponent(struct form * form, int newComp) { + struct event ev; + + if (form->currComp != -1) { + ev.event = EV_UNFOCUS; + sendEvent(form->elements[form->currComp].co, ev); + } + + form->currComp = newComp; + + if (form->currComp != -1) { + ev.event = EV_FOCUS; + ev.when = EV_NORMAL; + sendEvent(form->elements[form->currComp].co, ev); + } +} + +void newtComponentAddCallback(newtComponent co, newtCallback f, void * data) { + co->callback = f; + co->callbackData = data; +} + +void newtComponentTakesFocus(newtComponent co, int val) { + co->takesFocus = val; +} + +void newtFormSetBackground(newtComponent co, int color) { + struct form * form = co->data; + + form->background = color; +} + +void newtFormWatchFd(newtComponent co, int fd, int fdFlags) { + struct form * form = co->data; + + form->fds = realloc(form->fds, (form->numFds + 1) * sizeof(*form->fds)); + form->fds[form->numFds].fd = fd; + form->fds[form->numFds++].flags = fdFlags; + if (form->maxFd < fd) form->maxFd = fd; +} + +void newtSetHelpCallback(newtCallback cb) { + helpCallback = cb; +} diff --git a/mdk-stage1/newt/grid.c b/mdk-stage1/newt/grid.c new file mode 100644 index 000000000..433011396 --- /dev/null +++ b/mdk-stage1/newt/grid.c @@ -0,0 +1,389 @@ +#include <alloca.h> +#include <stdlib.h> +#include <string.h> + +#include "newt.h" +#include "newt_pr.h" + +struct gridField { + enum newtGridElement type; + union { + newtGrid grid; + newtComponent co; + } u; + int padLeft, padTop, padRight, padBottom; + int anchor; + int flags; +}; + +struct grid_s { + int rows, cols; + int width, height; /* totals, -1 means unknown */ + struct gridField ** fields; +}; + +/* this is a bit of a hack */ +extern struct componentOps formOps[]; + +newtGrid newtCreateGrid(int cols, int rows) { + newtGrid grid; + + grid = malloc(sizeof(*grid)); + grid->rows = rows; + grid->cols = cols; + + grid->fields = malloc(sizeof(*grid->fields) * cols); + while (cols--) { + grid->fields[cols] = malloc(sizeof(**(grid->fields)) * rows); + memset(grid->fields[cols], 0, sizeof(**(grid->fields)) * rows); + } + + grid->width = grid->height = -1; + + return grid; +} + +void newtGridSetField(newtGrid grid, int col, int row, + enum newtGridElement type, void * val, int padLeft, + int padTop, int padRight, int padBottom, int anchor, + int flags) { + struct gridField * field = &grid->fields[col][row]; + + if (field->type == NEWT_GRID_SUBGRID) + newtGridFree(field->u.grid, 1); + + field->type = type; + field->u.co = (void *) val; + + field->padLeft = padLeft; + field->padRight = padRight; + field->padTop = padTop; + field->padBottom = padBottom; + field->anchor = anchor; + field->flags = flags; + + grid->width = grid->height = -1; +} + +static void distSpace(int extra, int items, int * list) { + int all, some, i; + + all = extra / items; + some = extra % items; + for (i = 0; i < items; i++) { + list[i] += all; + if (some) { + list[i]++; + some--; + } + } +} + +static void shuffleGrid(newtGrid grid, int left, int top, int set) { + struct gridField * field; + int row, col; + int i, j; + int minWidth, minHeight; + int * widths, * heights; + int thisLeft, thisTop; + int x, y, remx, remy; + + widths = alloca(sizeof(*widths) * grid->cols); + memset(widths, 0, sizeof(*widths) * grid->cols); + heights = alloca(sizeof(*heights) * grid->rows); + memset(heights, 0, sizeof(*heights) * grid->rows); + + minWidth = 0; + for (row = 0; row < grid->rows; row++) { + i = 0; + for (col = 0; col < grid->cols; col++) { + field = &grid->fields[col][row]; + if (field->type == NEWT_GRID_SUBGRID) { + /* we'll have to redo this later */ + if (field->u.grid->width == -1) + shuffleGrid(field->u.grid, left, top, 0); + j = field->u.grid->width; + } else if (field->type == NEWT_GRID_COMPONENT) { + if (field->u.co->ops == formOps) + newtFormSetSize(field->u.co); + j = field->u.co->width; + } else + j = 0; + + j += field->padLeft + field->padRight; + + if (j > widths[col]) widths[col] = j; + i += widths[col]; + } + + if (i > minWidth) minWidth = i; + } + + minHeight = 0; + for (col = 0; col < grid->cols; col++) { + i = 0; + for (row = 0; row < grid->rows; row++) { + field = &grid->fields[col][row]; + if (field->type == NEWT_GRID_SUBGRID) { + /* we'll have to redo this later */ + if (field->u.grid->height == -1) + shuffleGrid(field->u.grid, 0, 0, 0); + j = field->u.grid->height; + } else if (field->type == NEWT_GRID_COMPONENT){ + j = field->u.co->height; + } else + j = 0; + + j += field->padTop + field->padBottom; + + if (j > heights[row]) heights[row] = j; + i += heights[row]; + } + + if (i > minHeight) minHeight = i; + } + + /* this catches the -1 case */ + if (grid->width < minWidth) grid->width = minWidth; /* ack! */ + if (grid->height < minHeight) grid->height = minHeight; /* ditto! */ + + if (!set) return; + + distSpace(grid->width - minWidth, grid->cols, widths); + distSpace(grid->height - minHeight, grid->rows, heights); + + thisTop = top; + for (row = 0; row < grid->rows; row++) { + i = 0; + thisLeft = left; + for (col = 0; col < grid->cols; col++) { + field = &grid->fields[col][row]; + + if (field->type == NEWT_GRID_EMPTY) continue; + + x = thisLeft + field->padLeft; + remx = widths[col] - field->padLeft - field->padRight; + y = thisTop + field->padTop; + remy = heights[row] - field->padTop - field->padBottom; + + if (field->type == NEWT_GRID_SUBGRID) { + remx -= field->u.grid->width; + remy -= field->u.grid->height; + } else if (field->type == NEWT_GRID_COMPONENT) { + remx -= field->u.co->width; + remy -= field->u.co->height; + } + + if (!(field->flags & NEWT_GRID_FLAG_GROWX)) { + if (field->anchor & NEWT_ANCHOR_RIGHT) + x += remx; + else if (!(field->anchor & NEWT_ANCHOR_LEFT)) + x += (remx / 2); + } + + if (!(field->flags & NEWT_GRID_FLAG_GROWY)) { + if (field->anchor & NEWT_ANCHOR_BOTTOM) + y += remx; + else if (!(field->anchor & NEWT_ANCHOR_TOP)) + y += (remy / 2); + } + + if (field->type == NEWT_GRID_SUBGRID) { + if (field->flags & NEWT_GRID_FLAG_GROWX) + field->u.grid->width = widths[col] - field->padLeft + - field->padRight; + if (field->flags & NEWT_GRID_FLAG_GROWY) + field->u.grid->height = heights[col] - field->padTop + - field->padBottom; + + shuffleGrid(field->u.grid, x, y, 1); + } else if (field->type == NEWT_GRID_COMPONENT) { + field->u.co->ops->place(field->u.co, x, y); + } + + thisLeft += widths[col]; + } + + thisTop += heights[row]; + } +} + +void newtGridPlace(newtGrid grid, int left, int top) { + shuffleGrid(grid, left, top, 1); +} + +void newtGridFree(newtGrid grid, int recurse) { + int row, col; + + for (col = 0; col < grid->cols; col++) { + if (recurse) { + for (row = 0; row < grid->rows; row++) { + if (grid->fields[col][row].type == NEWT_GRID_SUBGRID) + newtGridFree(grid->fields[col][row].u.grid, 1); + } + } + + free(grid->fields[col]); + } + + free(grid->fields); + free(grid); +} + +void newtGridGetSize(newtGrid grid, int * width, int * height) { + if (grid->width == -1 || grid->height == -1) { + grid->width = grid->height = -1; + shuffleGrid(grid, 0, 0, 1); + } + + *width = grid->width; + *height = grid->height; +} + +void newtGridWrappedWindow(newtGrid grid, char * title) { + int width, height, offset = 0; + + newtGridGetSize(grid, &width, &height); + if (width < strlen(title) + 2) { + offset = ((strlen(title) + 2) - width) / 2; + width = strlen(title) + 2; + } + newtCenteredWindow(width + 2, height + 2, title); + newtGridPlace(grid, 1 + offset, 1); +} + +void newtGridWrappedWindowAt(newtGrid grid, char * title, int left, int top) { + int width, height; + + newtGridGetSize(grid, &width, &height); + newtOpenWindow(left, top, width + 2, height + 2, title); + newtGridPlace(grid, 1, 1); +} + +void newtGridAddComponentsToForm(newtGrid grid, newtComponent form, + int recurse) { + int row, col; + + for (col = 0; col < grid->cols; col++) { + for (row = 0; row < grid->rows; row++) { + if (grid->fields[col][row].type == NEWT_GRID_SUBGRID && recurse) + newtGridAddComponentsToForm(grid->fields[col][row].u.grid, + form, 1); + else if (grid->fields[col][row].type == NEWT_GRID_COMPONENT) + newtFormAddComponent(form, grid->fields[col][row].u.co); + } + } +} + +/* this handles up to 50 items */ +static newtGrid stackem(int isVert, enum newtGridElement type1, void * what1, + va_list args, int close) { + struct item { + enum newtGridElement type; + void * what; + } items[50]; + int i, num; + newtGrid grid; + + items[0].type = type1, items[0].what = what1, num = 1; + while (1) { + items[num].type = va_arg(args, enum newtGridElement); + if (items[num].type == NEWT_GRID_EMPTY) break; + + items[num].what = va_arg(args, void *); + num++; + } + + grid = newtCreateGrid(isVert ? 1 : num, isVert ? num : 1); + + for (i = 0; i < num; i++) { + newtGridSetField(grid, isVert ? 0 : i, isVert ? i : 0, + items[i].type, items[i].what, + close ? 0 : (i ? (isVert ? 0 : 1) : 0), + close ? 0 : (i ? (isVert ? 1 : 0) : 0), 0, 0, 0, 0); + } + + return grid; +} + +newtGrid newtGridHCloseStacked(enum newtGridElement type1, void * what1, ...) { + va_list args; + newtGrid grid; + + va_start(args, what1); + + grid = stackem(0, type1, what1, args, 1); + + va_start(args, what1); + + return grid; +} + +newtGrid newtGridVCloseStacked(enum newtGridElement type1, void * what1, ...) { + va_list args; + newtGrid grid; + + va_start(args, what1); + + grid = stackem(1, type1, what1, args, 1); + + va_start(args, what1); + + return grid; +} + +newtGrid newtGridVStacked(enum newtGridElement type1, void * what1, ...) { + va_list args; + newtGrid grid; + + va_start(args, what1); + + grid = stackem(1, type1, what1, args, 0); + + va_start(args, what1); + + return grid; +} + +newtGrid newtGridHStacked(enum newtGridElement type1, void * what1, ...) { + va_list args; + newtGrid grid; + + va_start(args, what1); + + grid = stackem(0, type1, what1, args, 0); + + va_start(args, what1); + + return grid; +} + +newtGrid newtGridBasicWindow(newtComponent text, newtGrid middle, + newtGrid buttons) { + newtGrid grid; + + grid = newtCreateGrid(1, 3); + newtGridSetField(grid, 0, 0, NEWT_GRID_COMPONENT, text, + 0, 0, 0, 0, NEWT_ANCHOR_LEFT, 0); + newtGridSetField(grid, 0, 1, NEWT_GRID_SUBGRID, middle, + 0, 1, 0, 0, 0, 0); + newtGridSetField(grid, 0, 2, NEWT_GRID_SUBGRID, buttons, + 0, 1, 0, 0, 0, NEWT_GRID_FLAG_GROWX); + + return grid; +} + +newtGrid newtGridSimpleWindow(newtComponent text, newtComponent middle, + newtGrid buttons) { + newtGrid grid; + + grid = newtCreateGrid(1, 3); + newtGridSetField(grid, 0, 0, NEWT_GRID_COMPONENT, text, + 0, 0, 0, 0, NEWT_ANCHOR_LEFT, 0); + newtGridSetField(grid, 0, 1, NEWT_GRID_COMPONENT, middle, + 0, 1, 0, 0, 0, 0); + newtGridSetField(grid, 0, 2, NEWT_GRID_SUBGRID, buttons, + 0, 1, 0, 0, 0, NEWT_GRID_FLAG_GROWX); + + return grid; +} diff --git a/mdk-stage1/newt/label.c b/mdk-stage1/newt/label.c new file mode 100644 index 000000000..f1a9cebbf --- /dev/null +++ b/mdk-stage1/newt/label.c @@ -0,0 +1,81 @@ +#include <slang.h> +#include <stdlib.h> +#include <string.h> + +#include "newt.h" +#include "newt_pr.h" + +struct label { + char * text; + int length; +}; + +static void labelDraw(newtComponent co); +static void labelDestroy(newtComponent co); + +static struct componentOps labelOps = { + labelDraw, + newtDefaultEventHandler, + labelDestroy, + newtDefaultPlaceHandler, + newtDefaultMappedHandler, +} ; + +newtComponent newtLabel(int left, int top, const char * text) { + newtComponent co; + struct label * la; + + co = malloc(sizeof(*co)); + la = malloc(sizeof(struct label)); + co->data = la; + + co->ops = &labelOps; + + co->height = 1; + co->width = strlen(text); + co->top = top; + co->left = left; + co->takesFocus = 0; + + la->length = strlen(text); + la->text = strdup(text); + + return co; +} + +void newtLabelSetText(newtComponent co, const char * text) { + int newLength; + struct label * la = co->data; + + newLength = strlen(text); + if (newLength <= la->length) { + memset(la->text, ' ', la->length); + memcpy(la->text, text, newLength); + } else { + free(la->text); + la->text = strdup(text); + la->length = newLength; + co->width = newLength; + } + + labelDraw(co); +} + +static void labelDraw(newtComponent co) { + struct label * la = co->data; + + if (co->isMapped == -1) return; + + SLsmg_set_color(COLORSET_LABEL); + + newtGotorc(co->top, co->left); + SLsmg_write_string(la->text); +} + +static void labelDestroy(newtComponent co) { + struct label * la = co->data; + + free(la->text); + free(la); + free(co); +} diff --git a/mdk-stage1/newt/listbox.c b/mdk-stage1/newt/listbox.c new file mode 100644 index 000000000..ef276aeb4 --- /dev/null +++ b/mdk-stage1/newt/listbox.c @@ -0,0 +1,752 @@ +/* This goofed-up box whacked into shape by Elliot Lee <sopwith@cuc.edu> + (from the original listbox by Erik Troan <ewt@redhat.com>) + and contributed to newt for use under the LGPL license. + Copyright (C) 1996, 1997 Elliot Lee */ + +#include <slang.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <ctype.h> + +#include "newt.h" +#include "newt_pr.h" + + +/* Linked list of items in the listbox */ +struct items { + char * text; + const void *data; + unsigned char isSelected; + struct items *next; +}; + +/* Holds all the relevant information for this listbox */ +struct listbox { + newtComponent sb; /* Scrollbar on right side of listbox */ + int curWidth; /* size of text w/o scrollbar or border*/ + int curHeight; /* size of text w/o border */ + int sbAdjust; + int bdxAdjust, bdyAdjust; + int numItems, numSelected; + int userHasSetWidth; + int currItem, startShowItem; /* startShowItem is the first item displayed + on the screen */ + int isActive; /* If we handle key events all the time, it seems + to do things even when they are supposed to be for + another button/whatever */ + struct items *boxItems; + int grow; + int flags; /* flags for this listbox, right now just + NEWT_FLAG_RETURNEXIT */ +}; + +static void listboxDraw(newtComponent co); +static void listboxDestroy(newtComponent co); +static struct eventResult listboxEvent(newtComponent co, struct event ev); +static void newtListboxRealSetCurrent(newtComponent co); +static void listboxPlace(newtComponent co, int newLeft, int newTop); +static inline void updateWidth(newtComponent co, struct listbox * li, + int maxField); +static void listboxMapped(newtComponent co, int isMapped); + +static struct componentOps listboxOps = { + listboxDraw, + listboxEvent, + listboxDestroy, + listboxPlace, + listboxMapped, +}; + +static void listboxMapped(newtComponent co, int isMapped) { + struct listbox * li = co->data; + + co->isMapped = isMapped; + if (li->sb) + li->sb->ops->mapped(li->sb, isMapped); +} + +static void listboxPlace(newtComponent co, int newLeft, int newTop) { + struct listbox * li = co->data; + + co->top = newTop; + co->left = newLeft; + + if (li->sb) + li->sb->ops->place(li->sb, co->left + co->width - li->bdxAdjust - 1, + co->top); +} + +newtComponent newtListbox(int left, int top, int height, int flags) { + newtComponent co, sb; + struct listbox * li; + + if (!(co = malloc(sizeof(*co)))) + return NULL; + + if (!(li = malloc(sizeof(struct listbox)))) { + free(co); + return NULL; + } + + li->boxItems = NULL; + li->numItems = 0; + li->currItem = 0; + li->numSelected = 0; + li->isActive = 0; + li->userHasSetWidth = 0; + li->startShowItem = 0; + li->sbAdjust = 0; + li->bdxAdjust = 0; + li->bdyAdjust = 0; + li->flags = flags & (NEWT_FLAG_RETURNEXIT | NEWT_FLAG_BORDER | + NEWT_FLAG_MULTIPLE); + + if (li->flags & NEWT_FLAG_BORDER) { + li->bdxAdjust = 2; + li->bdyAdjust = 1; + } + + co->height = height; + li->curHeight = co->height - (2 * li->bdyAdjust); + + if (height) { + li->grow = 0; + if (flags & NEWT_FLAG_SCROLL) { + sb = newtVerticalScrollbar(left, top + li->bdyAdjust, + li->curHeight, + COLORSET_LISTBOX, COLORSET_ACTLISTBOX); + li->sbAdjust = 3; + } else { + sb = NULL; + } + } else { + li->grow = 1; + sb = NULL; + } + + li->sb = sb; + co->data = li; + co->isMapped = 0; + co->left = left; + co->top = top; + co->ops = &listboxOps; + co->takesFocus = 1; + co->callback = NULL; + + updateWidth(co, li, 5); + + return co; +} + +static inline void updateWidth(newtComponent co, struct listbox * li, + int maxField) { + li->curWidth = maxField; + co->width = li->curWidth + li->sbAdjust + 2 * li->bdxAdjust; + + if (li->sb) + li->sb->left = co->left + co->width - li->bdxAdjust - 1; +} + +void newtListboxSetCurrentByKey(newtComponent co, void * key) { + struct listbox * li = co->data; + struct items * item; + int i; + + item = li->boxItems, i = 0; + while (item && item->data != key) + item = item->next, i++; + + if (item) + newtListboxSetCurrent(co, i); +} + +void newtListboxSetCurrent(newtComponent co, int num) +{ + struct listbox * li = co->data; + + if (num >= li->numItems) + li->currItem = li->numItems - 1; + else if (num < 0) + li->currItem = 0; + else + li->currItem = num; + + if (li->currItem < li->startShowItem) + li->startShowItem = li->currItem; + else if (li->currItem - li->startShowItem > li->curHeight - 1) + li->startShowItem = li->currItem - li->curHeight + 1; + if (li->startShowItem + li->curHeight > li->numItems) + li->startShowItem = li->numItems - li->curHeight; + if(li->startShowItem < 0) + li->startShowItem = 0; + + newtListboxRealSetCurrent(co); +} + +static void newtListboxRealSetCurrent(newtComponent co) +{ + struct listbox * li = co->data; + + if(li->sb) + newtScrollbarSet(li->sb, li->currItem + 1, li->numItems); + listboxDraw(co); + if(co->callback) co->callback(co, co->callbackData); +} + +void newtListboxSetWidth(newtComponent co, int width) { + struct listbox * li = co->data; + + co->width = width; + li->curWidth = co->width - li->sbAdjust - 2 * li->bdxAdjust; + li->userHasSetWidth = 1; + if (li->sb) li->sb->left = co->width + co->left - 1; + listboxDraw(co); +} + +void * newtListboxGetCurrent(newtComponent co) { + struct listbox * li = co->data; + int i; + struct items *item; + + for(i = 0, item = li->boxItems; item != NULL && i < li->currItem; + i++, item = item->next); + + if (item) + return (void *)item->data; + else + return NULL; +} + +void newtListboxSelectItem(newtComponent co, const void * key, + enum newtFlagsSense sense) +{ + struct listbox * li = co->data; + int i; + struct items * item; + + item = li->boxItems, i = 0; + while (item && item->data != key) + item = item->next, i++; + + if (!item) return; + + if (item->isSelected) + li->numSelected--; + + switch(sense) { + case NEWT_FLAGS_RESET: + item->isSelected = 0; break; + case NEWT_FLAGS_SET: + item->isSelected = 1; break; + case NEWT_FLAGS_TOGGLE: + item->isSelected = !item->isSelected; + } + + if (item->isSelected) + li->numSelected++; + + listboxDraw(co); +} + +void newtListboxClearSelection(newtComponent co) +{ + struct items *item; + struct listbox * li = co->data; + + for(item = li->boxItems; item != NULL; + item = item->next) + item->isSelected = 0; + li->numSelected = 0; + listboxDraw(co); +} + +/* Free the returned array after use, but NOT the values in the array */ +void ** newtListboxGetSelection(newtComponent co, int *numitems) +{ + struct listbox * li; + int i; + void **retval; + struct items *item; + + if(!co || !numitems) return NULL; + + li = co->data; + if(!li || !li->numSelected) return NULL; + + retval = malloc(li->numSelected * sizeof(void *)); + for(i = 0, item = li->boxItems; item != NULL; + item = item->next) + if(item->isSelected) + retval[i++] = (void *)item->data; + *numitems = li->numSelected; + return retval; +} + +void newtListboxSetEntry(newtComponent co, int num, const char * text) { + struct listbox * li = co->data; + int i; + struct items *item; + + for(i = 0, item = li->boxItems; item != NULL && i < num; + i++, item = item->next); + + if(!item) + return; + else { + free(item->text); + item->text = strdup(text); + } + if (li->userHasSetWidth == 0 && strlen(text) > li->curWidth) { + updateWidth(co, li, strlen(text)); + } + + if (num >= li->startShowItem && num <= li->startShowItem + co->height) + listboxDraw(co); +} + +void newtListboxSetData(newtComponent co, int num, void * data) { + struct listbox * li = co->data; + int i; + struct items *item; + + for(i = 0, item = li->boxItems; item != NULL && i < num; + i++, item = item->next); + + item->data = data; +} + +int newtListboxAppendEntry(newtComponent co, const char * text, + const void * data) { + struct listbox * li = co->data; + struct items *item; + + if(li->boxItems) { + for (item = li->boxItems; item->next != NULL; item = item->next); + + item = item->next = malloc(sizeof(struct items)); + } else { + item = li->boxItems = malloc(sizeof(struct items)); + } + + if (!li->userHasSetWidth && text && (strlen(text) > li->curWidth)) + updateWidth(co, li, strlen(text)); + + item->text = strdup(text); item->data = data; item->next = NULL; + item->isSelected = 0; + + if (li->grow) + co->height++, li->curHeight++; + li->numItems++; + + return 0; +} + +int newtListboxInsertEntry(newtComponent co, const char * text, + const void * data, void * key) { + struct listbox * li = co->data; + struct items *item, *t; + + if (li->boxItems) { + if (key) { + item = li->boxItems; + while (item && item->data != key) item = item->next; + + if (!item) return 1; + + t = item->next; + item = item->next = malloc(sizeof(struct items)); + item->next = t; + } else { + t = li->boxItems; + item = li->boxItems = malloc(sizeof(struct items)); + item->next = t; + } + } else if (key) { + return 1; + } else { + item = li->boxItems = malloc(sizeof(struct items)); + item->next = NULL; + } + + if (!li->userHasSetWidth && text && (strlen(text) > li->curWidth)) + updateWidth(co, li, strlen(text)); + + item->text = strdup(text?text:"(null)"); item->data = data; + item->isSelected = 0; + + if (li->sb) + li->sb->left = co->left + co->width - li->bdxAdjust - 1; + li->numItems++; + + listboxDraw(co); + + return 0; +} + +int newtListboxDeleteEntry(newtComponent co, void * key) { + struct listbox * li = co->data; + int widest = 0, t; + struct items *item, *item2 = NULL; + int num; + + if (li->boxItems == NULL || li->numItems <= 0) + return 0; + + num = 0; + + item2 = NULL, item = li->boxItems; + while (item && item->data != key) { + item2 = item; + item = item->next; + num++; + } + + if (!item) + return -1; + + if (item2) + item2->next = item->next; + else + li->boxItems = item->next; + + free(item->text); + free(item); + li->numItems--; + + if (!li->userHasSetWidth) { + widest = 0; + for (item = li->boxItems; item != NULL; item = item->next) + if ((t = strlen(item->text)) > widest) widest = t; + } + + if (li->currItem >= num) + li->currItem--; + + if (!li->userHasSetWidth) { + updateWidth(co, li, widest); + } + + listboxDraw(co); + + return 0; +} + +void newtListboxClear(newtComponent co) +{ + struct listbox * li; + struct items *anitem, *nextitem; + if(co == NULL || (li = co->data) == NULL) + return; + for(anitem = li->boxItems; anitem != NULL; anitem = nextitem) { + nextitem = anitem->next; + free(anitem->text); + free(anitem); + } + li->numItems = li->numSelected = li->currItem = li->startShowItem = 0; + li->boxItems = NULL; + if (!li->userHasSetWidth) + updateWidth(co, li, 5); +} + +/* If you don't want to get back the text, pass in NULL for the ptr-ptr. Same + goes for the data. */ +void newtListboxGetEntry(newtComponent co, int num, char **text, void **data) { + struct listbox * li = co->data; + int i; + struct items *item; + + if (!li->boxItems || num >= li->numItems) { + if(text) + *text = NULL; + if(data) + *data = NULL; + return; + } + + i = 0; + item = li->boxItems; + while (item && i < num) { + i++, item = item->next; + } + + if (item) { + if (text) + *text = item->text; + if (data) + *data = (void *)item->data; + } +} + +static void listboxDraw(newtComponent co) +{ + struct listbox * li = co->data; + struct items *item; + int i, j; + + if (!co->isMapped) return ; + + if(li->flags & NEWT_FLAG_BORDER) { + if(li->isActive) + SLsmg_set_color(NEWT_COLORSET_ACTLISTBOX); + else + SLsmg_set_color(NEWT_COLORSET_LISTBOX); + + newtDrawBox(co->left, co->top, co->width, co->height, 0); + } + + if(li->sb) + li->sb->ops->draw(li->sb); + + SLsmg_set_color(NEWT_COLORSET_LISTBOX); + + for(i = 0, item = li->boxItems; item != NULL && i < li->startShowItem; + i++, item = item->next); + + j = i; + + for (i = 0; item != NULL && i < li->curHeight; i++, item = item->next) { + if (!item->text) continue; + + newtGotorc(co->top + i + li->bdyAdjust, co->left + li->bdxAdjust); + if(j + i == li->currItem) { + if(item->isSelected) + SLsmg_set_color(NEWT_COLORSET_ACTSELLISTBOX); + else + SLsmg_set_color(NEWT_COLORSET_ACTLISTBOX); + } else if(item->isSelected) + SLsmg_set_color(NEWT_COLORSET_SELLISTBOX); + else + SLsmg_set_color(NEWT_COLORSET_LISTBOX); + + SLsmg_write_nstring(item->text, li->curWidth); + + } + newtGotorc(co->top + (li->currItem - li->startShowItem), co->left); +} + +static struct eventResult listboxEvent(newtComponent co, struct event ev) { + struct eventResult er; + struct listbox * li = co->data; + struct items *item; + int i; + + er.result = ER_IGNORED; + + if(ev.when == EV_EARLY || ev.when == EV_LATE) { + return er; + } + + switch(ev.event) { + case EV_KEYPRESS: + if (!li->isActive) break; + + switch(ev.u.key) { + case ' ': + if(!(li->flags & NEWT_FLAG_MULTIPLE)) break; + newtListboxSelectItem(co, li->boxItems[li->currItem].data, + NEWT_FLAGS_TOGGLE); + er.result = ER_SWALLOWED; + /* We don't break here, because it is cool to be able to + hold space to select a bunch of items in a list at once */ + + case NEWT_KEY_DOWN: + if(li->numItems <= 0) break; + if(li->currItem < li->numItems - 1) { + li->currItem++; + if(li->currItem > (li->startShowItem + li->curHeight - 1)) { + li->startShowItem = li->currItem - li->curHeight + 1; + if(li->startShowItem + li->curHeight > li->numItems) + li->startShowItem = li->numItems - li->curHeight; + } + if(li->sb) + newtScrollbarSet(li->sb, li->currItem + 1, li->numItems); + listboxDraw(co); + } + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + break; + + case NEWT_KEY_ENTER: + if(li->numItems <= 0) break; + if(li->flags & NEWT_FLAG_RETURNEXIT) + er.result = ER_EXITFORM; + break; + + case NEWT_KEY_UP: + if(li->numItems <= 0) break; + if(li->currItem > 0) { + li->currItem--; + if(li->currItem < li->startShowItem) + li->startShowItem = li->currItem; + if(li->sb) + newtScrollbarSet(li->sb, li->currItem + 1, li->numItems); + listboxDraw(co); + } + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + break; + + case NEWT_KEY_PGUP: + if(li->numItems <= 0) break; + li->startShowItem -= li->curHeight - 1; + if(li->startShowItem < 0) + li->startShowItem = 0; + li->currItem -= li->curHeight - 1; + if(li->currItem < 0) + li->currItem = 0; + newtListboxRealSetCurrent(co); + er.result = ER_SWALLOWED; + break; + + case NEWT_KEY_PGDN: + if(li->numItems <= 0) break; + li->startShowItem += li->curHeight; + if(li->startShowItem > (li->numItems - li->curHeight)) { + li->startShowItem = li->numItems - li->curHeight; + } + li->currItem += li->curHeight; + if(li->currItem >= li->numItems) { + li->currItem = li->numItems - 1; + } + newtListboxRealSetCurrent(co); + er.result = ER_SWALLOWED; + break; + + case NEWT_KEY_HOME: + if(li->numItems <= 0) break; + newtListboxSetCurrent(co, 0); + er.result = ER_SWALLOWED; + break; + + case NEWT_KEY_END: + if(li->numItems <= 0) break; + li->startShowItem = li->numItems - li->curHeight; + if(li->startShowItem < 0) + li->startShowItem = 0; + li->currItem = li->numItems - 1; + newtListboxRealSetCurrent(co); + er.result = ER_SWALLOWED; + break; + default: + if (li->numItems <= 0) break; + if (ev.u.key < NEWT_KEY_EXTRA_BASE && isalpha(ev.u.key)) { + for(i = 0, item = li->boxItems; item != NULL && + i < li->currItem; i++, item = item->next); + + if (item && item->text && (toupper(*item->text) == toupper(ev.u.key))) { + item = item->next; + i++; + } else { + item = li->boxItems; + i = 0; + } + while (item && item->text && + toupper(*item->text) != toupper(ev.u.key)) { + item = item->next; + i++; + } + if (item) { + li->currItem = i; + if(li->currItem < li->startShowItem || + li->currItem > li->startShowItem) + li->startShowItem = + li->currItem > li->numItems - li->curHeight ? + li->startShowItem = li->numItems - li->curHeight : + li->currItem; + if(li->sb) + newtScrollbarSet(li->sb, li->currItem + 1, li->numItems); + newtListboxRealSetCurrent(co); + er.result = ER_SWALLOWED; + } + } + } + break; + + case EV_FOCUS: + li->isActive = 1; + listboxDraw(co); + er.result = ER_SWALLOWED; + break; + + case EV_UNFOCUS: + li->isActive = 0; + listboxDraw(co); + er.result = ER_SWALLOWED; + break; + + case EV_MOUSE: + /* if this mouse click was within the listbox, make the current + item the item clicked on. */ + /* Up scroll arrow */ + if (li->sb && + ev.u.mouse.x == co->left + co->width - li->bdxAdjust - 1 && + ev.u.mouse.y == co->top + li->bdyAdjust) { + if(li->numItems <= 0) break; + if(li->currItem > 0) { + li->currItem--; + if(li->currItem < li->startShowItem) + li->startShowItem = li->currItem; + if(li->sb) + newtScrollbarSet(li->sb, li->currItem + 1, li->numItems); + listboxDraw(co); + } + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + break; + } + /* Down scroll arrow */ + if (li->sb && + ev.u.mouse.x == co->left + co->width - li->bdxAdjust - 1 && + ev.u.mouse.y == co->top + co->height - li->bdyAdjust - 1) { + if(li->numItems <= 0) break; + if(li->currItem < li->numItems - 1) { + li->currItem++; + if(li->currItem > (li->startShowItem + li->curHeight - 1)) { + li->startShowItem = li->currItem - li->curHeight + 1; + if(li->startShowItem + li->curHeight > li->numItems) + li->startShowItem = li->numItems - li->curHeight; + } + if(li->sb) + newtScrollbarSet(li->sb, li->currItem + 1, li->numItems); + listboxDraw(co); + } + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + break; + } + if ((ev.u.mouse.y >= co->top + li->bdyAdjust) && + (ev.u.mouse.y <= co->top + co->height - (li->bdyAdjust * 2)) && + (ev.u.mouse.x >= co->left + li->bdxAdjust) && + (ev.u.mouse.x <= co->left + co->width + (li->bdxAdjust * 2))) { + li->currItem = li->startShowItem + + (ev.u.mouse.y - li->bdyAdjust - co->top); + newtListboxRealSetCurrent(co); + listboxDraw(co); + if(co->callback) co->callback(co, co->callbackData); + er.result = ER_SWALLOWED; + break; + } + } + + return er; +} + +static void listboxDestroy(newtComponent co) { + struct listbox * li = co->data; + struct items * item, * nextitem; + + nextitem = item = li->boxItems; + + while (item != NULL) { + nextitem = item->next; + free(item->text); + free(item); + item = nextitem; + } + + if (li->sb) li->sb->ops->destroy(li->sb); + + free(li); + free(co); +} diff --git a/mdk-stage1/newt/newt.c b/mdk-stage1/newt/newt.c new file mode 100644 index 000000000..1cfe3ac93 --- /dev/null +++ b/mdk-stage1/newt/newt.c @@ -0,0 +1,672 @@ +#include <slang.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <sys/signal.h> +#include <sys/time.h> +#include <sys/types.h> +#include <termios.h> +#include <unistd.h> + +#include "newt.h" +#include "newt_pr.h" + +struct Window { + int height, width, top, left; + short * buffer; + char * title; +}; + +struct keymap { + char * str; + int code; + char * tc; +}; + +static struct Window windowStack[20]; +static struct Window * currentWindow = NULL; + +static char * helplineStack[20]; +static char ** currentHelpline = NULL; + +static int cursorRow, cursorCol; +static int needResize; +static int cursorOn = 1; + +static const char * defaultHelpLine = +" <Tab>/<Alt-Tab> between elements | <Space> selects | <F12> next screen" +; + +const struct newtColors newtDefaultColorPalette = { + "cyan", "black", /* root fg, bg */ + "black", "blue", /* border fg, bg */ + "white", "blue", /* window fg, bg */ + "white", "black", /* shadow fg, bg */ + "white", "blue", /* title fg, bg */ + "black", "cyan", /* button fg, bg */ + "yellow", "cyan", /* active button fg, bg */ + "yellow", "blue", /* checkbox fg, bg */ + "blue", "brown", /* active checkbox fg, bg */ + "yellow", "blue", /* entry box fg, bg */ + "white", "blue", /* label fg, bg */ + "black", "cyan", /* listbox fg, bg */ + "yellow", "cyan", /* active listbox fg, bg */ + "white", "blue", /* textbox fg, bg */ + "cyan", "black", /* active textbox fg, bg */ + "white", "blue", /* help line */ + "yellow", "blue", /* root text */ + "blue", /* scale full */ + "red", /* scale empty */ + "blue", "cyan", /* disabled entry fg, bg */ + "white", "blue", /* compact button fg, bg */ + "yellow", "red", /* active & sel listbox */ + "black", "brown" /* selected listbox */ +}; + +static const struct keymap keymap[] = { + { "\033OA", NEWT_KEY_UP, "kh" }, + { "\033[A", NEWT_KEY_UP, "ku" }, + { "\033OB", NEWT_KEY_DOWN, "kd" }, + { "\033[B", NEWT_KEY_DOWN, "kd" }, + { "\033[C", NEWT_KEY_RIGHT, "kr" }, + { "\033OC", NEWT_KEY_RIGHT, "kr" }, + { "\033[D", NEWT_KEY_LEFT, "kl" }, + { "\033OD", NEWT_KEY_LEFT, "kl" }, + { "\033[H", NEWT_KEY_HOME, "kh" }, + { "\033[1~", NEWT_KEY_HOME, "kh" }, + { "\033Ow", NEWT_KEY_END, "kH" }, + { "\033[4~", NEWT_KEY_END, "kH" }, + + { "\033[3~", NEWT_KEY_DELETE, "kl" }, + { "\033[2~", NEWT_KEY_INSERT, NULL }, + + { "\033\t", NEWT_KEY_UNTAB, NULL }, + + { "\033[5~", NEWT_KEY_PGUP, NULL }, + { "\033[6~", NEWT_KEY_PGDN, NULL }, + { "\033V", NEWT_KEY_PGUP, "kH" }, + { "\033v", NEWT_KEY_PGUP, "kH" }, + + { "\033[[A", NEWT_KEY_F1, NULL }, + { "\033[[B", NEWT_KEY_F2, NULL }, + { "\033[[C", NEWT_KEY_F3, NULL }, + { "\033[[D", NEWT_KEY_F4, NULL }, + { "\033[[E", NEWT_KEY_F5, NULL }, + + { "\033OP", NEWT_KEY_F1, NULL }, + { "\033OQ", NEWT_KEY_F2, NULL }, + { "\033OR", NEWT_KEY_F3, NULL }, + { "\033OS", NEWT_KEY_F4, NULL }, + + { "\033[11~", NEWT_KEY_F1, NULL }, + { "\033[12~", NEWT_KEY_F2, NULL }, + { "\033[13~", NEWT_KEY_F3, NULL }, + { "\033[14~", NEWT_KEY_F4, NULL }, + { "\033[15~", NEWT_KEY_F5, NULL }, + { "\033[17~", NEWT_KEY_F6, NULL }, + { "\033[18~", NEWT_KEY_F7, NULL }, + { "\033[19~", NEWT_KEY_F8, NULL }, + { "\033[20~", NEWT_KEY_F9, NULL }, + { "\033[21~", NEWT_KEY_F10, NULL }, + { "\033[23~", NEWT_KEY_F11, NULL }, + { "\033[24~", NEWT_KEY_F12, NULL }, + + { NULL, 0, NULL }, /* LEAVE this one */ +}; +static char keyPrefix = '\033'; + +static const char * version = "Newt windowing library version " VERSION + " - (C) 1996-2000 Red Hat Software. " + "Redistributable under the term of the Library " + "GNU Public License. " + "Written by Erik Troan\n"; + +static newtSuspendCallback suspendCallback = NULL; +static void * suspendCallbackData = NULL; + +void newtSetSuspendCallback(newtSuspendCallback cb, void * data) { + suspendCallback = cb; + suspendCallbackData = data; +} + +static void handleSigwinch(int signum) { + needResize = 1; +} + +static int getkeyInterruptHook(void) { + return -1; +} + +void newtFlushInput(void) { + while (SLang_input_pending(0)) { + SLang_getkey(); + } +} + +void newtRefresh(void) { + SLsmg_refresh(); +} + +void newtSuspend(void) { + SLtt_set_cursor_visibility (1); + SLsmg_suspend_smg(); + SLang_reset_tty(); + SLtt_set_cursor_visibility (cursorOn); +} + +void newtResume(void) { + SLsmg_resume_smg (); + SLsmg_refresh(); + SLang_init_tty(0, 0, 0); +} + +void newtCls(void) { + SLsmg_set_color(NEWT_COLORSET_ROOT); + SLsmg_gotorc(0, 0); + SLsmg_erase_eos(); + + newtRefresh(); +} + +#if defined(THIS_DOESNT_WORK) +void newtResizeScreen(int redraw) { + newtPushHelpLine(""); + + SLtt_get_screen_size(); + SLang_init_tty(0, 0, 0); + + SLsmg_touch_lines (0, SLtt_Screen_Rows - 1); + + /* I don't know why I need this */ + SLsmg_refresh(); + + newtPopHelpLine(); + + if (redraw) + SLsmg_refresh(); +} +#endif + +int newtInit(void) { + char * MonoValue, * MonoEnv = "NEWT_MONO"; + + /* use the version variable just to be sure it gets included */ + strlen(version); + + SLtt_get_terminfo(); + SLtt_get_screen_size(); + + MonoValue = getenv(MonoEnv); + if ( MonoValue == NULL ) { + SLtt_Use_Ansi_Colors = 1; + } else { + SLtt_Use_Ansi_Colors = 0; + } + + SLsmg_init_smg(); + SLang_init_tty(0, 0, 0); + + newtSetColors(newtDefaultColorPalette); + newtCursorOff(); + /*initKeymap();*/ + + /*memset(&sa, 0, sizeof(sa)); + sa.sa_handler = handleSigwinch; + sigaction(SIGWINCH, &sa, NULL);*/ + + SLsignal_intr(SIGWINCH, handleSigwinch); + SLang_getkey_intr_hook = getkeyInterruptHook; + + + + return 0; +} + +int newtFinished(void) { + SLsmg_gotorc(SLtt_Screen_Rows - 1, 0); + newtCursorOn(); + SLsmg_refresh(); + SLsmg_reset_smg(); + SLang_reset_tty(); + + return 0; +} + +void newtSetColors(struct newtColors colors) { + SLtt_set_color(NEWT_COLORSET_ROOT, "", colors.rootFg, colors.rootBg); + SLtt_set_color(NEWT_COLORSET_BORDER, "", colors.borderFg, colors.borderBg); + SLtt_set_color(NEWT_COLORSET_WINDOW, "", colors.windowFg, colors.windowBg); + SLtt_set_color(NEWT_COLORSET_SHADOW, "", colors.shadowFg, colors.shadowBg); + SLtt_set_color(NEWT_COLORSET_TITLE, "", colors.titleFg, colors.titleBg); + SLtt_set_color(NEWT_COLORSET_BUTTON, "", colors.buttonFg, colors.buttonBg); + SLtt_set_color(NEWT_COLORSET_ACTBUTTON, "", colors.actButtonFg, + colors.actButtonBg); + SLtt_set_color(NEWT_COLORSET_CHECKBOX, "", colors.checkboxFg, + colors.checkboxBg); + SLtt_set_color(NEWT_COLORSET_ACTCHECKBOX, "", colors.actCheckboxFg, + colors.actCheckboxBg); + SLtt_set_color(NEWT_COLORSET_ENTRY, "", colors.entryFg, colors.entryBg); + SLtt_set_color(NEWT_COLORSET_LABEL, "", colors.labelFg, colors.labelBg); + SLtt_set_color(NEWT_COLORSET_LISTBOX, "", colors.listboxFg, + colors.listboxBg); + SLtt_set_color(NEWT_COLORSET_ACTLISTBOX, "", colors.actListboxFg, + colors.actListboxBg); + SLtt_set_color(NEWT_COLORSET_TEXTBOX, "", colors.textboxFg, + colors.textboxBg); + SLtt_set_color(NEWT_COLORSET_ACTTEXTBOX, "", colors.actTextboxFg, + colors.actTextboxBg); + SLtt_set_color(NEWT_COLORSET_HELPLINE, "", colors.helpLineFg, + colors.helpLineBg); + SLtt_set_color(NEWT_COLORSET_ROOTTEXT, "", colors.rootTextFg, + colors.rootTextBg); + + SLtt_set_color(NEWT_COLORSET_EMPTYSCALE, "", "black", + colors.emptyScale); + SLtt_set_color(NEWT_COLORSET_FULLSCALE, "", "black", + colors.fullScale); + SLtt_set_color(NEWT_COLORSET_DISENTRY, "", colors.disabledEntryFg, + colors.disabledEntryBg); + + SLtt_set_color(NEWT_COLORSET_COMPACTBUTTON, "", colors.compactButtonFg, + colors.compactButtonBg); + + SLtt_set_color(NEWT_COLORSET_ACTSELLISTBOX, "", colors.actSelListboxFg, + colors.actSelListboxBg); + SLtt_set_color(NEWT_COLORSET_SELLISTBOX, "", colors.selListboxFg, + colors.selListboxBg); +} + +int newtGetKey(void) { + int key; + char buf[10], * chptr = buf; + const struct keymap * curr; + + do { + key = SLang_getkey(); + if (key == 0xFFFF) { + if (needResize) + return NEWT_KEY_RESIZE; + + /* ignore other signals */ + continue; + } + + if (key == NEWT_KEY_SUSPEND && suspendCallback) + suspendCallback(suspendCallbackData); + } while (key == NEWT_KEY_SUSPEND); + + switch (key) { + case 'v' | 0x80: + case 'V' | 0x80: + return NEWT_KEY_PGUP; + + case 22: + return NEWT_KEY_PGDN; + + return NEWT_KEY_BKSPC; + case 0x7f: + return NEWT_KEY_BKSPC; + + case 0x08: + return NEWT_KEY_BKSPC; + + default: + if (key != keyPrefix) return key; + } + + memset(buf, 0, sizeof(buf)); + + *chptr++ = key; + while (SLang_input_pending(5)) { + key = SLang_getkey(); + if (key == keyPrefix) { + /* he hit unknown keys too many times -- start over */ + memset(buf, 0, sizeof(buf)); + chptr = buf; + } + + *chptr++ = key; + + /* this search should use bsearch(), but when we only look through + a list of 20 (or so) keymappings, it's probably faster just to + do a inline linear search */ + + for (curr = keymap; curr->code; curr++) { + if (curr->str) { + if (!strcmp(curr->str, buf)) + return curr->code; + } + } + } + + for (curr = keymap; curr->code; curr++) { + if (curr->str) { + if (!strcmp(curr->str, buf)) + return curr->code; + } + } + + /* Looks like we were a bit overzealous in reading characters. Return + just the first character, and put everything else back in the buffer + for later */ + + chptr--; + while (chptr > buf) + SLang_ungetkey(*chptr--); + + return *chptr; +} + +void newtWaitForKey(void) { + newtRefresh(); + + SLang_getkey(); + newtClearKeyBuffer(); +} + +void newtClearKeyBuffer(void) { + while (SLang_input_pending(1)) { + SLang_getkey(); + } +} + +int newtOpenWindow(int left, int top, int width, int height, + const char * title) { + int j, row, col; + int n; + int i; + + newtFlushInput(); + + if (!currentWindow) { + currentWindow = windowStack; + } else { + currentWindow++; + } + + currentWindow->left = left; + currentWindow->top = top; + currentWindow->width = width; + currentWindow->height = height; + currentWindow->title = title ? strdup(title) : NULL; + + currentWindow->buffer = malloc(sizeof(short) * (width + 3) * (height + 3)); + + row = top - 1; + col = left - 1; + n = 0; + for (j = 0; j < height + 3; j++, row++) { + SLsmg_gotorc(row, col); + SLsmg_read_raw(currentWindow->buffer + n, + currentWindow->width + 3); + n += currentWindow->width + 3; + } + + SLsmg_set_color(NEWT_COLORSET_BORDER); + SLsmg_draw_box(top - 1, left - 1, height + 2, width + 2); + + if (currentWindow->title) { + i = strlen(currentWindow->title) + 4; + i = ((width - i) / 2) + left; + SLsmg_gotorc(top - 1, i); + SLsmg_set_char_set(1); + SLsmg_write_char(SLSMG_RTEE_CHAR); + SLsmg_set_char_set(0); + SLsmg_write_char(' '); + SLsmg_set_color(NEWT_COLORSET_TITLE); + SLsmg_write_string((char *)currentWindow->title); + SLsmg_set_color(NEWT_COLORSET_BORDER); + SLsmg_write_char(' '); + SLsmg_set_char_set(1); + SLsmg_write_char(SLSMG_LTEE_CHAR); + SLsmg_set_char_set(0); + } + + SLsmg_set_color(NEWT_COLORSET_WINDOW); + SLsmg_fill_region(top, left, height, width, ' '); + + SLsmg_set_color(NEWT_COLORSET_SHADOW); + SLsmg_fill_region(top + height + 1, left, 1, width + 2, ' '); + SLsmg_fill_region(top, left + width + 1, height + 1, 1, ' '); + + for (i = top; i < (top + height + 1); i++) { + SLsmg_gotorc(i, left + width + 1); + SLsmg_write_string(" "); + } + + return 0; +} + +int newtCenteredWindow(int width, int height, const char * title) { + int top, left; + + top = (SLtt_Screen_Rows - height) / 2; + + /* I don't know why, but this seems to look better */ + if ((SLtt_Screen_Rows % 2) && (top % 2)) top--; + + left = (SLtt_Screen_Cols - width) / 2; + + newtOpenWindow(left, top, width, height, title); + + return 0; +} + +void newtPopWindow(void) { + int j, row, col; + int n = 0; + + row = col = 0; + + row = currentWindow->top - 1; + col = currentWindow->left - 1; + for (j = 0; j < currentWindow->height + 3; j++, row++) { + SLsmg_gotorc(row, col); + SLsmg_write_raw(currentWindow->buffer + n, + currentWindow->width + 3); + n += currentWindow->width + 3; + } + + free(currentWindow->buffer); + free(currentWindow->title); + + if (currentWindow == windowStack) + currentWindow = NULL; + else + currentWindow--; + + SLsmg_set_char_set(0); + + newtRefresh(); +} + +void newtGetWindowPos(int * x, int * y) { + if (currentWindow) { + *x = currentWindow->left; + *y = currentWindow->top; + } else + *x = *y = 0; +} + +void newtGetrc(int * row, int * col) { + *row = cursorRow; + *col = cursorCol; +} + +void newtGotorc(int newRow, int newCol) { + if (currentWindow) { + newRow += currentWindow->top; + newCol += currentWindow->left; + } + + cursorRow = newRow; + cursorCol = newCol; + SLsmg_gotorc(cursorRow, cursorCol); +} + +void newtDrawBox(int left, int top, int width, int height, int shadow) { + if (currentWindow) { + top += currentWindow->top; + left += currentWindow->left; + } + + SLsmg_draw_box(top, left, height, width); + + if (shadow) { + SLsmg_set_color(NEWT_COLORSET_SHADOW); + SLsmg_fill_region(top + height, left + 1, 1, width - 1, ' '); + SLsmg_fill_region(top + 1, left + width, height, 1, ' '); + } +} + +void newtClearBox(int left, int top, int width, int height) { + if (currentWindow) { + top += currentWindow->top; + left += currentWindow->left; + } + + SLsmg_fill_region(top, left, height, width, ' '); +} + +#if 0 +/* This doesn't seem to work quite right. I don't know why not, but when + I rsh from an rxvt into a box and run this code, the machine returns + console key's (\033[B) rather then xterm ones (\033OB). */ +static void initKeymap(void) { + struct keymap * curr; + + for (curr = keymap; curr->code; curr++) { + if (!curr->str) + curr->str = SLtt_tgetstr(curr->tc); + } + + /* Newt's keymap handling is a bit broken. It assumes that any extended + keystrokes begin with ESC. If you're using a homebrek terminal you + will probably need to fix this, or just yell at me and I'll be so + ashamed of myself for doing it this way I'll fix it */ + + keyPrefix = 0x1b; /* ESC */ +} +#endif + +void newtDelay(int usecs) { + fd_set set; + struct timeval tv; + + FD_ZERO(&set); + + tv.tv_sec = usecs / 1000000; + tv.tv_usec = usecs % 1000000; + + select(0, &set, &set, &set, &tv); +} + +struct eventResult newtDefaultEventHandler(newtComponent c, + struct event ev) { + struct eventResult er; + + er.result = ER_IGNORED; + return er; +} + +void newtRedrawHelpLine(void) { + char * buf; + + SLsmg_set_color(NEWT_COLORSET_HELPLINE); + + buf = alloca(SLtt_Screen_Cols + 1); + memset(buf, ' ', SLtt_Screen_Cols); + buf[SLtt_Screen_Cols] = '\0'; + + if (currentHelpline) + memcpy(buf, *currentHelpline, strlen(*currentHelpline)); + + SLsmg_gotorc(SLtt_Screen_Rows - 1, 0); + SLsmg_write_string(buf); +} + +void newtPushHelpLine(const char * text) { + if (!text) + text = defaultHelpLine; + + if (currentHelpline) + (*(++currentHelpline)) = strdup(text); + else { + currentHelpline = helplineStack; + *currentHelpline = strdup(text); + } + + newtRedrawHelpLine(); +} + +void newtPopHelpLine(void) { + if (!currentHelpline) return; + + free(*currentHelpline); + if (currentHelpline == helplineStack) + currentHelpline = NULL; + else + currentHelpline--; + + newtRedrawHelpLine(); +} + +void newtDrawRootText(int col, int row, const char * text) { + SLsmg_set_color(NEWT_COLORSET_ROOTTEXT); + + if (col < 0) { + col = SLtt_Screen_Cols + col; + } + + if (row < 0) { + row = SLtt_Screen_Rows + row; + } + + SLsmg_gotorc(row, col); + SLsmg_write_string((char *)text); +} + +int newtSetFlags(int oldFlags, int newFlags, enum newtFlagsSense sense) { + switch (sense) { + case NEWT_FLAGS_SET: + return oldFlags | newFlags; + + case NEWT_FLAGS_RESET: + return oldFlags & (~newFlags); + + case NEWT_FLAGS_TOGGLE: + return oldFlags ^ newFlags; + + default: + return oldFlags; + } +} + +void newtBell(void) +{ + SLtt_beep(); +} + +void newtGetScreenSize(int * cols, int * rows) { + if (rows) *rows = SLtt_Screen_Rows; + if (cols) *cols = SLtt_Screen_Cols; +} + +void newtDefaultPlaceHandler(newtComponent c, int newLeft, int newTop) { + c->left = newLeft; + c->top = newTop; +} + +void newtDefaultMappedHandler(newtComponent c, int isMapped) { + c->isMapped = isMapped; +} + +void newtCursorOff(void) { + cursorOn = 0; + SLtt_set_cursor_visibility (cursorOn); +} + +void newtCursorOn(void) { + cursorOn = 1; + SLtt_set_cursor_visibility (cursorOn); +} diff --git a/mdk-stage1/newt/newt.h b/mdk-stage1/newt/newt.h new file mode 100644 index 000000000..d3fd8bedc --- /dev/null +++ b/mdk-stage1/newt/newt.h @@ -0,0 +1,362 @@ +#ifndef H_NEWT +#define H_NEWT + +#ifdef __cplusplus +extern "C" { +#endif + +#include <stdarg.h> + +#define NEWT_COLORSET_ROOT 2 +#define NEWT_COLORSET_BORDER 3 +#define NEWT_COLORSET_WINDOW 4 +#define NEWT_COLORSET_SHADOW 5 +#define NEWT_COLORSET_TITLE 6 +#define NEWT_COLORSET_BUTTON 7 +#define NEWT_COLORSET_ACTBUTTON 8 +#define NEWT_COLORSET_CHECKBOX 9 +#define NEWT_COLORSET_ACTCHECKBOX 10 +#define NEWT_COLORSET_ENTRY 11 +#define NEWT_COLORSET_LABEL 12 +#define NEWT_COLORSET_LISTBOX 13 +#define NEWT_COLORSET_ACTLISTBOX 14 +#define NEWT_COLORSET_TEXTBOX 15 +#define NEWT_COLORSET_ACTTEXTBOX 16 +#define NEWT_COLORSET_HELPLINE 17 +#define NEWT_COLORSET_ROOTTEXT 18 +#define NEWT_COLORSET_EMPTYSCALE 19 +#define NEWT_COLORSET_FULLSCALE 20 +#define NEWT_COLORSET_DISENTRY 21 +#define NEWT_COLORSET_COMPACTBUTTON 22 +#define NEWT_COLORSET_ACTSELLISTBOX 23 +#define NEWT_COLORSET_SELLISTBOX 24 + +#define NEWT_ARG_LAST -100000 +#define NEWT_ARG_APPEND -1 + +struct newtColors { + char * rootFg, * rootBg; + char * borderFg, * borderBg; + char * windowFg, * windowBg; + char * shadowFg, * shadowBg; + char * titleFg, * titleBg; + char * buttonFg, * buttonBg; + char * actButtonFg, * actButtonBg; + char * checkboxFg, * checkboxBg; + char * actCheckboxFg, * actCheckboxBg; + char * entryFg, * entryBg; + char * labelFg, * labelBg; + char * listboxFg, * listboxBg; + char * actListboxFg, * actListboxBg; + char * textboxFg, * textboxBg; + char * actTextboxFg, * actTextboxBg; + char * helpLineFg, * helpLineBg; + char * rootTextFg, * rootTextBg; + char * emptyScale, * fullScale; + char * disabledEntryFg, * disabledEntryBg; + char * compactButtonFg, * compactButtonBg; + char * actSelListboxFg, * actSelListboxBg; + char * selListboxFg, * selListboxBg; +}; + +enum newtFlagsSense { NEWT_FLAGS_SET, NEWT_FLAGS_RESET, NEWT_FLAGS_TOGGLE }; + +#define NEWT_FLAG_RETURNEXIT (1 << 0) +#define NEWT_FLAG_HIDDEN (1 << 1) +#define NEWT_FLAG_SCROLL (1 << 2) +#define NEWT_FLAG_DISABLED (1 << 3) +/* OBSOLETE #define NEWT_FLAG_NOSCROLL (1 << 4) for listboxes */ +#define NEWT_FLAG_BORDER (1 << 5) +#define NEWT_FLAG_WRAP (1 << 6) +#define NEWT_FLAG_NOF12 (1 << 7) +#define NEWT_FLAG_MULTIPLE (1 << 8) +#define NEWT_FLAG_SELECTED (1 << 9) +#define NEWT_FLAG_CHECKBOX (1 << 10) +#define NEWT_FLAG_PASSWORD (1 << 11) /* draw '*' of chars in entrybox */ +#define NEWT_FD_READ (1 << 0) +#define NEWT_FD_WRITE (1 << 1) + +#define NEWT_CHECKBOXTREE_COLLAPSED '\0' +#define NEWT_CHECKBOXTREE_EXPANDED '\1' +#define NEWT_CHECKBOXTREE_UNSELECTED ' ' +#define NEWT_CHECKBOXTREE_SELECTED '*' + +/* Backwards compatibility */ +#define NEWT_LISTBOX_RETURNEXIT NEWT_FLAG_RETURNEXIT +#define NEWT_ENTRY_SCROLL NEWT_FLAG_SCROLL +#define NEWT_ENTRY_HIDDEN NEWT_FLAG_HIDDEN +#define NEWT_ENTRY_RETURNEXIT NEWT_FLAG_RETURNEXIT +#define NEWT_ENTRY_DISABLED NEWT_FLAG_DISABLED + +#define NEWT_TEXTBOX_WRAP NEWT_FLAG_WRAP +#define NEWT_TEXTBOX_SCROLL NEWT_FLAG_SCROLL +#define NEWT_FORM_NOF12 NEWT_FLAG_NOF12 + +#define newtListboxAddEntry newtListboxAppendEntry + + +typedef struct newtComponent_struct * newtComponent; + +extern const struct newtColors newtDefaultColorPalette; + +typedef void (*newtCallback)(newtComponent, void *); +typedef void (*newtSuspendCallback)(void * data); + +int newtInit(void); +int newtFinished(void); +void newtCls(void); +void newtResizeScreen(int redraw); +void newtWaitForKey(void); +void newtClearKeyBuffer(void); +void newtDelay(int usecs); +/* top, left are *not* counting the border */ +int newtOpenWindow(int left, int top, int width, int height, + const char * title); +int newtCenteredWindow(int width, int height, const char * title); +void newtPopWindow(void); +void newtSetColors(struct newtColors colors); +void newtRefresh(void); +void newtSuspend(void); +void newtSetSuspendCallback(newtSuspendCallback cb, void * data); +void newtSetHelpCallback(newtCallback cb); +void newtResume(void); +void newtPushHelpLine(const char * text); +void newtRedrawHelpLine(void); +void newtPopHelpLine(void); +void newtDrawRootText(int col, int row, const char * text); +void newtBell(void); +void newtCursorOff(void); +void newtCursorOn(void); + +/* Components */ + +newtComponent newtCompactButton(int left, int top, const char * text); +newtComponent newtButton(int left, int top, const char * text); +newtComponent newtCheckbox(int left, int top, const char * text, char defValue, + const char * seq, char * result); +char newtCheckboxGetValue(newtComponent co); +void newtCheckboxSetValue(newtComponent co, char value); +void newtCheckboxSetFlags(newtComponent co, int flags, enum newtFlagsSense sense); + + +newtComponent newtRadiobutton(int left, int top, const char * text, int isDefault, + newtComponent prevButton); +newtComponent newtRadioGetCurrent(newtComponent setMember); +newtComponent newtListitem(int left, int top, const char * text, int isDefault, + newtComponent prevItem, const void * data, int flags); +void newtListitemSet(newtComponent co, const char * text); +void * newtListitemGetData(newtComponent co); +void newtGetScreenSize(int * cols, int * rows); + +newtComponent newtLabel(int left, int top, const char * text); +void newtLabelSetText(newtComponent co, const char * text); +newtComponent newtVerticalScrollbar(int left, int top, int height, + int normalColorset, int thumbColorset); +void newtScrollbarSet(newtComponent co, int where, int total); + +newtComponent newtListbox(int left, int top, int height, int flags); +void * newtListboxGetCurrent(newtComponent co); +void newtListboxSetCurrent(newtComponent co, int num); +void newtListboxSetCurrentByKey(newtComponent co, void * key); +void newtListboxSetEntry(newtComponent co, int num, const char * text); +void newtListboxSetWidth(newtComponent co, int width); +void newtListboxSetData(newtComponent co, int num, void * data); +int newtListboxAppendEntry(newtComponent co, const char * text, + const void * data); +/* Send the key to insert after, or NULL to insert at the top */ +int newtListboxInsertEntry(newtComponent co, const char * text, const void * data, void * key); +int newtListboxDeleteEntry(newtComponent co, void * data); +void newtListboxClear(newtComponent co); /* removes all entries from listbox */ +void newtListboxGetEntry(newtComponent co, int num, char **text, void **data); +/* Returns an array of data pointers from items, last element is NULL */ +void **newtListboxGetSelection(newtComponent co, int *numitems); +void newtListboxClearSelection(newtComponent co); +void newtListboxSelectItem(newtComponent co, const void * key, + enum newtFlagsSense sense); + +newtComponent newtCheckboxTree(int left, int top, int height, int flags); +newtComponent newtCheckboxTreeMulti(int left, int top, int height, char *seq, int flags); +const void ** newtCheckboxTreeGetSelection(newtComponent co, int *numitems); +const void * newtCheckboxTreeGetCurrent(newtComponent co); +const void ** newtCheckboxTreeGetMultiSelection(newtComponent co, int *numitems, char seqnum); +/* last item is NEWT_ARG_LAST for all of these */ +int newtCheckboxTreeAddItem(newtComponent co, + const char * text, const void * data, + int flags, int index, ...); +int newtCheckboxTreeAddArray(newtComponent co, + const char * text, const void * data, + int flags, int * indexes); +int * newtCheckboxTreeFindItem(newtComponent co, void * data); +void newtCheckboxTreeSetEntry(newtComponent co, const void * data, + const char * text); +char newtCheckboxTreeGetEntryValue(newtComponent co, const void * data); +void newtCheckboxTreeSetEntryValue(newtComponent co, const void * data, + char value); + +newtComponent newtTextboxReflowed(int left, int top, char * text, int width, + int flexDown, int flexUp, int flags); +newtComponent newtTextbox(int left, int top, int width, int height, int flags); +void newtTextboxSetText(newtComponent co, const char * text); +void newtTextboxSetHeight(newtComponent co, int height); +int newtTextboxGetNumLines(newtComponent co); +char * newtReflowText(char * text, int width, int flexDown, int flexUp, + int * actualWidth, int * actualHeight); + +struct newtExitStruct { + enum { NEWT_EXIT_HOTKEY, NEWT_EXIT_COMPONENT, NEWT_EXIT_FDREADY, + NEWT_EXIT_TIMER } reason; + union { + int key; + newtComponent co; + } u; +} ; + +newtComponent newtForm(newtComponent vertBar, void * helpTag, int flags); +void newtFormSetTimer(newtComponent form, int millisecs); +void newtFormWatchFd(newtComponent form, int fd, int fdFlags); +void newtFormSetSize(newtComponent co); +newtComponent newtFormGetCurrent(newtComponent co); +void newtFormSetBackground(newtComponent co, int color); +void newtFormSetCurrent(newtComponent co, newtComponent subco); +void newtFormAddComponent(newtComponent form, newtComponent co); +void newtFormAddComponents(newtComponent form, ...); +void newtFormSetHeight(newtComponent co, int height); +void newtFormSetWidth(newtComponent co, int width); +newtComponent newtRunForm(newtComponent form); /* obsolete */ +void newtFormRun(newtComponent co, struct newtExitStruct * es); +void newtDrawForm(newtComponent form); +void newtFormAddHotKey(newtComponent co, int key); + +typedef int (*newtEntryFilter)(newtComponent entry, void * data, int ch, + int cursor); +newtComponent newtEntry(int left, int top, const char * initialValue, int width, + char ** resultPtr, int flags); +void newtEntrySet(newtComponent co, const char * value, int cursorAtEnd); +void newtEntrySetFilter(newtComponent co, newtEntryFilter filter, void * data); +char * newtEntryGetValue(newtComponent co); +void newtEntrySetFlags(newtComponent co, int flags, enum newtFlagsSense sense); + +newtComponent newtScale(int left, int top, int width, int fullValue); +void newtScaleSet(newtComponent co, unsigned int amount); + +void newtComponentAddCallback(newtComponent co, newtCallback f, void * data); +void newtComponentTakesFocus(newtComponent co, int val); + +/* this also destroys all of the components (including other forms) on the + form */ +void newtFormDestroy(newtComponent form); + +/* Key codes */ + +#define NEWT_KEY_TAB '\t' +#define NEWT_KEY_ENTER '\r' +#define NEWT_KEY_SUSPEND '\032' /* ctrl - z*/ +#define NEWT_KEY_RETURN NEWT_KEY_ENTER + +#define NEWT_KEY_EXTRA_BASE 0x8000 +#define NEWT_KEY_UP NEWT_KEY_EXTRA_BASE + 1 +#define NEWT_KEY_DOWN NEWT_KEY_EXTRA_BASE + 2 +#define NEWT_KEY_LEFT NEWT_KEY_EXTRA_BASE + 4 +#define NEWT_KEY_RIGHT NEWT_KEY_EXTRA_BASE + 5 +#define NEWT_KEY_BKSPC NEWT_KEY_EXTRA_BASE + 6 +#define NEWT_KEY_DELETE NEWT_KEY_EXTRA_BASE + 7 +#define NEWT_KEY_HOME NEWT_KEY_EXTRA_BASE + 8 +#define NEWT_KEY_END NEWT_KEY_EXTRA_BASE + 9 +#define NEWT_KEY_UNTAB NEWT_KEY_EXTRA_BASE + 10 +#define NEWT_KEY_PGUP NEWT_KEY_EXTRA_BASE + 11 +#define NEWT_KEY_PGDN NEWT_KEY_EXTRA_BASE + 12 +#define NEWT_KEY_INSERT NEWT_KEY_EXTRA_BASE + 13 + +#define NEWT_KEY_F1 NEWT_KEY_EXTRA_BASE + 101 +#define NEWT_KEY_F2 NEWT_KEY_EXTRA_BASE + 102 +#define NEWT_KEY_F3 NEWT_KEY_EXTRA_BASE + 103 +#define NEWT_KEY_F4 NEWT_KEY_EXTRA_BASE + 104 +#define NEWT_KEY_F5 NEWT_KEY_EXTRA_BASE + 105 +#define NEWT_KEY_F6 NEWT_KEY_EXTRA_BASE + 106 +#define NEWT_KEY_F7 NEWT_KEY_EXTRA_BASE + 107 +#define NEWT_KEY_F8 NEWT_KEY_EXTRA_BASE + 108 +#define NEWT_KEY_F9 NEWT_KEY_EXTRA_BASE + 109 +#define NEWT_KEY_F10 NEWT_KEY_EXTRA_BASE + 110 +#define NEWT_KEY_F11 NEWT_KEY_EXTRA_BASE + 111 +#define NEWT_KEY_F12 NEWT_KEY_EXTRA_BASE + 112 + +/* not really a key, but newtGetKey returns it */ +#define NEWT_KEY_RESIZE NEWT_KEY_EXTRA_BASE + 113 + +#define NEWT_ANCHOR_LEFT (1 << 0) +#define NEWT_ANCHOR_RIGHT (1 << 1) +#define NEWT_ANCHOR_TOP (1 << 2) +#define NEWT_ANCHOR_BOTTOM (1 << 3) + +#define NEWT_GRID_FLAG_GROWX (1 << 0) +#define NEWT_GRID_FLAG_GROWY (1 << 1) + +typedef struct grid_s * newtGrid; +enum newtGridElement { NEWT_GRID_EMPTY = 0, + NEWT_GRID_COMPONENT, NEWT_GRID_SUBGRID }; + +newtGrid newtCreateGrid(int cols, int rows); +/* TYPE, what, TYPE, what, ..., NULL */ +newtGrid newtGridVStacked(enum newtGridElement type, void * what, ...); +newtGrid newtGridVCloseStacked(enum newtGridElement type, void * what, ...); +newtGrid newtGridHStacked(enum newtGridElement type1, void * what1, ...); +newtGrid newtGridHCloseStacked(enum newtGridElement type1, void * what1, ...); +newtGrid newtGridBasicWindow(newtComponent text, newtGrid middle, + newtGrid buttons); +newtGrid newtGridSimpleWindow(newtComponent text, newtComponent middle, + newtGrid buttons); +void newtGridSetField(newtGrid grid, int col, int row, + enum newtGridElement type, void * val, int padLeft, + int padTop, int padRight, int padBottom, int anchor, + int flags); +void newtGridPlace(newtGrid grid, int left, int top); +#define newtGridDestroy newtGridFree +void newtGridFree(newtGrid grid, int recurse); +void newtGridGetSize(newtGrid grid, int * width, int * height); +void newtGridWrappedWindow(newtGrid grid, char * title); +void newtGridWrappedWindowAt(newtGrid grid, char * title, int left, int top); +void newtGridAddComponentsToForm(newtGrid grid, newtComponent form, + int recurse); + +/* convienve */ +newtGrid newtButtonBarv(char * button1, newtComponent * b1comp, va_list args); +newtGrid newtButtonBar(char * button1, newtComponent * b1comp, ...); + +/* automatically centered and shrink wrapped */ +void newtWinMessage(char * title, char * buttonText, char * text, ...); +void newtWinMessagev(char * title, char * buttonText, char * text, + va_list argv); + +/* having separate calls for these two seems silly, but having two separate + variable length-arg lists seems like a bad idea as well */ + +/* Returns 0 if F12 was pressed, 1 for button1, 2 for button2 */ +int newtWinChoice(char * title, char * button1, char * button2, + char * text, ...); +/* Returns 0 if F12 was pressed, 1 for button1, 2 for button2, + 3 for button3 */ +int newtWinTernary(char * title, char * button1, char * button2, + char * button3, char * message, ...); + +/* Returns the button number pressed, 0 on F12 */ +int newtWinMenu(char * title, char * text, int suggestedWidth, int flexDown, + int flexUp, int maxListHeight, char ** items, int * listItem, + char * button1, ...); + +struct newtWinEntry { + char * text; + char ** value; /* may be initialized to set default */ + int flags; +}; + +/* Returns the button number pressed, 0 on F12. The final values are + dynamically allocated, and need to be freed. */ +int newtWinEntries(char * title, char * text, int suggestedWidth, int flexDown, + int flexUp, int dataWidth, + struct newtWinEntry * items, char * button1, ...); + +#ifdef __cplusplus +} /* End of extern "C" { */ +#endif + +#endif /* H_NEWT */ diff --git a/mdk-stage1/newt/newt_pr.h b/mdk-stage1/newt/newt_pr.h new file mode 100644 index 000000000..76f5e2f6f --- /dev/null +++ b/mdk-stage1/newt/newt_pr.h @@ -0,0 +1,82 @@ +#ifndef H_NEWT_PR +#define H_NEWT_PR + +#define COLORSET_ROOT NEWT_COLORSET_ROOT +#define COLORSET_BORDER NEWT_COLORSET_BORDER +#define COLORSET_WINDOW NEWT_COLORSET_WINDOW +#define COLORSET_SHADOW NEWT_COLORSET_SHADOW +#define COLORSET_TITLE NEWT_COLORSET_TITLE +#define COLORSET_BUTTON NEWT_COLORSET_BUTTON +#define COLORSET_ACTBUTTON NEWT_COLORSET_ACTBUTTON +#define COLORSET_CHECKBOX NEWT_COLORSET_CHECKBOX +#define COLORSET_ACTCHECKBOX NEWT_COLORSET_ACTCHECKBOX +#define COLORSET_ENTRY NEWT_COLORSET_ENTRY +#define COLORSET_LABEL NEWT_COLORSET_LABEL +#define COLORSET_LISTBOX NEWT_COLORSET_LISTBOX +#define COLORSET_ACTLISTBOX NEWT_COLORSET_ACTLISTBOX +#define COLORSET_TEXTBOX NEWT_COLORSET_TEXTBOX +#define COLORSET_ACTTEXTBOX NEWT_COLORSET_ACTTEXTBOX + +int newtSetFlags(int oldFlags, int newFlags, enum newtFlagsSense sense); + +void newtGotorc(int row, int col); +void newtGetrc(int * row, int * col); +void newtGetWindowPos(int * x, int * y); +void newtDrawBox(int left, int top, int width, int height, int shadow); +void newtClearBox(int left, int top, int width, int height); + +int newtGetKey(void); + +struct newtComponent_struct { + /* common data */ + int height, width; + int top, left; + int takesFocus; + int isMapped; + + struct componentOps * ops; + + newtCallback callback; + void * callbackData; + + void * data; +} ; + +enum eventResultTypes { ER_IGNORED, ER_SWALLOWED, ER_EXITFORM, ER_SETFOCUS, + ER_NEXTCOMP }; +struct eventResult { + enum eventResultTypes result; + union { + newtComponent focus; + } u; +}; + +enum eventTypes { EV_FOCUS, EV_UNFOCUS, EV_KEYPRESS, EV_MOUSE }; +enum eventSequence { EV_EARLY, EV_NORMAL, EV_LATE }; + +struct event { + enum eventTypes event; + enum eventSequence when; + union { + int key; + struct { + enum { MOUSE_MOTION, MOUSE_BUTTON_DOWN, MOUSE_BUTTON_UP } type; + int x, y; + } mouse; + } u; +} ; + +struct componentOps { + void (* draw)(newtComponent c); + struct eventResult (* event)(newtComponent c, struct event ev); + void (* destroy)(newtComponent c); + void (* place)(newtComponent c, int newLeft, int newTop); + void (* mapped)(newtComponent c, int isMapped); +} ; + +void newtDefaultPlaceHandler(newtComponent c, int newLeft, int newTop); +void newtDefaultMappedHandler(newtComponent c, int isMapped); +struct eventResult newtDefaultEventHandler(newtComponent c, + struct event ev); + +#endif /* H_NEWT_PR */ diff --git a/mdk-stage1/newt/scale.c b/mdk-stage1/newt/scale.c new file mode 100644 index 000000000..800958580 --- /dev/null +++ b/mdk-stage1/newt/scale.c @@ -0,0 +1,72 @@ +#include <slang.h> +#include <stdlib.h> +#include <string.h> + +#include "newt.h" +#include "newt_pr.h" + +struct scale { + int fullValue; + int charsSet; +}; + +static void scaleDraw(newtComponent co); + +static struct componentOps scaleOps = { + scaleDraw, + newtDefaultEventHandler, + NULL, + newtDefaultPlaceHandler, + newtDefaultMappedHandler, +} ; + +newtComponent newtScale(int left, int top, int width, int fullValue) { + newtComponent co; + struct scale * sc; + + co = malloc(sizeof(*co)); + sc = malloc(sizeof(struct scale)); + co->data = sc; + + co->ops = &scaleOps; + + co->height = 1; + co->width = width; + co->top = top; + co->left = left; + co->takesFocus = 0; + + sc->fullValue = fullValue; + sc->charsSet = 0; + + return co; +} + +void newtScaleSet(newtComponent co, unsigned int amount) { + struct scale * sc = co->data; + int newCharsSet; + + newCharsSet = (amount * co->width) / sc->fullValue; + + if (newCharsSet != sc->charsSet) { + sc->charsSet = newCharsSet; + scaleDraw(co); + } +} + +static void scaleDraw(newtComponent co) { + struct scale * sc = co->data; + int i; + + if (co->top == -1) return; + + newtGotorc(co->top, co->left); + + SLsmg_set_color(NEWT_COLORSET_FULLSCALE); + for (i = 0; i < sc->charsSet; i++) + SLsmg_write_string(" "); + + SLsmg_set_color(NEWT_COLORSET_EMPTYSCALE); + for (i = 0; i < (co->width - sc->charsSet); i++) + SLsmg_write_string(" "); +} diff --git a/mdk-stage1/newt/scrollbar.c b/mdk-stage1/newt/scrollbar.c new file mode 100644 index 000000000..cb4bc2757 --- /dev/null +++ b/mdk-stage1/newt/scrollbar.c @@ -0,0 +1,124 @@ +#include <slang.h> +#include <stdlib.h> +#include <string.h> + +#include "newt.h" +#include "newt_pr.h" + +struct scrollbar { + int curr; + int cs, csThumb; + int arrows; +} ; + +static void sbDraw(newtComponent co); +static void sbDestroy(newtComponent co); +static void sbDrawThumb(newtComponent co, int isOn); + +static struct componentOps sbOps = { + sbDraw, + newtDefaultEventHandler, + sbDestroy, + newtDefaultPlaceHandler, + newtDefaultMappedHandler, +} ; + +void newtScrollbarSet(newtComponent co, int where, int total) { + struct scrollbar * sb = co->data; + int new; + + if (sb->arrows) + new = (where * (co->height - 3)) / (total ? total : 1) + 1; + else + new = (where * (co->height - 1)) / (total ? total : 1); + if (new != sb->curr) { + sbDrawThumb(co, 0); + sb->curr = new; + sbDrawThumb(co, 1); + } +} + +newtComponent newtVerticalScrollbar(int left, int top, int height, + int normalColorset, int thumbColorset) { + newtComponent co; + struct scrollbar * sb; + + co = malloc(sizeof(*co)); + sb = malloc(sizeof(*sb)); + co->data = sb; + + if (!strcmp(getenv("TERM"), "linux") && height >= 2) { + sb->arrows = 1; + sb->curr = 1; + } else { + sb->arrows = 0; + sb->curr = 0; + } + sb->cs = normalColorset; + sb->csThumb = thumbColorset; + + co->ops = &sbOps; + co->isMapped = 0; + co->left = left; + co->top = top; + co->height = height; + co->width = 1; + co->takesFocus = 0; + + return co; +} + +static void sbDraw(newtComponent co) { + struct scrollbar * sb = co->data; + int i; + + if (!co->isMapped) return; + + SLsmg_set_color(sb->cs); + + SLsmg_set_char_set(1); + if (sb->arrows) { + newtGotorc(co->top, co->left); + SLsmg_write_char('\x2d'); + for (i = 1; i < co->height - 1; i++) { + newtGotorc(i + co->top, co->left); + SLsmg_write_char('\x61'); + } + newtGotorc(co->top + co->height - 1, co->left); + SLsmg_write_char('\x2e'); + } else { + for (i = 0; i < co->height; i++) { + newtGotorc(i + co->top, co->left); + SLsmg_write_char('\x61'); + } + } + + SLsmg_set_char_set(0); + + sbDrawThumb(co, 1); +} + +static void sbDrawThumb(newtComponent co, int isOn) { + struct scrollbar * sb = co->data; + char ch = isOn ? '#' : '\x61'; + + if (!co->isMapped) return; + + newtGotorc(sb->curr + co->top, co->left); + SLsmg_set_char_set(1); + + /*if (isOn) + SLsmg_set_color(sb->csThumb); + else*/ + SLsmg_set_color(sb->cs); + + SLsmg_write_char(ch); + SLsmg_set_char_set(0); +} + +static void sbDestroy(newtComponent co) { + struct scrollbar * sb = co->data; + + free(sb); + free(co); +} diff --git a/mdk-stage1/newt/textbox.c b/mdk-stage1/newt/textbox.c new file mode 100644 index 000000000..272c9b675 --- /dev/null +++ b/mdk-stage1/newt/textbox.c @@ -0,0 +1,409 @@ +#include <ctype.h> +#include <slang.h> +#include <stdlib.h> +#include <string.h> + +#include "newt.h" +#include "newt_pr.h" + +struct textbox { + char ** lines; + int numLines; + int linesAlloced; + int doWrap; + newtComponent sb; + int topLine; + int textWidth; +}; + +static char * expandTabs(const char * text); +static void textboxDraw(newtComponent co); +static void addLine(newtComponent co, const char * s, int len); +static void doReflow(const char * text, char ** resultPtr, int width, + int * badness, int * heightPtr); +static struct eventResult textboxEvent(newtComponent c, + struct event ev); +static void textboxDestroy(newtComponent co); +static void textboxPlace(newtComponent co, int newLeft, int newTop); +static void textboxMapped(newtComponent co, int isMapped); + +static struct componentOps textboxOps = { + textboxDraw, + textboxEvent, + textboxDestroy, + textboxPlace, + textboxMapped, +} ; + +static void textboxMapped(newtComponent co, int isMapped) { + struct textbox * tb = co->data; + + co->isMapped = isMapped; + if (tb->sb) + tb->sb->ops->mapped(tb->sb, isMapped); +} + +static void textboxPlace(newtComponent co, int newLeft, int newTop) { + struct textbox * tb = co->data; + + co->top = newTop; + co->left = newLeft; + + if (tb->sb) + tb->sb->ops->place(tb->sb, co->left + co->width - 1, co->top); +} + +void newtTextboxSetHeight(newtComponent co, int height) { + co->height = height; +} + +int newtTextboxGetNumLines(newtComponent co) { + struct textbox * tb = co->data; + + return (tb->numLines); +} + +newtComponent newtTextboxReflowed(int left, int top, char * text, int width, + int flexDown, int flexUp, int flags) { + newtComponent co; + char * reflowedText; + int actWidth, actHeight; + + reflowedText = newtReflowText(text, width, flexDown, flexUp, + &actWidth, &actHeight); + + co = newtTextbox(left, top, actWidth, actHeight, NEWT_FLAG_WRAP); + newtTextboxSetText(co, reflowedText); + free(reflowedText); + + return co; +} + +newtComponent newtTextbox(int left, int top, int width, int height, int flags) { + newtComponent co; + struct textbox * tb; + + co = malloc(sizeof(*co)); + tb = malloc(sizeof(*tb)); + co->data = tb; + + co->ops = &textboxOps; + + co->height = height; + co->top = top; + co->left = left; + co->takesFocus = 0; + co->width = width; + + tb->doWrap = flags & NEWT_FLAG_WRAP; + tb->numLines = 0; + tb->linesAlloced = 0; + tb->lines = NULL; + tb->topLine = 0; + tb->textWidth = width; + + if (flags & NEWT_FLAG_SCROLL) { + co->width += 2; + tb->sb = newtVerticalScrollbar(co->left + co->width - 1, co->top, + co->height, COLORSET_TEXTBOX, COLORSET_TEXTBOX); + } else { + tb->sb = NULL; + } + + return co; +} + +static char * expandTabs(const char * text) { + int bufAlloced = strlen(text) + 40; + char * buf, * dest; + const char * src; + int bufUsed = 0; + int linePos = 0; + int i; + + buf = malloc(bufAlloced + 1); + for (src = text, dest = buf; *src; src++) { + if ((bufUsed + 10) > bufAlloced) { + bufAlloced += strlen(text) / 2; + buf = realloc(buf, bufAlloced + 1); + dest = buf + bufUsed; + } + if (*src == '\t') { + i = 8 - (linePos & 8); + memset(dest, ' ', i); + dest += i, bufUsed += i, linePos += i; + } else { + if (*src == '\n') + linePos = 0; + else + linePos++; + + *dest++ = *src; + bufUsed++; + } + } + + *dest = '\0'; + return buf; +} + +#define iseuckanji(c) (0xa1 <= (unsigned char)(c&0xff) && (unsigned char)(c&0xff) <= 0xfe) + +static void doReflow(const char * text, char ** resultPtr, int width, + int * badness, int * heightPtr) { + char * result = NULL; + const char * chptr, * end; + int i; + int howbad = 0; + int height = 0; + int kanji = 0; + + if (resultPtr) { + /* XXX I think this will work */ + result = malloc(strlen(text) + (strlen(text) / width) + 50); + *result = '\0'; + } + + while (*text) { + kanji = 0; + end = strchr(text, '\n'); + if (!end) + end = text + strlen(text); + + while (*text && text < end) { + if (end - text < width) { + if (result) { + strncat(result, text, end - text + 1); + strcat(result, "\n"); + height++; + } + + if (end - text < (width / 2)) + howbad += ((width / 2) - (end - text)) / 2; + text = end; + if (*text) text++; + } else { + chptr = text; + kanji = 0; + for ( i = 0; i < width - 1; i++ ) { + if ( !iseuckanji(*chptr)) { + kanji = 0; + } else if ( kanji == 1 ) { + kanji = 2; + } else { + kanji = 1; + } + chptr++; + } + if (kanji == 0) { + while (chptr > text && !isspace(*chptr)) chptr--; + while (chptr > text && isspace(*chptr)) chptr--; + chptr++; + } + + if (chptr-text == 1 && !isspace(*chptr)) + chptr = text + width - 1; + + if (chptr > text) + howbad += width - (chptr - text) + 1; + if (result) { + if (kanji == 1) { + strncat(result, text, chptr - text + 1); + chptr++; + kanji = 0; + } else { + strncat(result, text, chptr - text + 1); + } + strcat(result, "\n"); + height++; + } + + if (isspace(*chptr)) + text = chptr + 1; + else + text = chptr; + while (isspace(*text)) text++; + } + } + } + +// if (result) printf("result: %s\n", result); + + if (badness) *badness = howbad; + if (resultPtr) *resultPtr = result; + if (heightPtr) *heightPtr = height; +} + +char * newtReflowText(char * text, int width, int flexDown, int flexUp, + int * actualWidth, int * actualHeight) { + int min, max; + int i; + char * result; + int minbad, minbadwidth, howbad; + char * expandedText; + + expandedText = expandTabs(text); + + if (flexDown || flexUp) { + min = width - flexDown; + max = width + flexUp; + + minbad = -1; + minbadwidth = width; + + for (i = min; i <= max; i++) { + doReflow(expandedText, NULL, i, &howbad, NULL); + + if (minbad == -1 || howbad < minbad) { + minbad = howbad; + minbadwidth = i; + } + } + + width = minbadwidth; + } + + doReflow(expandedText, &result, width, NULL, actualHeight); + free(expandedText); + if (actualWidth) *actualWidth = width; + return result; +} + +void newtTextboxSetText(newtComponent co, const char * text) { + const char * start, * end; + struct textbox * tb = co->data; + char * reflowed, * expanded; + int badness, height; + + if (tb->lines) { + free(tb->lines); + tb->linesAlloced = tb->numLines = 0; + } + + expanded = expandTabs(text); + + if (tb->doWrap) { + doReflow(expanded, &reflowed, tb->textWidth, &badness, &height); + free(expanded); + expanded = reflowed; + } + + for (start = expanded; *start; start++) + if (*start == '\n') tb->linesAlloced++; + + /* This ++ leaves room for an ending line w/o a \n */ + tb->linesAlloced++; + tb->lines = malloc(sizeof(char *) * tb->linesAlloced); + + start = expanded; + while ((end = strchr(start, '\n'))) { + addLine(co, start, end - start); + start = end + 1; + } + + if (*start) + addLine(co, start, strlen(start)); + + free(expanded); +} + +/* This assumes the buffer is allocated properly! */ +static void addLine(newtComponent co, const char * s, int len) { + struct textbox * tb = co->data; + + if (len > tb->textWidth) len = tb->textWidth; + + tb->lines[tb->numLines] = malloc(tb->textWidth + 1); + memset(tb->lines[tb->numLines], ' ', tb->textWidth); + memcpy(tb->lines[tb->numLines], s, len); + tb->lines[tb->numLines++][tb->textWidth] = '\0'; +} + +static void textboxDraw(newtComponent c) { + int i; + struct textbox * tb = c->data; + int size; + + if (tb->sb) { + size = tb->numLines - c->height; + newtScrollbarSet(tb->sb, tb->topLine, size ? size : 0); + tb->sb->ops->draw(tb->sb); + } + + SLsmg_set_color(NEWT_COLORSET_TEXTBOX); + + for (i = 0; (i + tb->topLine) < tb->numLines && i < c->height; i++) { + newtGotorc(c->top + i, c->left); + SLsmg_write_string(tb->lines[i + tb->topLine]); + } +} + +static struct eventResult textboxEvent(newtComponent co, + struct event ev) { + struct textbox * tb = co->data; + struct eventResult er; + + er.result = ER_IGNORED; + + if (ev.when == EV_EARLY && ev.event == EV_KEYPRESS && tb->sb) { + switch (ev.u.key) { + case NEWT_KEY_UP: + if (tb->topLine) tb->topLine--; + textboxDraw(co); + er.result = ER_SWALLOWED; + break; + + case NEWT_KEY_DOWN: + if (tb->topLine < (tb->numLines - co->height)) tb->topLine++; + textboxDraw(co); + er.result = ER_SWALLOWED; + break; + + case NEWT_KEY_PGDN: + tb->topLine += co->height; + if (tb->topLine > (tb->numLines - co->height)) { + tb->topLine = tb->numLines - co->height; + if (tb->topLine < 0) tb->topLine = 0; + } + textboxDraw(co); + er.result = ER_SWALLOWED; + break; + + case NEWT_KEY_PGUP: + tb->topLine -= co->height; + if (tb->topLine < 0) tb->topLine = 0; + textboxDraw(co); + er.result = ER_SWALLOWED; + break; + } + } + if (ev.when == EV_EARLY && ev.event == EV_MOUSE && tb->sb) { + /* Top scroll arrow */ + if (ev.u.mouse.x == co->width && ev.u.mouse.y == co->top) { + if (tb->topLine) tb->topLine--; + textboxDraw(co); + + er.result = ER_SWALLOWED; + } + /* Bottom scroll arrow */ + if (ev.u.mouse.x == co->width && + ev.u.mouse.y == co->top + co->height - 1) { + if (tb->topLine < (tb->numLines - co->height)) tb->topLine++; + textboxDraw(co); + + er.result = ER_SWALLOWED; + } + } + return er; +} + +static void textboxDestroy(newtComponent co) { + int i; + struct textbox * tb = co->data; + + for (i = 0; i < tb->numLines; i++) + free(tb->lines[i]); + free(tb->lines); + free(tb); + free(co); +} diff --git a/mdk-stage1/newt/windows.c b/mdk-stage1/newt/windows.c new file mode 100644 index 000000000..792d3ed76 --- /dev/null +++ b/mdk-stage1/newt/windows.c @@ -0,0 +1,275 @@ +#include <errno.h> +#include <stdarg.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +#include "errno.h" +#include "newt.h" + +static void * newtvwindow(char * title, char * button1, char * button2, + char * button3, char * message, va_list args) { + newtComponent b1, b2 = NULL, b3 = NULL, t, f, answer; + char * buf = NULL; + int size = 0; + int i = 0; + int scroll = 0; + int width, height; + char * flowedText; + newtGrid grid, buttonGrid; + + do { + size += 1000; + if (buf) free(buf); + buf = malloc(size); + i = vsnprintf(buf, size, message, args); + } while (i >= size || i == -1); + + flowedText = newtReflowText(buf, 35, 5, 5, &width, &height); + if (height > 6) { + free(flowedText); + flowedText = newtReflowText(buf, 60, 5, 5, &width, &height); + } + free(buf); + + if (height > 12) { + height = 12; + scroll = NEWT_FLAG_SCROLL; + } + t = newtTextbox(-1, -1, width, height, NEWT_TEXTBOX_WRAP | scroll); + newtTextboxSetText(t, flowedText); + free(flowedText); + + if (button3) { + buttonGrid = newtButtonBar(button1, &b1, button2, &b2, + button3, &b3, NULL); + } else if (button2) { + buttonGrid = newtButtonBar(button1, &b1, button2, &b2, NULL); + } else { + buttonGrid = newtButtonBar(button1, &b1, NULL); + } + + newtGridSetField(buttonGrid, 0, 0, NEWT_GRID_COMPONENT, b1, + 0, 0, button2 ? 1 : 0, 0, 0, 0); + + grid = newtCreateGrid(1, 2); + newtGridSetField(grid, 0, 0, NEWT_GRID_COMPONENT, t, 0, 0, 0, 0, 0, 0); + newtGridSetField(grid, 0, 1, NEWT_GRID_SUBGRID, buttonGrid, + 0, 1, 0, 0, 0, NEWT_GRID_FLAG_GROWX); + newtGridWrappedWindow(grid, title); + + f = newtForm(NULL, NULL, 0); + newtFormAddComponents(f, t, b1, NULL); + + if (button2) + newtFormAddComponent(f, b2); + if (button3) + newtFormAddComponent(f, b3); + + answer = newtRunForm(f); + newtGridFree(grid, 1); + + newtFormDestroy(f); + newtPopWindow(); + + if (answer == f) + return NULL; + else if (answer == b1) + return button1; + else if (answer == b2) + return button2; + + return button3; +} + +int newtWinChoice(char * title, char * button1, char * button2, + char * message, ...) { + va_list args; + void * rc; + + va_start(args, message); + rc = newtvwindow(title, button1, button2, NULL, message, args); + va_end(args); + + if (rc == button1) + return 1; + else if (rc == button2) + return 2; + + return 0; +} + +void newtWinMessage(char * title, char * buttonText, char * text, ...) { + va_list args; + + va_start(args, text); + newtvwindow(title, buttonText, NULL, NULL, text, args); + va_end(args); +} + +void newtWinMessagev(char * title, char * buttonText, char * text, + va_list argv) { + newtvwindow(title, buttonText, NULL, NULL, text, argv); +} + +int newtWinTernary(char * title, char * button1, char * button2, + char * button3, char * message, ...) { + va_list args; + void * rc; + + va_start(args, message); + rc = newtvwindow(title, button1, button2, button3, message, args); + va_end(args); + + if (rc == button1) + return 1; + else if (rc == button2) + return 2; + else if (rc == button3) + return 3; + + return 0; +} + +/* only supports up to 50 buttons -- shucks! */ +int newtWinMenu(char * title, char * text, int suggestedWidth, int flexDown, + int flexUp, int maxListHeight, char ** items, int * listItem, + char * button1, ...) { + newtComponent textbox, listbox, result, form; + va_list args; + newtComponent buttons[50]; + newtGrid grid, buttonBar; + int numButtons; + int i, rc; + int needScroll; + char * buttonName; + + textbox = newtTextboxReflowed(-1, -1, text, suggestedWidth, flexDown, + flexUp, 0); + + for (i = 0; items[i]; i++) ; + if (i < maxListHeight) maxListHeight = i; + needScroll = i > maxListHeight; + + listbox = newtListbox(-1, -1, maxListHeight, + (needScroll ? NEWT_FLAG_SCROLL : 0) | NEWT_FLAG_RETURNEXIT); + for (i = 0; items[i]; i++) { + newtListboxAddEntry(listbox, items[i], (void *) i); + } + + newtListboxSetCurrent(listbox, *listItem); + + buttonName = button1, numButtons = 0; + va_start(args, button1); + while (buttonName) { + buttons[numButtons] = newtButton(-1, -1, buttonName); + numButtons++; + buttonName = va_arg(args, char *); + } + + va_end(args); + + buttonBar = newtCreateGrid(numButtons, 1); + for (i = 0; i < numButtons; i++) { + newtGridSetField(buttonBar, i, 0, NEWT_GRID_COMPONENT, + buttons[i], + i ? 1 : 0, 0, 0, 0, 0, 0); + } + + grid = newtGridSimpleWindow(textbox, listbox, buttonBar); + newtGridWrappedWindow(grid, title); + + form = newtForm(NULL, 0, 0); + newtGridAddComponentsToForm(grid, form, 1); + newtGridFree(grid, 1); + + result = newtRunForm(form); + + *listItem = ((long) newtListboxGetCurrent(listbox)); + + for (rc = 0; result != buttons[rc] && rc < numButtons; rc++); + if (rc == numButtons) + rc = 0; /* F12 or return-on-exit (which are the same for us) */ + else + rc++; + + newtFormDestroy(form); + newtPopWindow(); + + return rc; +} + +/* only supports up to 50 buttons and entries -- shucks! */ +int newtWinEntries(char * title, char * text, int suggestedWidth, int flexDown, + int flexUp, int dataWidth, + struct newtWinEntry * items, char * button1, ...) { + newtComponent buttons[50], result, form, textw; + newtGrid grid, buttonBar, subgrid; + int numItems; + int rc, i; + int numButtons; + char * buttonName; + va_list args; + + textw = newtTextboxReflowed(-1, -1, text, suggestedWidth, flexDown, + flexUp, 0); + + for (numItems = 0; items[numItems].text; numItems++); + + buttonName = button1, numButtons = 0; + va_start(args, button1); + while (buttonName) { + buttons[numButtons] = newtButton(-1, -1, buttonName); + numButtons++; + buttonName = va_arg(args, char *); + } + + va_end(args); + + buttonBar = newtCreateGrid(numButtons, 1); + for (i = 0; i < numButtons; i++) { + newtGridSetField(buttonBar, i, 0, NEWT_GRID_COMPONENT, + buttons[i], + i ? 1 : 0, 0, 0, 0, 0, 0); + } + + subgrid = newtCreateGrid(2, numItems); + for (i = 0; i < numItems; i++) { + newtGridSetField(subgrid, 0, i, NEWT_GRID_COMPONENT, + newtLabel(-1, -1, items[i].text), + 0, 0, 0, 0, NEWT_ANCHOR_LEFT, 0); + newtGridSetField(subgrid, 1, i, NEWT_GRID_COMPONENT, + newtEntry(-1, -1, items[i].value ? + *items[i].value : NULL, dataWidth, + items[i].value, items[i].flags), + 1, 0, 0, 0, 0, 0); + } + + grid = newtCreateGrid(1, 3); + form = newtForm(NULL, 0, 0); + newtGridSetField(grid, 0, 0, NEWT_GRID_COMPONENT, textw, + 0, 0, 0, 0, NEWT_ANCHOR_LEFT, 0); + newtGridSetField(grid, 0, 1, NEWT_GRID_SUBGRID, subgrid, + 0, 1, 0, 0, 0, 0); + newtGridSetField(grid, 0, 2, NEWT_GRID_SUBGRID, buttonBar, + 0, 1, 0, 0, 0, NEWT_GRID_FLAG_GROWX); + newtGridAddComponentsToForm(grid, form, 1); + newtGridWrappedWindow(grid, title); + newtGridFree(grid, 1); + + result = newtRunForm(form); + + for (rc = 0; rc < numItems; rc++) + *items[rc].value = strdup(*items[rc].value); + + for (rc = 0; result != buttons[rc] && rc < numButtons; rc++); + if (rc == numButtons) + rc = 0; /* F12 */ + else + rc++; + + newtFormDestroy(form); + newtPopWindow(); + + return rc; +} diff --git a/mdk-stage1/slang/Makefile b/mdk-stage1/slang/Makefile new file mode 100644 index 000000000..c78ee4668 --- /dev/null +++ b/mdk-stage1/slang/Makefile @@ -0,0 +1,48 @@ + #****************************************************************************** + # + # Guillaume Cottenceau (gc@mandrakesoft.com) + # + # Copyright 2000 MandrakeSoft + # + # This software may be freely redistributed under the terms of the GNU + # public license. + # + # You should have received a copy of the GNU General Public License + # along with this program; if not, write to the Free Software + # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + # + #***************************************************************************** + +top_dir = .. + +include $(top_dir)/Makefile.common + + +all: libslang.a libslang-DIET.a + +clean: + rm -f *.o *.a + +FLAGS = -Wall -Werror -Os -fomit-frame-pointer -Dunix -DSLANG -c + + +OBJS = sltermin.o sldisply.o slutty.o slang.o slarray.o slclass.o slcmd.o slerr.o slgetkey.o slkeymap.o slmalloc.o slmath.o slmemchr.o slmemcmp.o slmemcpy.o slmemset.o slmisc.o slparse.o slprepr.o slregexp.o slrline.o slsearch.o slsmg.o slstd.o sltoken.o sltypes.o slxstrng.o slcurses.o slscroll.o slsignal.o slkeypad.o slerrno.o slstring.o slstruct.o slcmplex.o slarrfun.o slimport.o slpath.o slarith.o slassoc.o slcompat.o slposdir.o slstdio.o slproc.o sltime.o slstrops.o slbstr.o slpack.o slintall.o slistruc.o slposio.o slnspace.o slarrmis.o slospath.o slscanf.o + +OBJS-DIET = $(subst .o,-DIET.o,$(OBJS)) + + +libslang.a: $(OBJS) + ar -cru $@ $^ + ranlib $@ + +libslang-DIET.a: $(OBJS-DIET) + ar -cru $@ $^ + ranlib $@ + + +$(OBJS): %.o: %.c + gcc $(FLAGS) $(GLIBC_INCLUDES) -c $< -o $@ + +$(OBJS-DIET): %-DIET.o: %.c + gcc $(FLAGS) $(DIETLIBC_INCLUDES) -c $< -o $@ + diff --git a/mdk-stage1/slang/_slang.h b/mdk-stage1/slang/_slang.h new file mode 100644 index 000000000..02ee13505 --- /dev/null +++ b/mdk-stage1/slang/_slang.h @@ -0,0 +1,743 @@ +#ifndef _PRIVATE_SLANG_H_ +#define _PRIVATE_SLANG_H_ +/* header file for S-Lang internal structures that users do not (should not) + need. Use slang.h for that purpose. */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* #include "config.h" */ +#include "jdmacros.h" +#include "sllimits.h" + +#ifdef VMS +# define SLANG_SYSTEM_NAME "_VMS" +#else +# if defined (IBMPC_SYSTEM) +# define SLANG_SYSTEM_NAME "_IBMPC" +# else +# define SLANG_SYSTEM_NAME "_UNIX" +# endif +#endif /* VMS */ + +/* These quantities are main_types for byte-compiled code. They are used + * by the inner_interp routine. The _BC_ means byte-code. + */ + +#define _SLANG_BC_LVARIABLE SLANG_LVARIABLE /* 0x01 */ +#define _SLANG_BC_GVARIABLE SLANG_GVARIABLE /* 0x02 */ +#define _SLANG_BC_IVARIABLE SLANG_IVARIABLE /* 0x03 */ +#define _SLANG_BC_RVARIABLE SLANG_RVARIABLE /* 0x04 */ +#define _SLANG_BC_INTRINSIC SLANG_INTRINSIC /* 0x05 */ +#define _SLANG_BC_FUNCTION SLANG_FUNCTION /* 0x06 */ +#define _SLANG_BC_MATH_UNARY SLANG_MATH_UNARY /* 0x07 */ +#define _SLANG_BC_APP_UNARY SLANG_APP_UNARY /* 0x08 */ +#define _SLANG_BC_ICONST SLANG_ICONSTANT /* 0x09 */ +#define _SLANG_BC_DCONST SLANG_DCONSTANT /* 0x0A */ +#define _SLANG_BC_PVARIABLE SLANG_PVARIABLE /* 0x0B */ +#define _SLANG_BC_PFUNCTION SLANG_PFUNCTION /* 0x0C */ + +#define _SLANG_BC_BINARY 0x10 +#define _SLANG_BC_LITERAL 0x11 /* constant objects */ +#define _SLANG_BC_LITERAL_INT 0x12 +#define _SLANG_BC_LITERAL_STR 0x13 +#define _SLANG_BC_BLOCK 0x14 + +/* These 3 MUST be in this order too ! */ +#define _SLANG_BC_RETURN 0x15 +#define _SLANG_BC_BREAK 0x16 +#define _SLANG_BC_CONTINUE 0x17 + +#define _SLANG_BC_EXCH 0x18 +#define _SLANG_BC_LABEL 0x19 +#define _SLANG_BC_LOBJPTR 0x1A +#define _SLANG_BC_GOBJPTR 0x1B +#define _SLANG_BC_X_ERROR 0x1C +/* These must be in this order */ +#define _SLANG_BC_X_USER0 0x1D +#define _SLANG_BC_X_USER1 0x1E +#define _SLANG_BC_X_USER2 0x1F +#define _SLANG_BC_X_USER3 0x20 +#define _SLANG_BC_X_USER4 0x21 + +#define _SLANG_BC_CALL_DIRECT 0x24 +#define _SLANG_BC_CALL_DIRECT_FRAME 0x25 +#define _SLANG_BC_UNARY 0x26 +#define _SLANG_BC_UNARY_FUNC 0x27 + +#define _SLANG_BC_DEREF_ASSIGN 0x30 +#define _SLANG_BC_SET_LOCAL_LVALUE 0x31 +#define _SLANG_BC_SET_GLOBAL_LVALUE 0x32 +#define _SLANG_BC_SET_INTRIN_LVALUE 0x33 +#define _SLANG_BC_SET_STRUCT_LVALUE 0x34 +#define _SLANG_BC_FIELD 0x35 +#define _SLANG_BC_SET_ARRAY_LVALUE 0x36 + +#define _SLANG_BC_LINE_NUM 0x40 + +#define _SLANG_BC_TMP 0x50 +#define _SLANG_BC_LVARIABLE_AGET 0x60 +#define _SLANG_BC_LVARIABLE_APUT 0x61 +#define _SLANG_BC_INTEGER_PLUS 0x62 +#define _SLANG_BC_INTEGER_MINUS 0x63 +#define _SLANG_BC_ARG_LVARIABLE 0x64 +#define _SLANG_BC_EARG_LVARIABLE 0x65 + +#define _SLANG_BC_CALL_DIRECT_INTRINSIC 0x80 +#define _SLANG_BC_INTRINSIC_CALL_DIRECT 0x81 +#define _SLANG_BC_CALL_DIRECT_LSTR 0x82 +#define _SLANG_BC_CALL_DIRECT_SLFUN 0x83 +#define _SLANG_BC_CALL_DIRECT_INTRSTOP 0x84 +#define _SLANG_BC_INTRINSIC_STOP 0x85 +#define _SLANG_BC_CALL_DIRECT_EARG_LVAR 0x86 +#define _SLANG_BC_CALL_DIRECT_LINT 0x87 +#define _SLANG_BC_CALL_DIRECT_LVAR 0x88 + + +/* Byte-Code Sub Types (_BCST_) */ + +/* These are sub_types of _SLANG_BC_BLOCK */ +#define _SLANG_BCST_ERROR_BLOCK 0x01 +#define _SLANG_BCST_EXIT_BLOCK 0x02 +#define _SLANG_BCST_USER_BLOCK0 0x03 +#define _SLANG_BCST_USER_BLOCK1 0x04 +#define _SLANG_BCST_USER_BLOCK2 0x05 +#define _SLANG_BCST_USER_BLOCK3 0x06 +#define _SLANG_BCST_USER_BLOCK4 0x07 +/* The user blocks MUST be in the above order */ +#define _SLANG_BCST_LOOP 0x10 +#define _SLANG_BCST_WHILE 0x11 +#define _SLANG_BCST_FOR 0x12 +#define _SLANG_BCST_FOREVER 0x13 +#define _SLANG_BCST_CFOR 0x14 +#define _SLANG_BCST_DOWHILE 0x15 +#define _SLANG_BCST_FOREACH 0x16 + +#define _SLANG_BCST_IF 0x20 +#define _SLANG_BCST_IFNOT 0x21 +#define _SLANG_BCST_ELSE 0x22 +#define _SLANG_BCST_ANDELSE 0x23 +#define _SLANG_BCST_ORELSE 0x24 +#define _SLANG_BCST_SWITCH 0x25 +#define _SLANG_BCST_NOTELSE 0x26 + +/* assignment (_SLANG_BC_SET_*_LVALUE) subtypes. The order MUST correspond + * to the assignment token order with the ASSIGN_TOKEN as the first! + */ +#define _SLANG_BCST_ASSIGN 0x01 +#define _SLANG_BCST_PLUSEQS 0x02 +#define _SLANG_BCST_MINUSEQS 0x03 +#define _SLANG_BCST_TIMESEQS 0x04 +#define _SLANG_BCST_DIVEQS 0x05 +#define _SLANG_BCST_BOREQS 0x06 +#define _SLANG_BCST_BANDEQS 0x07 +#define _SLANG_BCST_PLUSPLUS 0x08 +#define _SLANG_BCST_POST_PLUSPLUS 0x09 +#define _SLANG_BCST_MINUSMINUS 0x0A +#define _SLANG_BCST_POST_MINUSMINUS 0x0B + +/* These use SLANG_PLUS, SLANG_MINUS, SLANG_PLUSPLUS, etc... */ + +typedef union +{ +#if SLANG_HAS_FLOAT + double double_val; + float float_val; +#endif + long long_val; + unsigned long ulong_val; + VOID_STAR ptr_val; + char *s_val; + int int_val; + unsigned int uint_val; + SLang_MMT_Type *ref; + SLang_Name_Type *n_val; + struct _SLang_Struct_Type *struct_val; + struct _SLang_Array_Type *array_val; + short short_val; + unsigned short ushort_val; + char char_val; + unsigned char uchar_val; +} +_SL_Object_Union_Type; + +typedef struct _SLang_Object_Type +{ + unsigned char data_type; /* SLANG_INT_TYPE, ... */ + _SL_Object_Union_Type v; +} +SLang_Object_Type; + +struct _SLang_MMT_Type +{ + unsigned char data_type; /* int, string, etc... */ + VOID_STAR user_data; /* address of user structure */ + unsigned int count; /* number of references */ +}; + +extern int _SLang_pop_object_of_type (unsigned char, SLang_Object_Type *, int); + +typedef struct +{ + char *name; /* slstring */ + SLang_Object_Type obj; +} +_SLstruct_Field_Type; + +typedef struct _SLang_Struct_Type +{ + _SLstruct_Field_Type *fields; + unsigned int nfields; /* number used */ + unsigned int num_refs; +} +_SLang_Struct_Type; + +extern void _SLstruct_delete_struct (_SLang_Struct_Type *); +extern int _SLang_push_struct (_SLang_Struct_Type *); +extern int _SLang_pop_struct (_SLang_Struct_Type **); +extern int _SLstruct_init (void); +/* extern int _SLstruct_get_field (char *); */ +extern int _SLstruct_define_struct (void); +extern int _SLstruct_define_typedef (void); + +extern int _SLang_pop_datatype (unsigned char *); +extern int _SLang_push_datatype (unsigned char); + +struct _SLang_Ref_Type +{ + int is_global; + union + { + SLang_Name_Type *nt; + SLang_Object_Type *local_obj; + } + v; +}; + +extern int _SLang_dereference_ref (SLang_Ref_Type *); +extern int _SLang_deref_assign (SLang_Ref_Type *); +extern int _SLang_push_ref (int, VOID_STAR); + +extern int _SL_increment_frame_pointer (void); +extern int _SL_decrement_frame_pointer (void); + +extern int SLang_pop(SLang_Object_Type *); +extern void SLang_free_object (SLang_Object_Type *); +extern int _SLanytype_typecast (unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR); +extern void _SLstring_intrinsic (void); + + +/* These functions are used to create slstrings of a fixed length. Be + * very careful how they are used. In particular, if len bytes are allocated, + * then the string must be len characters long, no more and no less. + */ +extern char *_SLallocate_slstring (unsigned int); +extern char *_SLcreate_via_alloced_slstring (char *, unsigned int); +extern void _SLunallocate_slstring (char *, unsigned int); +extern int _SLpush_alloced_slstring (char *, unsigned int); + +typedef struct +{ + char **buf; + unsigned int max_num; + unsigned int num; + unsigned int delta_num; +} +_SLString_List_Type; +extern int _SLstring_list_append (_SLString_List_Type *, char *); +extern int _SLstring_list_init (_SLString_List_Type *, unsigned int, unsigned int); +extern void _SLstring_list_delete (_SLString_List_Type *); +extern int _SLstring_list_push (_SLString_List_Type *); + +/* This function assumes that s is an slstring. */ +extern char *_SLstring_dup_slstring (char *); +extern int _SLang_dup_and_push_slstring (char *); + + +extern int _SLang_init_import (void); + +/* This function checks to see if the referenced object is initialized */ +extern int _SLang_is_ref_initialized (SLang_Ref_Type *); +extern int _SLcheck_identifier_syntax (char *); +extern int _SLang_uninitialize_ref (SLang_Ref_Type *); + +extern int _SLpush_slang_obj (SLang_Object_Type *); + +extern char *_SLexpand_escaped_char(char *, char *); +extern void _SLexpand_escaped_string (char *, char *, char *); + +/* returns a pointer to an SLstring string-- use SLang_free_slstring */ +extern char *_SLstringize_object (SLang_Object_Type *); +extern int _SLdump_objects (char *, SLang_Object_Type *, unsigned int, int); + +extern SLang_Object_Type *_SLRun_Stack; +extern SLang_Object_Type *_SLStack_Pointer; + +struct _SLang_NameSpace_Type +{ + struct _SLang_NameSpace_Type *next; + char *name; /* this is the load_type name */ + char *namespace_name; /* this name is assigned by implements */ + unsigned int table_size; + SLang_Name_Type **table; +}; +extern SLang_NameSpace_Type *_SLns_allocate_namespace (char *, unsigned int); +extern SLang_NameSpace_Type *_SLns_find_namespace (char *); +extern int _SLns_set_namespace_name (SLang_NameSpace_Type *, char *); +extern SLang_Array_Type *_SLnspace_apropos (SLang_NameSpace_Type *, char *, unsigned int); +extern void _SLang_use_namespace_intrinsic (char *name); +extern char *_SLang_cur_namespace_intrinsic (void); +extern SLang_Array_Type *_SLang_apropos (char *, char *, unsigned int); +extern void _SLang_implements_intrinsic (char *); + +extern int _SLang_Trace; +extern int _SLstack_depth(void); +extern char *_SLang_Current_Function_Name; + +extern int _SLang_trace_fun(char *); +extern int _SLang_Compile_Line_Num_Info; + +extern char *_SLstring_dup_hashed_string (char *, unsigned long); +extern unsigned long _SLcompute_string_hash (char *); +extern char *_SLstring_make_hashed_string (char *, unsigned int, unsigned long *); +extern void _SLfree_hashed_string (char *, unsigned int, unsigned long); +unsigned long _SLstring_hash (unsigned char *, unsigned char *); +extern int _SLinit_slcomplex (void); + +extern int _SLang_init_slstrops (void); +extern int _SLstrops_do_sprintf_n (int); +extern int _SLang_sscanf (void); +extern double _SLang_atof (char *); +extern int _SLang_init_bstring (void); +extern int _SLang_init_sltime (void); +extern void _SLpack (void); +extern void _SLunpack (char *, SLang_BString_Type *); +extern void _SLpack_pad_format (char *); +extern unsigned int _SLpack_compute_size (char *); +extern int _SLusleep (unsigned long); + +/* frees upon error. NULL __NOT__ ok. */ +extern int _SLang_push_slstring (char *); + +extern unsigned char _SLarith_promote_type (unsigned char); +extern int _SLarith_get_precedence (unsigned char); +extern int _SLarith_typecast (unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR); + +extern int SLang_push(SLang_Object_Type *); +extern int SLadd_global_variable (char *); +extern void _SLang_clear_error (void); + +extern int _SLdo_pop (void); +extern unsigned int _SLsys_getkey (void); +extern int _SLsys_input_pending (int); +#ifdef IBMPC_SYSTEM +extern unsigned int _SLpc_convert_scancode (unsigned int, unsigned int, int); +#define _SLTT_KEY_SHIFT 1 +#define _SLTT_KEY_CTRL 2 +#define _SLTT_KEY_ALT 4 +#endif + +typedef struct _SLterminfo_Type SLterminfo_Type; +extern SLterminfo_Type *_SLtt_tigetent (char *); +extern char *_SLtt_tigetstr (SLterminfo_Type *, char *); +extern int _SLtt_tigetnum (SLterminfo_Type *, char *); +extern int _SLtt_tigetflag (SLterminfo_Type *, char *); + +#if SLTT_HAS_NON_BCE_SUPPORT +extern int _SLtt_get_bce_color_offset (void); +#endif +extern void (*_SLtt_color_changed_hook)(void); + +extern unsigned char SLang_Input_Buffer [SL_MAX_INPUT_BUFFER_LEN]; + +extern int _SLregister_types (void); +extern SLang_Class_Type *_SLclass_get_class (unsigned char); +extern VOID_STAR _SLclass_get_ptr_to_value (SLang_Class_Type *, SLang_Object_Type *); +extern void _SLclass_type_mismatch_error (unsigned char, unsigned char); +extern int _SLclass_init (void); +extern int _SLclass_copy_class (unsigned char, unsigned char); + +extern unsigned char _SLclass_Class_Type [256]; + +extern int (*_SLclass_get_typecast (unsigned char, unsigned char, int)) +(unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR); + +extern int (*_SLclass_get_binary_fun (int, SLang_Class_Type *, SLang_Class_Type *, SLang_Class_Type **, int)) +(int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR); + +extern int (*_SLclass_get_unary_fun (int, SLang_Class_Type *, SLang_Class_Type **, int)) +(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); + +extern int _SLarith_register_types (void); +extern unsigned char _SLarith_Arith_Types []; +extern unsigned char _SLarith_Is_Arith_Type [256]; +extern int _SLarith_bin_op (SLang_Object_Type *, SLang_Object_Type *, int); + +extern int _SLarray_add_bin_op (unsigned char); + +extern int _SLang_call_funptr (SLang_Name_Type *); +extern void _SLset_double_format (char *); +extern SLang_Name_Type *_SLlocate_global_name (char *); +extern SLang_Name_Type *_SLlocate_name (char *); + +extern char *_SLdefines[]; + +#define SL_ERRNO_NOT_IMPLEMENTED 0x7FFF +extern int _SLerrno_errno; +extern int _SLerrno_init (void); + +extern int _SLstdio_fdopen (char *, int, char *); + +extern void _SLstruct_pop_args (int *); +extern void _SLstruct_push_args (SLang_Array_Type *); + +extern int _SLarray_aput (void); +extern int _SLarray_aget (void); +extern int _SLarray_inline_implicit_array (void); +extern int _SLarray_inline_array (void); +extern int _SLarray_wildcard_array (void); + +extern int +_SLarray_typecast (unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, int); + +extern int _SLarray_aput_transfer_elem (SLang_Array_Type *, int *, + VOID_STAR, unsigned int, int); +extern int _SLarray_aget_transfer_elem (SLang_Array_Type *, int *, + VOID_STAR, unsigned int, int); +extern void _SLarray_free_array_elements (SLang_Class_Type *, VOID_STAR, unsigned int); + +extern SLang_Foreach_Context_Type * +_SLarray_cl_foreach_open (unsigned char, unsigned int); +extern void _SLarray_cl_foreach_close (unsigned char, SLang_Foreach_Context_Type *); +extern int _SLarray_cl_foreach (unsigned char, SLang_Foreach_Context_Type *); + +extern int _SLarray_matrix_multiply (void); +extern void (*_SLang_Matrix_Multiply)(void); + +extern int _SLarray_init_slarray (void); +extern SLang_Array_Type * +SLang_create_array1 (unsigned char, int, VOID_STAR, int *, unsigned int, int); + +extern int _SLcompile_push_context (SLang_Load_Type *); +extern int _SLcompile_pop_context (void); +extern int _SLang_Auto_Declare_Globals; + +typedef struct +{ + union + { + long long_val; + char *s_val; /* Used for IDENT_TOKEN, FLOAT, etc... */ + SLang_BString_Type *b_val; + } v; + int free_sval_flag; + unsigned int num_refs; + unsigned long hash; +#if _SLANG_HAS_DEBUG_CODE + int line_number; +#endif + unsigned char type; +} +_SLang_Token_Type; + +extern void _SLcompile (_SLang_Token_Type *); +extern void (*_SLcompile_ptr)(_SLang_Token_Type *); + +/* *** TOKENS *** */ + +/* Note that that tokens corresponding to ^J, ^M, and ^Z should not be used. + * This is because a file that contains any of these characters will + * have an OS dependent interpretation, e.g., ^Z is EOF on MSDOS. + */ + +/* Special tokens */ +#define EOF_TOKEN 0x01 +#define RPN_TOKEN 0x02 +#define NL_TOKEN 0x03 +#define NOP_TOKEN 0x05 +#define FARG_TOKEN 0x06 +#define TMP_TOKEN 0x07 + +#define RESERVED1_TOKEN 0x0A /* \n */ +#define RESERVED2_TOKEN 0x0D /* \r */ + +/* Literal tokens */ +#define CHAR_TOKEN 0x10 +#define UCHAR_TOKEN 0x11 +#define SHORT_TOKEN 0x12 +#define USHORT_TOKEN 0x13 +#define INT_TOKEN 0x14 +#define UINT_TOKEN 0x15 +#define LONG_TOKEN 0x16 +#define ULONG_TOKEN 0x17 +#define IS_INTEGER_TOKEN(x) ((x >= CHAR_TOKEN) && (x <= ULONG_TOKEN)) +#define FLOAT_TOKEN 0x18 +#define DOUBLE_TOKEN 0x19 +#define RESERVED3_TOKEN 0x1A /* ^Z */ +#define COMPLEX_TOKEN 0x1B +#define STRING_TOKEN 0x1C +#define BSTRING_TOKEN 0x1D +#define _BSTRING_TOKEN 0x1E /* byte-compiled BSTRING */ +#define ESC_STRING_TOKEN 0x1F + +/* Tokens that can be LVALUES */ +#define IDENT_TOKEN 0x20 +#define ARRAY_TOKEN 0x21 +#define DOT_TOKEN 0x22 +#define IS_LVALUE_TOKEN (((t) <= DOT_TOKEN) && ((t) >= IDENT_TOKEN)) + +/* do not use these values */ +#define RESERVED4_TOKEN 0x23 /* # */ +#define RESERVED5_TOKEN 0x25 /* % */ + +/* Flags for struct fields */ +#define STATIC_TOKEN 0x26 +#define READONLY_TOKEN 0x27 +#define PRIVATE_TOKEN 0x28 +#define PUBLIC_TOKEN 0x29 + +/* Punctuation tokens */ +#define OBRACKET_TOKEN 0x2a +#define CBRACKET_TOKEN 0x2b +#define OPAREN_TOKEN 0x2c +#define CPAREN_TOKEN 0x2d +#define OBRACE_TOKEN 0x2e +#define CBRACE_TOKEN 0x2f + +#define COMMA_TOKEN 0x31 +#define SEMICOLON_TOKEN 0x32 +#define COLON_TOKEN 0x33 +#define NAMESPACE_TOKEN 0x34 + +/* Operators */ +#define POW_TOKEN 0x38 + +/* The order here must match the order in the Binop_Level table in slparse.c */ +#define FIRST_BINARY_OP 0x39 +#define ADD_TOKEN 0x39 +#define SUB_TOKEN 0x3a +#define TIMES_TOKEN 0x3b +#define DIV_TOKEN 0x3c +#define LT_TOKEN 0x3d +#define LE_TOKEN 0x3e +#define GT_TOKEN 0x3f +#define GE_TOKEN 0x40 +#define EQ_TOKEN 0x41 +#define NE_TOKEN 0x42 +#define AND_TOKEN 0x43 +#define OR_TOKEN 0x44 +#define MOD_TOKEN 0x45 +#define BAND_TOKEN 0x46 +#define SHL_TOKEN 0x47 +#define SHR_TOKEN 0x48 +#define BXOR_TOKEN 0x49 +#define BOR_TOKEN 0x4a +#define POUND_TOKEN 0x4b /* matrix multiplication */ + +#define LAST_BINARY_OP 0x4b +#define IS_BINARY_OP(t) ((t >= FIRST_BINARY_OP) && (t <= LAST_BINARY_OP)) + +/* unary tokens -- but not all of them (see grammar) */ +#define DEREF_TOKEN 0x4d +#define NOT_TOKEN 0x4e +#define BNOT_TOKEN 0x4f + +#define IS_INTERNAL_FUNC(t) ((t >= 0x50) && (t <= 0x56)) +#define POP_TOKEN 0x50 +#define CHS_TOKEN 0x51 +#define SIGN_TOKEN 0x52 +#define ABS_TOKEN 0x53 +#define SQR_TOKEN 0x54 +#define MUL2_TOKEN 0x55 +#define EXCH_TOKEN 0x56 + +/* Assignment tokens. Note: these must appear with sequential values. + * The order here must match the specific lvalue assignments below. + * These tokens are used by rpn routines in slang.c. slparse.c maps them + * onto the specific lvalue tokens while parsing infix. + * Also the assignment _SLANG_BCST_ assumes this order + */ +#define ASSIGN_TOKEN 0x57 +#define PLUSEQS_TOKEN 0x58 +#define MINUSEQS_TOKEN 0x59 +#define TIMESEQS_TOKEN 0x5A +#define DIVEQS_TOKEN 0x5B +#define BOREQS_TOKEN 0x5C +#define BANDEQS_TOKEN 0x5D +#define PLUSPLUS_TOKEN 0x5E +#define POST_PLUSPLUS_TOKEN 0x5F +#define MINUSMINUS_TOKEN 0x60 +#define POST_MINUSMINUS_TOKEN 0x61 + +/* Directives */ +#define FIRST_DIRECTIVE_TOKEN 0x62 +#define IFNOT_TOKEN 0x62 +#define IF_TOKEN 0x63 +#define ELSE_TOKEN 0x64 +#define FOREVER_TOKEN 0x65 +#define WHILE_TOKEN 0x66 +#define FOR_TOKEN 0x67 +#define _FOR_TOKEN 0x68 +#define LOOP_TOKEN 0x69 +#define SWITCH_TOKEN 0x6A +#define DOWHILE_TOKEN 0x6B +#define ANDELSE_TOKEN 0x6C +#define ORELSE_TOKEN 0x6D +#define ERRBLK_TOKEN 0x6E +#define EXITBLK_TOKEN 0x6F +/* These must be sequential */ +#define USRBLK0_TOKEN 0x70 +#define USRBLK1_TOKEN 0x71 +#define USRBLK2_TOKEN 0x72 +#define USRBLK3_TOKEN 0x73 +#define USRBLK4_TOKEN 0x74 + +#define CONT_TOKEN 0x75 +#define BREAK_TOKEN 0x76 +#define RETURN_TOKEN 0x77 + +#define CASE_TOKEN 0x78 +#define DEFINE_TOKEN 0x79 +#define DO_TOKEN 0x7a +#define VARIABLE_TOKEN 0x7b +#define GVARIABLE_TOKEN 0x7c +#define _REF_TOKEN 0x7d +#define PUSH_TOKEN 0x7e +#define STRUCT_TOKEN 0x7f +#define TYPEDEF_TOKEN 0x80 +#define NOTELSE_TOKEN 0x81 +#define DEFINE_STATIC_TOKEN 0x82 +#define FOREACH_TOKEN 0x83 +#define USING_TOKEN 0x84 +#define DEFINE_PRIVATE_TOKEN 0x85 +#define DEFINE_PUBLIC_TOKEN 0x86 + +/* Note: the order here must match the order of the generic assignment tokens. + * Also, the first token of each group must be the ?_ASSIGN_TOKEN. + * slparse.c exploits this order, as well as slang.h. + */ +#define FIRST_ASSIGN_TOKEN 0x90 +#define _STRUCT_ASSIGN_TOKEN 0x90 +#define _STRUCT_PLUSEQS_TOKEN 0x91 +#define _STRUCT_MINUSEQS_TOKEN 0x92 +#define _STRUCT_TIMESEQS_TOKEN 0x93 +#define _STRUCT_DIVEQS_TOKEN 0x94 +#define _STRUCT_BOREQS_TOKEN 0x95 +#define _STRUCT_BANDEQS_TOKEN 0x96 +#define _STRUCT_PLUSPLUS_TOKEN 0x97 +#define _STRUCT_POST_PLUSPLUS_TOKEN 0x98 +#define _STRUCT_MINUSMINUS_TOKEN 0x99 +#define _STRUCT_POST_MINUSMINUS_TOKEN 0x9A + +#define _ARRAY_ASSIGN_TOKEN 0xA0 +#define _ARRAY_PLUSEQS_TOKEN 0xA1 +#define _ARRAY_MINUSEQS_TOKEN 0xA2 +#define _ARRAY_TIMESEQS_TOKEN 0xA3 +#define _ARRAY_DIVEQS_TOKEN 0xA4 +#define _ARRAY_BOREQS_TOKEN 0xA5 +#define _ARRAY_BANDEQS_TOKEN 0xA6 +#define _ARRAY_PLUSPLUS_TOKEN 0xA7 +#define _ARRAY_POST_PLUSPLUS_TOKEN 0xA8 +#define _ARRAY_MINUSMINUS_TOKEN 0xA9 +#define _ARRAY_POST_MINUSMINUS_TOKEN 0xAA + +#define _SCALAR_ASSIGN_TOKEN 0xB0 +#define _SCALAR_PLUSEQS_TOKEN 0xB1 +#define _SCALAR_MINUSEQS_TOKEN 0xB2 +#define _SCALAR_TIMESEQS_TOKEN 0xB3 +#define _SCALAR_DIVEQS_TOKEN 0xB4 +#define _SCALAR_BOREQS_TOKEN 0xB5 +#define _SCALAR_BANDEQS_TOKEN 0xB6 +#define _SCALAR_PLUSPLUS_TOKEN 0xB7 +#define _SCALAR_POST_PLUSPLUS_TOKEN 0xB8 +#define _SCALAR_MINUSMINUS_TOKEN 0xB9 +#define _SCALAR_POST_MINUSMINUS_TOKEN 0xBA + +#define _DEREF_ASSIGN_TOKEN 0xC0 +#define _DEREF_PLUSEQS_TOKEN 0xC1 +#define _DEREF_MINUSEQS_TOKEN 0xC2 +#define _DEREF_TIMESEQS_TOKEN 0xC3 +#define _DEREF_DIVEQS_TOKEN 0xC4 +#define _DEREF_BOREQS_TOKEN 0xC5 +#define _DEREF_BANDEQS_TOKEN 0xC6 +#define _DEREF_PLUSPLUS_TOKEN 0xC7 +#define _DEREF_POST_PLUSPLUS_TOKEN 0xC8 +#define _DEREF_MINUSMINUS_TOKEN 0xC9 +#define _DEREF_POST_MINUSMINUS_TOKEN 0xCA + +#define LAST_ASSIGN_TOKEN 0xCA +#define IS_ASSIGN_TOKEN(t) (((t)>=FIRST_ASSIGN_TOKEN)&&((t)<=LAST_ASSIGN_TOKEN)) + +#define _INLINE_ARRAY_TOKEN 0xE0 +#define _INLINE_IMPLICIT_ARRAY_TOKEN 0xE1 +#define _NULL_TOKEN 0xE2 +#define _INLINE_WILDCARD_ARRAY_TOKEN 0xE3 + +#define LINE_NUM_TOKEN 0xFC +#define ARG_TOKEN 0xFD +#define EARG_TOKEN 0xFE +#define NO_OP_LITERAL 0xFF + +typedef struct +{ + /* sltoken.c */ + /* SLang_eval_object */ + SLang_Load_Type *llt; + SLPreprocess_Type *this_slpp; + /* prep_get_char() */ + char *input_line; + char cchar; + /* get_token() */ + int want_nl_token; + + /* slparse.c */ + _SLang_Token_Type ctok; + int block_depth; + int assignment_expression; + + /* slang.c : SLcompile() */ + _SLang_Token_Type save_token; + _SLang_Token_Type next_token; + void (*slcompile_ptr)(_SLang_Token_Type *); +} +_SLEval_Context; + +extern int _SLget_token (_SLang_Token_Type *); +extern void _SLparse_error (char *, _SLang_Token_Type *, int); +extern void _SLparse_start (SLang_Load_Type *); +extern int _SLget_rpn_token (_SLang_Token_Type *); +extern void _SLcompile_byte_compiled (void); + +extern int (*_SLprep_eval_hook) (char *); + +#ifdef HAVE_VSNPRINTF +#define _SLvsnprintf vsnprintf +#else +extern int _SLvsnprintf (char *, unsigned int, char *, va_list); +#endif + +#ifdef HAVE_SNPRINTF +# define _SLsnprintf snprintf +#else +extern int _SLsnprintf (char *, unsigned int, char *, ...); +#endif + +#undef _INLINE_ +#if defined(__GNUC__) && _SLANG_USE_INLINE_CODE +# define _INLINE_ __inline__ +#else +# define _INLINE_ +#endif + + +#endif /* _PRIVATE_SLANG_H_ */ diff --git a/mdk-stage1/slang/config.h b/mdk-stage1/slang/config.h new file mode 100644 index 000000000..a5ab3273c --- /dev/null +++ b/mdk-stage1/slang/config.h @@ -0,0 +1,163 @@ +/* src/sysconf.h. Generated automatically by configure. */ +/* -*- c -*- */ +/* Note: this is for unix only. */ + +#ifndef SL_CONFIG_H +#define SL_CONFIG_H + +/* define if you have stdlib.h */ +#define HAVE_STDLIB_H 1 + +/* define if you have unistd.h */ +#define HAVE_UNISTD_H 1 + +/* define if you have termios.h */ +#define HAVE_TERMIOS_H 1 + +/* define if you have memory.h */ +#define HAVE_MEMORY_H 1 + +/* define if you have malloc.h */ +#define HAVE_MALLOC_H 1 + +/* define if you have memset */ +#define HAVE_MEMSET 1 + +/* define if you have memcpy */ +#define HAVE_MEMCPY 1 + +//#define HAVE_SETLOCALE 1 +//#define HAVE_LOCALE_H 1 + +#define HAVE_VFSCANF 1 + +/* define if you have fcntl.h */ +#define HAVE_FCNTL_H 1 + +/* Define if you have the vsnprintf, snprintf functions and they return + * EOF upon failure. + */ +#define HAVE_VSNPRINTF 1 +#define HAVE_SNPRINTF 1 + +/* define if you have sys/fcntl.h */ +#define HAVE_SYS_FCNTL_H 1 + +#define HAVE_SYS_TYPES_H 1 +#define HAVE_SYS_WAIT_H 1 +#define HAVE_SYS_TIMES_H 1 + +/* Set these to the appropriate values */ +#define SIZEOF_SHORT 2 +#define SIZEOF_INT 4 +#define SIZEOF_LONG 4 +#define SIZEOF_FLOAT 4 +#define SIZEOF_DOUBLE 8 + +/* define if you have these. */ +#define HAVE_ATEXIT 1 +#define HAVE_ON_EXIT 1 +#define HAVE_PUTENV 1 +#define HAVE_GETCWD 1 +#define HAVE_TCGETATTR 1 +#define HAVE_TCSETATTR 1 +#define HAVE_CFGETOSPEED 1 +#define HAVE_LSTAT 1 +#define HAVE_KILL 1 +#define HAVE_CHOWN 1 +#define HAVE_VSNPRINTF 1 +#define HAVE_POPEN 1 +#define HAVE_UMASK 1 +#define HAVE_READLINK 1 +#define HAVE_TIMES 1 +#define HAVE_GMTIME 1 +#define HAVE_MKFIFO 1 + +#define HAVE_GETPPID 1 +#define HAVE_GETGID 1 +#define HAVE_GETEGID 1 +#define HAVE_GETEUID 1 +/* #undef HAVE_GETUID */ + +#define HAVE_SETGID 1 +#define HAVE_SETPGID 1 +#define HAVE_SETUID 1 + +#define HAVE_ACOSH 1 +#define HAVE_ASINH 1 +#define HAVE_ATANH 1 + +#define HAVE_DIRENT_H 1 +/* #undef HAVE_SYS_NDIR_H */ +/* #undef HAVE_SYS_DIR_H */ +/* #undef HAVE_NDIR_H */ + +#define HAVE_DLFCN_H 1 + +#define HAVE_SYS_UTSNAME_H 1 +#define HAVE_UNAME 1 + +/* These two are needed on DOS-like systems. Unix does not require them. + * They are included here for consistency. + * +#define HAVE_IO_H +#define HAVE_PROCESS_H + */ + +/* #undef USE_TERMCAP */ + +/* #undef mode_t */ +/* #undef uid_t */ +/* #undef pid_t */ +/* #undef gid_t */ + +/* Do we have posix signals? */ +#define HAVE_SIGACTION 1 +#define HAVE_SIGPROCMASK 1 +#define HAVE_SIGEMPTYSET 1 +#define HAVE_SIGADDSET 1 + +#if defined(HAVE_SIGADDSET) && defined(HAVE_SIGEMPTYSET) +# if defined(HAVE_SIGACTION) && defined(HAVE_SIGPROCMASK) +# define SLANG_POSIX_SIGNALS +# endif +#endif + +/* Define if you need to in order for stat and other things to work. */ +/* #undef _POSIX_SOURCE */ + +#ifdef _AIX +# ifndef _POSIX_SOURCE +# define _POSIX_SOURCE 1 +# endif +# ifndef _ALL_SOURCE +# define _ALL_SOURCE +# endif +/* This may generate warnings but the fact is that without it, xlc will + * INCORRECTLY inline many str* functions. */ +/* # undef __STR__ */ +#endif + +/* define USE_TERMCAP if you want to use it instead of terminfo. */ +#if defined(sequent) || defined(NeXT) +# ifndef USE_TERMCAP +# define USE_TERMCAP +# endif +#endif + +#if defined(ultrix) && !defined(__GNUC__) +# ifndef NO_PROTOTYPES +# define NO_PROTOTYPES +# endif +#endif + +#ifndef unix +# define unix 1 +#endif + +#ifndef __unix__ +# define __unix__ 1 +#endif + +#define _SLANG_SOURCE_ 1 +#endif /* SL_CONFIG_H */ diff --git a/mdk-stage1/slang/jdmacros.h b/mdk-stage1/slang/jdmacros.h new file mode 100644 index 000000000..70d491b78 --- /dev/null +++ b/mdk-stage1/slang/jdmacros.h @@ -0,0 +1,53 @@ +#ifndef _JD_MACROS_H_ +#define _JD_MACROS_H_ + +#ifndef SLMEMSET +# ifdef HAVE_MEMSET +# define SLMEMSET memset +# else +# define SLMEMSET SLmemset +# endif +#endif + +#ifndef SLMEMCHR +# ifdef HAVE_MEMCHR +# define SLMEMCHR memchr +# else +# define SLMEMCHR SLmemchr +# endif +#endif + +#ifndef SLMEMCPY +# ifdef HAVE_MEMCPY +# define SLMEMCPY memcpy +# else +# define SLMEMCPY SLmemcpy +# endif +#endif + +/* Note: HAVE_MEMCMP requires an unsigned memory comparison!!! */ +#ifndef SLMEMCMP +# ifdef HAVE_MEMCMP +# define SLMEMCMP memcmp +# else +# define SLMEMCMP SLmemcmp +# endif +#endif + +#ifndef SLFREE +# define SLFREE free +#endif + +#ifndef SLMALLOC +# define SLMALLOC malloc +#endif + +#ifndef SLCALLOC +# define SLCALLOC calloc +#endif + +#ifndef SLREALLOC +# define SLREALLOC realloc +#endif + +#endif /* _JD_MACROS_H_ */ diff --git a/mdk-stage1/slang/keywhash.c b/mdk-stage1/slang/keywhash.c new file mode 100644 index 000000000..17d94d5a3 --- /dev/null +++ b/mdk-stage1/slang/keywhash.c @@ -0,0 +1,190 @@ +/* Perfect hash generated by command line: + * ./a.out 1 + */ +#define MIN_HASH_VALUE 2 +#define MAX_HASH_VALUE 118 +#define MIN_KEYWORD_LEN 2 +#define MAX_KEYWORD_LEN 11 + +static unsigned char Keyword_Hash_Table [256] = +{ + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 1, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 9, 7, 1, 8, 2, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 0, 0, 119, 0, 119, 119, 119, 7, 119, 0, 0, 119, 119, 0, + 119, 119, 0, 0, 0, 0, 119, 119, 0, 119, 119, 119, 119, 119, 119, 2, + 119, 41, 1, 1, 9, 0, 55, 8, 0, 0, 119, 0, 27, 0, 0, 0, + 7, 2, 0, 21, 0, 0, 0, 3, 2, 0, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119 +}; + +static unsigned char keyword_hash (char *s, unsigned int len) +{ + unsigned int sum; + + sum = len; + while (len) + { + len--; + sum += (unsigned int) Keyword_Hash_Table [(unsigned char)s[len]]; + } + return sum; +} + +typedef struct +{ + char *name; + unsigned int type; +} +Keyword_Table_Type; + +static Keyword_Table_Type Keyword_Table [/* 117 */] = +{ + {"or", OR_TOKEN}, + {"not", NOT_TOKEN}, + {NULL,0}, + {"xor", BXOR_TOKEN}, + {"return", RETURN_TOKEN}, + {"exch", EXCH_TOKEN}, + {NULL,0}, + {"continue", CONT_TOKEN}, + {NULL,0}, + {"do", DO_TOKEN}, + {"mod", MOD_TOKEN}, + {"ERROR_BLOCK", ERRBLK_TOKEN}, + {"USER_BLOCK2", USRBLK2_TOKEN}, + {"USER_BLOCK4", USRBLK4_TOKEN}, + {"__tmp", TMP_TOKEN}, + {"pop", POP_TOKEN}, + {NULL,0}, + {"EXIT_BLOCK", EXITBLK_TOKEN}, + {"USER_BLOCK1", USRBLK1_TOKEN}, + {"USER_BLOCK3", USRBLK3_TOKEN}, + {"USER_BLOCK0", USRBLK0_TOKEN}, + {NULL,0}, + {"shr", SHR_TOKEN}, + {"chs", CHS_TOKEN}, + {"sqr", SQR_TOKEN}, + {NULL,0}, + {"struct", STRUCT_TOKEN}, + {NULL,0}, + {NULL,0}, + {"switch", SWITCH_TOKEN}, + {"mul2", MUL2_TOKEN}, + {"sign", SIGN_TOKEN}, + {"using", USING_TOKEN}, + {"while", WHILE_TOKEN}, + {NULL,0}, + {NULL,0}, + {"loop", LOOP_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"public", PUBLIC_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"break", BREAK_TOKEN}, + {NULL,0}, + {"do_while", DOWHILE_TOKEN}, + {NULL,0}, + {"shl", SHL_TOKEN}, + {"else", ELSE_TOKEN}, + {"and", AND_TOKEN}, + {"orelse", ORELSE_TOKEN}, + {"private", PRIVATE_TOKEN}, + {NULL,0}, + {"if", IF_TOKEN}, + {"for", FOR_TOKEN}, + {"!if", IFNOT_TOKEN}, + {NULL,0}, + {"_for", _FOR_TOKEN}, + {"forever", FOREVER_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"abs", ABS_TOKEN}, + {"case", CASE_TOKEN}, + {NULL,0}, + {"static", STATIC_TOKEN}, + {"define", DEFINE_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"typedef", TYPEDEF_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"foreach", FOREACH_TOKEN}, + {"andelse", ANDELSE_TOKEN}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {NULL,0}, + {"variable", VARIABLE_TOKEN}, +}; + +static Keyword_Table_Type *is_keyword (char *str, unsigned int len) +{ + unsigned int hash; + char *name; + Keyword_Table_Type *kw; + + if ((len < MIN_KEYWORD_LEN) + || (len > MAX_KEYWORD_LEN)) + return NULL; + + hash = keyword_hash (str, len); + if ((hash > MAX_HASH_VALUE) || (hash < MIN_HASH_VALUE)) + return NULL; + + kw = &Keyword_Table[hash - MIN_HASH_VALUE]; + if ((NULL != (name = kw->name)) + && (*str == *name) + && (0 == strcmp (str, name))) + return kw; + return NULL; +} diff --git a/mdk-stage1/slang/sl-feat.h b/mdk-stage1/slang/sl-feat.h new file mode 100644 index 000000000..511d72451 --- /dev/null +++ b/mdk-stage1/slang/sl-feat.h @@ -0,0 +1,60 @@ +/* Setting this to 1 enables automatic support for associative arrays. + * If this is set to 0, an application must explicitly enable associative + * array support via SLang_init_slassoc. + */ +#define SLANG_HAS_ASSOC_ARRAYS 1 + +#define SLANG_HAS_COMPLEX 1 +#define SLANG_HAS_FLOAT 1 + +/* This is the old space-speed trade off. To reduce memory usage and code + * size, set this to zero. + */ +#define _SLANG_OPTIMIZE_FOR_SPEED 2 + +#define _SLANG_USE_INLINE_CODE 1 + +/* This is experimental. It adds extra information for tracking down + * errors. + */ +#define _SLANG_HAS_DEBUG_CODE 1 + +/* Allow optimizations based upon the __tmp operator. */ +#define _SLANG_USE_TMP_OPTIMIZATION 1 + +/* Setting this to one will map 8 bit vtxxx terminals to 7 bit. Terminals + * such as the vt320 can be set up to output the two-character escape sequence + * encoded as 'ESC [' as single character. Setting this variable to 1 will + * insert code to map such characters to the 7 bit equivalent. + * This affects just input characters in the range 128-160 on non PC + * systems. + */ +#if defined(VMS) || defined(AMIGA) +# define _SLANG_MAP_VTXXX_8BIT 1 +#else +# define _SLANG_MAP_VTXXX_8BIT 0 +#endif + +/* Add support for color terminals that cannot do background color erases + * Such terminals are poorly designed and are slowly disappearing but they + * are still quite common. For example, screen is one of them! + * + * This is experimental. In particular, it is not known to work if + * KANJI suupport is enabled. + */ +#if !defined(IBMPC_SYSTEM) +# define SLTT_HAS_NON_BCE_SUPPORT 1 +#else +# define SLTT_HAS_NON_BCE_SUPPORT 0 +#endif + +/* If you want slang to assume that an xterm always has the background color + * erase feature, then set this to 1. Otherwise, it will check the terminfo + * database. This may or may not be a good idea since most good color xterms + * support bce but many terminfo systems do not support it. + */ +#define SLTT_XTERM_ALWAYS_BCE 0 + +/* Set this to 1 to enable Kanji support. See above comment. */ +#define SLANG_HAS_KANJI_SUPPORT 0 + diff --git a/mdk-stage1/slang/slang.c b/mdk-stage1/slang/slang.c new file mode 100644 index 000000000..6edc7df37 --- /dev/null +++ b/mdk-stage1/slang/slang.c @@ -0,0 +1,5547 @@ +/* -*- mode: C; mode: fold; -*- */ +/* slang.c --- guts of S-Lang interpreter */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if SLANG_HAS_FLOAT +# include <math.h> +#endif + +#include "slang.h" +#include "_slang.h" + +#define USE_COMBINED_BYTECODES 0 + +struct _SLBlock_Type; + +typedef struct +{ + struct _SLBlock_Type *body; + unsigned int num_refs; +} +_SLBlock_Header_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + union + { + _SLBlock_Header_Type *header; /* body of function */ + char *autoload_filename; + } + v; +#if _SLANG_HAS_DEBUG_CODE + char *file; +#endif +#define SLANG_MAX_LOCAL_VARIABLES 254 +#define AUTOLOAD_NUM_LOCALS (SLANG_MAX_LOCAL_VARIABLES + 1) + unsigned char nlocals; /* number of local variables */ + unsigned char nargs; /* number of arguments */ +} +_SLang_Function_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + SLang_Object_Type obj; +} +SLang_Global_Var_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + int local_var_number; +} +SLang_Local_Var_Type; + +typedef struct _SLBlock_Type +{ + unsigned char bc_main_type; + unsigned char bc_sub_type; + union + { + struct _SLBlock_Type *blk; + int i_blk; + + SLang_Name_Type *nt_blk; + SLang_App_Unary_Type *nt_unary_blk; + SLang_Intrin_Var_Type *nt_ivar_blk; + SLang_Intrin_Fun_Type *nt_ifun_blk; + SLang_Global_Var_Type *nt_gvar_blk; + SLang_IConstant_Type *iconst_blk; + SLang_DConstant_Type *dconst_blk; + _SLang_Function_Type *nt_fun_blk; + + VOID_STAR ptr_blk; + char *s_blk; + SLang_BString_Type *bs_blk; + +#if SLANG_HAS_FLOAT + double *double_blk; /*literal double is a pointer */ +#endif + float float_blk; + long l_blk; + struct _SLang_Struct_Type *struct_blk; + int (*call_function)(void); + } + b; +} +SLBlock_Type; + +/* Debugging and tracing variables */ + +void (*SLang_Enter_Function)(char *) = NULL; +void (*SLang_Exit_Function)(char *) = NULL; +/* If non null, these call C functions before and after a slang function. */ + +int _SLang_Trace = 0; +/* If _SLang_Trace = -1, do not trace intrinsics */ +static int Trace_Mode = 0; + +static char *Trace_Function; /* function to be traced */ +int SLang_Traceback = 0; +/* non zero means do traceback. If less than 0, do not show local variables */ + +/* These variables handle _NARGS processing by the parser */ +int SLang_Num_Function_Args; +static int *Num_Args_Stack; +static unsigned int Recursion_Depth; +static SLang_Object_Type *Frame_Pointer; +static int Next_Function_Num_Args; +static unsigned int Frame_Pointer_Depth; +static unsigned int *Frame_Pointer_Stack; + +static int Lang_Break_Condition = 0; +/* true if any one below is true. This keeps us from testing 3 variables. + * I know this can be perfomed with a bitmapped variable, but... + */ +static int Lang_Break = 0; +static int Lang_Return = 0; +/* static int Lang_Continue = 0; */ + +SLang_Object_Type *_SLRun_Stack; +SLang_Object_Type *_SLStack_Pointer; +static SLang_Object_Type *_SLStack_Pointer_Max; + +/* Might want to increase this. */ +static SLang_Object_Type Local_Variable_Stack[SLANG_MAX_LOCAL_STACK]; +static SLang_Object_Type *Local_Variable_Frame = Local_Variable_Stack; + +static void free_function_header (_SLBlock_Header_Type *); + +void (*SLang_Dump_Routine)(char *); + +static void call_dump_routine (char *fmt, ...) +{ + char buf[1024]; + va_list ap; + + va_start (ap, fmt); + if (SLang_Dump_Routine != NULL) + { + (void) _SLvsnprintf (buf, sizeof (buf), fmt, ap); + (*SLang_Dump_Routine) (buf); + } + else + { + vfprintf (stderr, fmt, ap); + fflush (stderr); + } + va_end (ap); +} + +static void do_traceback (char *, unsigned int, char *); +static int init_interpreter (void); + +/*{{{ push/pop/etc stack manipulation functions */ + +/* This routine is assumed to work even in the presence of a SLang_Error. */ +_INLINE_ +int SLang_pop (SLang_Object_Type *x) +{ + register SLang_Object_Type *y; + + y = _SLStack_Pointer; + if (y == _SLRun_Stack) + { + if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW; + x->data_type = 0; + return -1; + } + y--; + *x = *y; + + _SLStack_Pointer = y; + return 0; +} + +static int pop_ctrl_integer (int *i) +{ + int type; + SLang_Class_Type *cl; +#if _SLANG_OPTIMIZE_FOR_SPEED + register SLang_Object_Type *y; + + /* Most of the time, either an integer or a char will be on the stack. + * Optimize these cases. + */ + y = _SLStack_Pointer; + if (y == _SLRun_Stack) + { + if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + y--; + + type = y->data_type; + if (type == SLANG_INT_TYPE) + { + _SLStack_Pointer = y; + *i = y->v.int_val; + return 0; + } + if (type == SLANG_CHAR_TYPE) + { + _SLStack_Pointer = y; + *i = y->v.char_val; + return 0; + } +#else + if (-1 == (type = SLang_peek_at_stack ())) + return -1; +#endif + + cl = _SLclass_get_class ((unsigned char) type); + if (cl->cl_to_bool == NULL) + { + SLang_verror (SL_TYPE_MISMATCH, + "%s cannot be used in a boolean context", + cl->cl_name); + return -1; + } + return cl->cl_to_bool ((unsigned char) type, i); +} + +_INLINE_ +int SLang_peek_at_stack (void) +{ + if (_SLStack_Pointer == _SLRun_Stack) + { + if (SLang_Error == 0) + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + + return (_SLStack_Pointer - 1)->data_type; +} + +int SLang_peek_at_stack1 (void) +{ + int type; + + type = SLang_peek_at_stack (); + if (type == SLANG_ARRAY_TYPE) + type = (_SLStack_Pointer - 1)->v.array_val->data_type; + + return type; +} + +_INLINE_ +void SLang_free_object (SLang_Object_Type *obj) +{ + unsigned char data_type; + SLang_Class_Type *cl; + + if (obj == NULL) return; + data_type = obj->data_type; +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [data_type]) + return; + if (data_type == SLANG_STRING_TYPE) + { + SLang_free_slstring (obj->v.s_val); + return; + } +#endif + cl = _SLclass_get_class (data_type); +#if !_SLANG_OPTIMIZE_FOR_SPEED + if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR) +#endif + (*cl->cl_destroy) (data_type, (VOID_STAR) &obj->v); +} + +_INLINE_ +int SLang_push (SLang_Object_Type *x) +{ + register SLang_Object_Type *y; + y = _SLStack_Pointer; + + /* if there is a SLang_Error, probably not much harm will be done + if it is ignored here */ + /* if (SLang_Error) return; */ + + /* flag it now */ + if (y >= _SLStack_Pointer_Max) + { + if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW; + return -1; + } + + *y = *x; + _SLStack_Pointer = y + 1; + return 0; +} + +/* _INLINE_ */ +int SLclass_push_ptr_obj (unsigned char type, VOID_STAR pval) +{ + register SLang_Object_Type *y; + y = _SLStack_Pointer; + + if (y >= _SLStack_Pointer_Max) + { + if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW; + return -1; + } + + y->data_type = type; + y->v.ptr_val = pval; + + _SLStack_Pointer = y + 1; + return 0; +} + +_INLINE_ +int SLclass_push_int_obj (unsigned char type, int x) +{ + register SLang_Object_Type *y; + y = _SLStack_Pointer; + + if (y >= _SLStack_Pointer_Max) + { + if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW; + return -1; + } + + y->data_type = type; + y->v.int_val = x; + + _SLStack_Pointer = y + 1; + return 0; +} + +_INLINE_ +int _SLang_pop_object_of_type (unsigned char type, SLang_Object_Type *obj, + int allow_arrays) +{ + register SLang_Object_Type *y; + + y = _SLStack_Pointer; + if (y == _SLRun_Stack) + return SLang_pop (obj); + y--; + if (y->data_type != type) + { +#if _SLANG_OPTIMIZE_FOR_SPEED + /* This is an implicit typecast. We do not want to typecast + * floats to ints implicitly. + */ + if (_SLarith_Is_Arith_Type [type] + && _SLarith_Is_Arith_Type [y->data_type] + && (_SLarith_Is_Arith_Type [type] >= _SLarith_Is_Arith_Type[y->data_type])) + { + /* This should not fail */ + (void) _SLarith_typecast (y->data_type, (VOID_STAR)&y->v, 1, + type, (VOID_STAR)&obj->v); + obj->data_type = type; + _SLStack_Pointer = y; + return 0; + } +#endif + + if ((allow_arrays == 0) + || (y->data_type != SLANG_ARRAY_TYPE) + || (y->v.array_val->data_type != type)) + if (-1 == SLclass_typecast (type, 1, 0)) + return -1; + } + *obj = *y; + _SLStack_Pointer = y; + return 0; +} + +/* This function reverses the top n items on the stack and returns a + * an offset from the start of the stack to the last item. + */ +int SLreverse_stack (int n) +{ + SLang_Object_Type *otop, *obot, tmp; + + otop = _SLStack_Pointer; + if ((n > otop - _SLRun_Stack) || (n < 0)) + { + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + obot = otop - n; + otop--; + while (otop > obot) + { + tmp = *obot; + *obot = *otop; + *otop = tmp; + otop--; + obot++; + } + return (int) ((_SLStack_Pointer - n) - _SLRun_Stack); +} + +_INLINE_ +int SLroll_stack (int np) +{ + int n, i; + SLang_Object_Type *otop, *obot, tmp; + + if ((n = abs(np)) <= 1) return 0; /* identity */ + + obot = otop = _SLStack_Pointer; + i = n; + while (i != 0) + { + if (obot <= _SLRun_Stack) + { + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + obot--; + i--; + } + otop--; + + if (np > 0) + { + /* Put top on bottom and roll rest up. */ + tmp = *otop; + while (otop > obot) + { + *otop = *(otop - 1); + otop--; + } + *otop = tmp; + } + else + { + /* Put bottom on top and roll rest down. */ + tmp = *obot; + while (obot < otop) + { + *obot = *(obot + 1); + obot++; + } + *obot = tmp; + } + return 0; +} + +int _SLstack_depth (void) +{ + return (int) (_SLStack_Pointer - _SLRun_Stack); +} + +int SLdup_n (int n) +{ + SLang_Object_Type *bot, *top; + + if (n <= 0) + return 0; + + top = _SLStack_Pointer; + if (top < _SLRun_Stack + n) + { + if (SLang_Error == 0) + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + if (top + n > _SLStack_Pointer_Max) + { + if (SLang_Error == 0) + SLang_Error = SL_STACK_OVERFLOW; + return -1; + } + bot = top - n; + + while (bot < top) + { + SLang_Class_Type *cl; + unsigned char data_type = bot->data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [data_type]) + { + *_SLStack_Pointer++ = *bot++; + continue; + } +#endif + cl = _SLclass_get_class (data_type); + if (-1 == (*cl->cl_push) (data_type, (VOID_STAR) &bot->v)) + return -1; + bot++; + } + return 0; +} + +/*}}}*/ + +/*{{{ inner interpreter and support functions */ + +_INLINE_ +int _SL_increment_frame_pointer (void) +{ + if (Recursion_Depth >= SLANG_MAX_RECURSIVE_DEPTH) + { + SLang_verror (SL_STACK_OVERFLOW, "Num Args Stack Overflow"); + return -1; + } + Num_Args_Stack [Recursion_Depth] = SLang_Num_Function_Args; + + SLang_Num_Function_Args = Next_Function_Num_Args; + Next_Function_Num_Args = 0; + Recursion_Depth++; + return 0; +} + +_INLINE_ +int _SL_decrement_frame_pointer (void) +{ + if (Recursion_Depth == 0) + { + SLang_verror (SL_STACK_UNDERFLOW, "Num Args Stack Underflow"); + return -1; + } + + Recursion_Depth--; + if (Recursion_Depth < SLANG_MAX_RECURSIVE_DEPTH) + SLang_Num_Function_Args = Num_Args_Stack [Recursion_Depth]; + + return 0; +} + +_INLINE_ +int SLang_start_arg_list (void) +{ + if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH) + { + Frame_Pointer_Stack [Frame_Pointer_Depth] = (unsigned int) (Frame_Pointer - _SLRun_Stack); + Frame_Pointer = _SLStack_Pointer; + Frame_Pointer_Depth++; + Next_Function_Num_Args = 0; + return 0; + } + + SLang_verror (SL_STACK_OVERFLOW, "Frame Stack Overflow"); + return -1; +} + +_INLINE_ +int SLang_end_arg_list (void) +{ + if (Frame_Pointer_Depth == 0) + { + SLang_verror (SL_STACK_UNDERFLOW, "Frame Stack Underflow"); + return -1; + } + Frame_Pointer_Depth--; + if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH) + { + Next_Function_Num_Args = (int) (_SLStack_Pointer - Frame_Pointer); + Frame_Pointer = _SLRun_Stack + Frame_Pointer_Stack [Frame_Pointer_Depth]; + } + return 0; +} + +_INLINE_ +static int do_bc_call_direct_frame (int (*f)(void)) +{ + if ((0 == SLang_end_arg_list ()) + && (0 == _SL_increment_frame_pointer ())) + { + (void) (*f) (); + _SL_decrement_frame_pointer (); + } + if (SLang_Error) + return -1; + return 0; +} + +static int do_name_type_error (SLang_Name_Type *nt) +{ + char buf[256]; + if (nt != NULL) + { + (void) _SLsnprintf (buf, sizeof (buf), "(Error occurred processing %s)", nt->name); + do_traceback (buf, 0, NULL); + } + return -1; +} + +/* local and global variable assignments */ + +static int do_binary_ab (int op, SLang_Object_Type *obja, SLang_Object_Type *objb) +{ + SLang_Class_Type *a_cl, *b_cl, *c_cl; + unsigned char b_data_type, a_data_type, c_data_type; + int (*binary_fun) (int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR); + VOID_STAR pa; + VOID_STAR pb; + VOID_STAR pc; + int ret; + + b_data_type = objb->data_type; + a_data_type = obja->data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (_SLarith_Is_Arith_Type[a_data_type] + && _SLarith_Is_Arith_Type[b_data_type]) + { + int status; + status = _SLarith_bin_op (obja, objb, op); + if (status != 1) + return status; + /* drop and try it the hard way */ + } +#endif + + a_cl = _SLclass_get_class (a_data_type); + if (a_data_type == b_data_type) + b_cl = a_cl; + else + b_cl = _SLclass_get_class (b_data_type); + + if (NULL == (binary_fun = _SLclass_get_binary_fun (op, a_cl, b_cl, &c_cl, 1))) + return -1; + + c_data_type = c_cl->cl_data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [a_data_type]) + pa = (VOID_STAR) &obja->v; + else +#endif + pa = _SLclass_get_ptr_to_value (a_cl, obja); + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [b_data_type]) + pb = (VOID_STAR) &objb->v; + else +#endif + pb = _SLclass_get_ptr_to_value (b_cl, objb); + + pc = c_cl->cl_transfer_buf; + + if (1 != (*binary_fun) (op, + a_data_type, pa, 1, + b_data_type, pb, 1, + pc)) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Binary operation between %s and %s failed", + a_cl->cl_name, b_cl->cl_name); + + return -1; + } + + /* apush will create a copy, so make sure we free after the push */ + ret = (*c_cl->cl_apush)(c_data_type, pc); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [c_data_type]) +#endif + (*c_cl->cl_adestroy)(c_data_type, pc); + + return ret; +} + +_INLINE_ +static void do_binary (int op) +{ + SLang_Object_Type obja, objb; + + if (SLang_pop (&objb)) return; + if (0 == SLang_pop (&obja)) + { + (void) do_binary_ab (op, &obja, &objb); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [obja.data_type]) +#endif + SLang_free_object (&obja); + } +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [objb.data_type]) +#endif + SLang_free_object (&objb); +} + +static int do_unary_op (int op, SLang_Object_Type *obj, int unary_type) +{ + int (*f) (int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); + VOID_STAR pa; + VOID_STAR pb; + SLang_Class_Type *a_cl, *b_cl; + unsigned char a_type, b_type; + int ret; + + a_type = obj->data_type; + a_cl = _SLclass_get_class (a_type); + + if (NULL == (f = _SLclass_get_unary_fun (op, a_cl, &b_cl, unary_type))) + return -1; + + b_type = b_cl->cl_data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [a_type]) + pa = (VOID_STAR) &obj->v; + else +#endif + pa = _SLclass_get_ptr_to_value (a_cl, obj); + + pb = b_cl->cl_transfer_buf; + + if (1 != (*f) (op, a_type, pa, 1, pb)) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Unary operation for %s failed", a_cl->cl_name); + return -1; + } + + ret = (*b_cl->cl_apush)(b_type, pb); + /* cl_apush creates a copy, so make sure we call cl_adestroy */ +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [b_type]) +#endif + (*b_cl->cl_adestroy)(b_type, pb); + + return ret; +} + +_INLINE_ +static int do_unary (int op, int unary_type) +{ + SLang_Object_Type obj; + int ret; + + if (-1 == SLang_pop (&obj)) return -1; + ret = do_unary_op (op, &obj, unary_type); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [obj.data_type]) +#endif + SLang_free_object (&obj); + return ret; +} + +static int do_assignment_binary (int op, SLang_Object_Type *obja_ptr) +{ + SLang_Object_Type objb; + int ret; + + if (SLang_pop (&objb)) + return -1; + + ret = do_binary_ab (op, obja_ptr, &objb); +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [objb.data_type]) +#endif + SLang_free_object (&objb); + return ret; +} + +/* The order of these is assumed to match the binary operators + * defined in slang.h + */ +static int +map_assignment_op_to_binary (unsigned char op_type, int *op, int *is_unary) +{ + *is_unary = 0; + switch (op_type) + { + case _SLANG_BCST_PLUSEQS: + case _SLANG_BCST_MINUSEQS: + case _SLANG_BCST_TIMESEQS: + case _SLANG_BCST_DIVEQS: + *op = SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS); + break; + + case _SLANG_BCST_BOREQS: + *op = SLANG_BOR; + break; + + case _SLANG_BCST_BANDEQS: + *op = SLANG_BAND; + break; + + case _SLANG_BCST_POST_MINUSMINUS: + case _SLANG_BCST_MINUSMINUS: + *op = SLANG_MINUS; + *is_unary = 1; + break; + + case _SLANG_BCST_PLUSPLUS: + case _SLANG_BCST_POST_PLUSPLUS: + *op = SLANG_PLUS; + *is_unary = 1; + break; + + default: + SLang_verror (SL_NOT_IMPLEMENTED, "Assignment operator not implemented"); + return -1; + } + return 0; +} + +static int +perform_lvalue_operation (unsigned char op_type, SLang_Object_Type *obja_ptr) +{ + switch (op_type) + { + case _SLANG_BCST_ASSIGN: + break; + + /* The order of these is assumed to match the binary operators + * defined in slang.h + */ + case _SLANG_BCST_PLUSEQS: + case _SLANG_BCST_MINUSEQS: + case _SLANG_BCST_TIMESEQS: + case _SLANG_BCST_DIVEQS: + if (-1 == do_assignment_binary (SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS), obja_ptr)) + return -1; + break; + + case _SLANG_BCST_BOREQS: + if (-1 == do_assignment_binary (SLANG_BOR, obja_ptr)) + return -1; + break; + + case _SLANG_BCST_BANDEQS: + if (-1 == do_assignment_binary (SLANG_BAND, obja_ptr)) + return -1; + break; + + case _SLANG_BCST_PLUSPLUS: + case _SLANG_BCST_POST_PLUSPLUS: +#if _SLANG_OPTIMIZE_FOR_SPEED + if (obja_ptr->data_type == SLANG_INT_TYPE) + return SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_val + 1); +#endif + if (-1 == do_unary_op (SLANG_PLUSPLUS, obja_ptr, _SLANG_BC_UNARY)) + return -1; + break; + + case _SLANG_BCST_MINUSMINUS: + case _SLANG_BCST_POST_MINUSMINUS: +#if _SLANG_OPTIMIZE_FOR_SPEED + if (obja_ptr->data_type == SLANG_INT_TYPE) + return SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_val - 1); +#endif + if (-1 == do_unary_op (SLANG_MINUSMINUS, obja_ptr, _SLANG_BC_UNARY)) + return -1; + break; + + default: + SLang_Error = SL_INTERNAL_ERROR; + return -1; + } + return 0; +} + +_INLINE_ +static int +set_lvalue_obj (unsigned char op_type, SLang_Object_Type *obja_ptr) +{ + if (op_type != _SLANG_BCST_ASSIGN) + { + if (-1 == perform_lvalue_operation (op_type, obja_ptr)) + return -1; + } +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [obja_ptr->data_type]) +#endif + SLang_free_object (obja_ptr); + + return SLang_pop(obja_ptr); +} + +static int +set_struct_lvalue (SLBlock_Type *bc_blk) +{ + int type; + SLang_Class_Type *cl; + char *name; + int op; + + if (-1 == (type = SLang_peek_at_stack ())) + return -1; + + cl = _SLclass_get_class (type); + if ((cl->cl_sput == NULL) + || (cl->cl_sget == NULL)) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "%s does not support structure access", + cl->cl_name); + SLdo_pop_n (2); /* object plus what was to be assigned */ + return -1; + } + name = bc_blk->b.s_blk; + op = bc_blk->bc_sub_type; + + if (op != _SLANG_BCST_ASSIGN) + { + /* We have something like (A.x += b) or (A.x++). In either case, + * we need A.x. + */ + SLang_Object_Type obj_A; + SLang_Object_Type obj; + + if (-1 == SLang_pop (&obj_A)) + return -1; + + if ((-1 == _SLpush_slang_obj (&obj_A)) + || (-1 == cl->cl_sget ((unsigned char) type, name)) + || (-1 == SLang_pop (&obj))) + { + SLang_free_object (&obj_A); + return -1; + } + /* Now the value of A.x is in obj. */ + if (-1 == perform_lvalue_operation (op, &obj)) + { + SLang_free_object (&obj); + SLang_free_object (&obj_A); + return -1; + } + SLang_free_object (&obj); + /* The result of the operation is now on the stack. + * Perform assignment */ + if (-1 == SLang_push (&obj_A)) + { + SLang_free_object (&obj_A); + return -1; + } + } + + return (*cl->cl_sput) ((unsigned char) type, name); +} + +static int make_unit_object (SLang_Object_Type *a, SLang_Object_Type *u) +{ + unsigned char type; + + type = a->data_type; + if (type == SLANG_ARRAY_TYPE) + type = a->v.array_val->data_type; + + u->data_type = type; + switch (type) + { + case SLANG_UCHAR_TYPE: + case SLANG_CHAR_TYPE: + u->v.char_val = 1; + break; + + case SLANG_SHORT_TYPE: + case SLANG_USHORT_TYPE: + u->v.short_val = 1; + break; + + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: + u->v.long_val = 1; + break; + +#if SLANG_HAS_FLOAT + case SLANG_FLOAT_TYPE: + u->v.float_val = 1; + break; + + case SLANG_COMPLEX_TYPE: + u->data_type = SLANG_DOUBLE_TYPE; + case SLANG_DOUBLE_TYPE: + u->v.double_val = 1; + break; +#endif + default: + u->data_type = SLANG_INT_TYPE; + u->v.int_val = 1; + } + return 0; +} + + +/* We want to convert 'A[i] op X' to 'A[i] = A[i] op X'. The code that + * has been generated is: X __args i A __aput-op + * where __aput-op represents this function. We need to generate: + * __args i A __eargs __aget X op __args i A __eargs __aput + * Here, __eargs implies a call to do_bc_call_direct_frame with either + * the aput or aget function. In addition, __args represents a call to + * SLang_start_arg_list. Of course, i represents a set of indices. + * + * Note: If op is an unary operation (e.g., ++ or --), then X will not + * b present an will have to be taken to be 1. + * + * Implementation note: For efficiency, calls to setup the frame, start + * arg list will be omitted and SLang_Num_Function_Args will be set. + * This is ugly but the alternative is much less efficient rendering these + * assignment operators useless. So, the plan is to roll the stack to get X, + * then duplicate the next N values, call __aget followed by op X, finally + * calling __aput. Hence, the sequence is: + * + * start: X i .. j A + * dupN: X i .. j A i .. j A + * __aget: X i .. j A Y + * roll: i .. j A Y X + * op: i .. j A Z + * roll: Z i .. j A + * __aput: + */ +static int +set_array_lvalue (int op) +{ + SLang_Object_Type x, y; + int num_args, is_unary; + + if (-1 == map_assignment_op_to_binary (op, &op, &is_unary)) + return -1; + + /* Grab the indices and the array. Do not start a new frame. */ + if (-1 == SLang_end_arg_list ()) + return -1; + num_args = Next_Function_Num_Args; + Next_Function_Num_Args = 0; + + if (-1 == SLdup_n (num_args)) + return -1; + + SLang_Num_Function_Args = num_args; + if (-1 == _SLarray_aget ()) + return -1; + + if (-1 == SLang_pop (&y)) + return -1; + + if (is_unary == 0) + { + if ((-1 == SLroll_stack (-(num_args + 1))) + || (-1 == SLang_pop (&x))) + { + SLang_free_object (&y); + return -1; + } + } + else if (-1 == make_unit_object (&y, &x)) + { + SLang_free_object (&y); + return -1; + } + + if (-1 == do_binary_ab (op, &y, &x)) + { + SLang_free_object (&y); + SLang_free_object (&x); + return -1; + } +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [y.data_type]) +#endif + SLang_free_object (&y); + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [x.data_type]) +#endif + SLang_free_object (&x); + + if (-1 == SLroll_stack (num_args + 1)) + return -1; + + SLang_Num_Function_Args = num_args; + return _SLarray_aput (); +} + + +static int +set_intrin_lvalue (SLBlock_Type *bc_blk) +{ + unsigned char op_type; + SLang_Object_Type obja; + SLang_Class_Type *cl; + SLang_Intrin_Var_Type *ivar; + VOID_STAR intrinsic_addr; + unsigned char intrinsic_type; + + ivar = bc_blk->b.nt_ivar_blk; + + intrinsic_type = ivar->type; + intrinsic_addr = ivar->addr; + + op_type = bc_blk->bc_sub_type; + + cl = _SLclass_get_class (intrinsic_type); + + if (op_type != _SLANG_BCST_ASSIGN) + { + /* We want to get the current value into obja. This is the + * easiest way. + */ + if ((-1 == (*cl->cl_push) (intrinsic_type, intrinsic_addr)) + || (-1 == SLang_pop (&obja))) + return -1; + + (void) perform_lvalue_operation (op_type, &obja); + SLang_free_object (&obja); + + if (SLang_Error) + return -1; + } + + return (*cl->cl_pop) (intrinsic_type, intrinsic_addr); +} + +int _SLang_deref_assign (SLang_Ref_Type *ref) +{ + SLang_Object_Type *objp; + SLang_Name_Type *nt; + SLBlock_Type blk; + + if (ref->is_global == 0) + { + objp = ref->v.local_obj; + if (objp > Local_Variable_Frame) + { + SLang_verror (SL_UNDEFINED_NAME, "Local variable reference is out of scope"); + return -1; + } + return set_lvalue_obj (_SLANG_BCST_ASSIGN, objp); + } + + nt = ref->v.nt; + switch (nt->name_type) + { + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + if (-1 == set_lvalue_obj (_SLANG_BCST_ASSIGN, + &((SLang_Global_Var_Type *)nt)->obj)) + { + do_name_type_error (nt); + return -1; + } + break; + + case SLANG_IVARIABLE: + blk.b.nt_blk = nt; + blk.bc_sub_type = _SLANG_BCST_ASSIGN; + if (-1 == set_intrin_lvalue (&blk)) + { + do_name_type_error (nt); + return -1; + } + break; + + case SLANG_LVARIABLE: + SLang_Error = SL_INTERNAL_ERROR; + /* set_intrin_lvalue (&blk); */ + return -1; + + case SLANG_RVARIABLE: + default: + SLang_verror (SL_READONLY_ERROR, "deref assignment to %s not allowed", nt->name); + return -1; + } + + return 0; +} + +static void set_deref_lvalue (SLBlock_Type *bc_blk) +{ + SLang_Object_Type *objp; + SLang_Ref_Type *ref; + + switch (bc_blk->bc_sub_type) + { + case SLANG_LVARIABLE: + objp = (Local_Variable_Frame - bc_blk->b.i_blk); + break; + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + objp = &bc_blk->b.nt_gvar_blk->obj; + break; + default: + SLang_Error = SL_INTERNAL_ERROR; + return; + } + + if (-1 == _SLpush_slang_obj (objp)) + return; + + if (-1 == SLang_pop_ref (&ref)) + return; + (void) _SLang_deref_assign (ref); + SLang_free_ref (ref); +} + +static int push_struct_field (char *name) +{ + int type; + SLang_Class_Type *cl; + + if (-1 == (type = SLang_peek_at_stack ())) + return -1; + + cl = _SLclass_get_class ((unsigned char) type); + if (cl->cl_sget == NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "%s does not permit structure access", + cl->cl_name); + SLdo_pop_n (2); + return -1; + } + + return (*cl->cl_sget) ((unsigned char) type, name); +} + +static void trace_dump (char *format, char *name, SLang_Object_Type *objs, int n, int dir) +{ + unsigned int len; + char prefix [52]; + + len = Trace_Mode - 1; + if (len + 2 >= sizeof (prefix)) + len = sizeof (prefix) - 2; + + SLMEMSET (prefix, ' ', len); + prefix[len] = 0; + + call_dump_routine (prefix); + call_dump_routine (format, name, n); + + if (n > 0) + { + prefix[len] = ' '; + len++; + prefix[len] = 0; + + _SLdump_objects (prefix, objs, n, dir); + } +} + +/* Pop a data item from the stack and return a pointer to it. + * Strings are not freed from stack so use another routine to do it. + */ +static VOID_STAR pop_pointer (SLang_Object_Type *obj, unsigned char type) +{ +#ifndef _SLANG_OPTIMIZE_FOR_SPEED + SLang_Class_Type *cl; +#endif + + SLang_Array_Type *at; + + /* Arrays are special. Allow scalars to automatically convert to arrays. + */ + if (type == SLANG_ARRAY_TYPE) + { + if (-1 == SLang_pop_array (&at, 1)) + return NULL; + obj->data_type = SLANG_ARRAY_TYPE; + return obj->v.ptr_val = (VOID_STAR) at; + } + + if (type == 0) + { + /* This happens when an intrinsic is declared without any information + * regarding parameter types. + */ + if (-1 == SLang_pop (obj)) + return NULL; + type = obj->data_type; + } + else if (-1 == _SLang_pop_object_of_type (type, obj, 0)) + return NULL; + +#if _SLANG_OPTIMIZE_FOR_SPEED + type = _SLclass_Class_Type [type]; +#else + type = _SLclass_get_class (type)->cl_class_type; +#endif + + if (type == SLANG_CLASS_TYPE_SCALAR) + return (VOID_STAR) &obj->v; + else if (type == SLANG_CLASS_TYPE_MMT) + return SLang_object_from_mmt (obj->v.ref); + else + return obj->v.ptr_val; +} + +/* This is ugly. Does anyone have a advice for a cleaner way of doing + * this?? + */ +typedef void (*VF0_Type)(void); +typedef void (*VF1_Type)(VOID_STAR); +typedef void (*VF2_Type)(VOID_STAR, VOID_STAR); +typedef void (*VF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR); +typedef void (*VF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef void (*VF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef void (*VF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef void (*VF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF0_Type)(void); +typedef long (*LF1_Type)(VOID_STAR); +typedef long (*LF2_Type)(VOID_STAR, VOID_STAR); +typedef long (*LF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef long (*LF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +#if SLANG_HAS_FLOAT +typedef double (*FF0_Type)(void); +typedef double (*FF1_Type)(VOID_STAR); +typedef double (*FF2_Type)(VOID_STAR, VOID_STAR); +typedef double (*FF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR); +typedef double (*FF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef double (*FF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef double (*FF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +typedef double (*FF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); +#endif + +static int execute_intrinsic_fun (SLang_Intrin_Fun_Type *objf) +{ +#if SLANG_HAS_FLOAT + double xf; +#endif + VOID_STAR p[SLANG_MAX_INTRIN_ARGS]; + SLang_Object_Type objs[SLANG_MAX_INTRIN_ARGS]; + long ret; + unsigned char type; + unsigned int argc; + unsigned int i; + FVOID_STAR fptr; + unsigned char *arg_types; + int stk_depth; + + fptr = objf->i_fun; + argc = objf->num_args; + type = objf->return_type; + arg_types = objf->arg_types; + + if (argc > SLANG_MAX_INTRIN_ARGS) + { + SLang_verror(SL_APPLICATION_ERROR, + "Intrinsic function %s requires too many parameters", objf->name); + return -1; + } + + if (-1 == _SL_increment_frame_pointer ()) + return -1; + + stk_depth = -1; + if (Trace_Mode && (_SLang_Trace > 0)) + { + int nargs; + + stk_depth = _SLstack_depth (); + + nargs = SLang_Num_Function_Args; + if (nargs == 0) + nargs = (int)argc; + + stk_depth -= nargs; + + if (stk_depth >= 0) + trace_dump (">>%s (%d args)\n", + objf->name, + _SLStack_Pointer - nargs, + nargs, + 1); + } + + i = argc; + while (i != 0) + { + i--; + if (NULL == (p[i] = pop_pointer (objs + i, arg_types[i]))) + { + i++; + goto free_and_return; + } + } + + ret = 0; +#if SLANG_HAS_FLOAT + xf = 0.0; +#endif + + switch (argc) + { + case 0: + if (type == SLANG_VOID_TYPE) ((VF0_Type) fptr) (); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF0_Type) fptr)(); +#endif + else ret = ((LF0_Type) fptr)(); + break; + + case 1: + if (type == SLANG_VOID_TYPE) ((VF1_Type) fptr)(p[0]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF1_Type) fptr)(p[0]); +#endif + else ret = ((LF1_Type) fptr)(p[0]); + break; + + case 2: + if (type == SLANG_VOID_TYPE) ((VF2_Type) fptr)(p[0], p[1]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF2_Type) fptr)(p[0], p[1]); +#endif + else ret = ((LF2_Type) fptr)(p[0], p[1]); + break; + + case 3: + if (type == SLANG_VOID_TYPE) ((VF3_Type) fptr)(p[0], p[1], p[2]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF3_Type) fptr)(p[0], p[1], p[2]); +#endif + else ret = ((LF3_Type) fptr)(p[0], p[1], p[2]); + break; + + case 4: + if (type == SLANG_VOID_TYPE) ((VF4_Type) fptr)(p[0], p[1], p[2], p[3]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF4_Type) fptr)(p[0], p[1], p[2], p[3]); +#endif + else ret = ((LF4_Type) fptr)(p[0], p[1], p[2], p[3]); + break; + + case 5: + if (type == SLANG_VOID_TYPE) ((VF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]); +#endif + else ret = ((LF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]); + break; + + case 6: + if (type == SLANG_VOID_TYPE) ((VF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]); +#endif + else ret = ((LF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]); + break; + + case 7: + if (type == SLANG_VOID_TYPE) ((VF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]); +#if SLANG_HAS_FLOAT + else if (type == SLANG_DOUBLE_TYPE) xf = ((FF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]); +#endif + else ret = ((LF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]); + break; + } + + switch (type) + { + case SLANG_VOID_TYPE: + break; + +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + (void) SLang_push_double (xf); + break; +#endif + case SLANG_UINT_TYPE: + case SLANG_INT_TYPE: (void) SLclass_push_int_obj (type, (int) ret); + break; + + case SLANG_CHAR_TYPE: + case SLANG_UCHAR_TYPE: (void) SLclass_push_char_obj (type, (char) ret); + break; + + case SLANG_SHORT_TYPE: + case SLANG_USHORT_TYPE: (void) SLclass_push_short_obj (type, (short) ret); + break; + + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: (void) SLclass_push_long_obj (type, ret); + break; + + case SLANG_STRING_TYPE: + if (NULL == (char *)ret) + { + if (SLang_Error == 0) SLang_Error = SL_INTRINSIC_ERROR; + } + else (void) SLang_push_string ((char *)ret); + break; + + default: + SLang_verror (SL_NOT_IMPLEMENTED, + "Support for intrinsic functions returning %s is not provided", + SLclass_get_datatype_name (type)); + } + + if (stk_depth >= 0) + { + stk_depth = _SLstack_depth () - stk_depth; + + trace_dump ("<<%s (returning %d values)\n", + objf->name, + _SLStack_Pointer - stk_depth, + stk_depth, + 1); + } + + free_and_return: + while (i < argc) + { + SLang_free_object (objs + i); + i++; + } + + return _SL_decrement_frame_pointer (); +} + +static int inner_interp(register SLBlock_Type *); + +/* Switch_Obj_Ptr points to the NEXT available free switch object */ +static SLang_Object_Type Switch_Objects[SLANG_MAX_NESTED_SWITCH]; +static SLang_Object_Type *Switch_Obj_Ptr = Switch_Objects; +static SLang_Object_Type *Switch_Obj_Max = Switch_Objects + SLANG_MAX_NESTED_SWITCH; + +static void +lang_do_loops (unsigned char stype, SLBlock_Type *block, unsigned int num_blocks) +{ + int i, ctrl; + int first, last; + SLBlock_Type *blks[4]; + char *loop_name; + SLang_Foreach_Context_Type *foreach_context; + SLang_Class_Type *cl; + int type; + unsigned int j; + + j = 0; + for (i = 0; i < (int) num_blocks; i++) + { + if (block[i].bc_main_type != _SLANG_BC_BLOCK) + { + if (block[i].bc_main_type == _SLANG_BC_LINE_NUM) + continue; + + SLang_verror (SL_SYNTAX_ERROR, "Bytecode is not a looping block"); + return; + } + blks[j] = block[i].b.blk; + j++; + } + + num_blocks = j; + block = blks[0]; + + switch (stype) + { + case _SLANG_BCST_FOREACH: + loop_name = "foreach"; + if (num_blocks != 1) + goto wrong_num_blocks_error; + + /* We should find Next_Function_Num_Args + 1 items on the stack. + * The first Next_Function_Num_Args items represent the arguments to + * to USING. The last item (deepest in stack) is the object to loop + * over. So, roll the stack up and grab it. + */ + if ((-1 == SLroll_stack (-(Next_Function_Num_Args + 1))) + || (-1 == (type = SLang_peek_at_stack ()))) + goto return_error; + + cl = _SLclass_get_class ((unsigned char) type); + if ((cl->cl_foreach == NULL) + || (cl->cl_foreach_open == NULL) + || (cl->cl_foreach_close == NULL)) + { + SLang_verror (SL_NOT_IMPLEMENTED, "%s does not permit foreach", cl->cl_name); + SLdo_pop_n (Next_Function_Num_Args + 1); + goto return_error; + } + + if (NULL == (foreach_context = (*cl->cl_foreach_open) ((unsigned char)type, Next_Function_Num_Args))) + goto return_error; + + while (1) + { + int status; + + if (SLang_Error) + { + (*cl->cl_foreach_close) ((unsigned char) type, foreach_context); + goto return_error; + } + + status = (*cl->cl_foreach) ((unsigned char) type, foreach_context); + if (status <= 0) + { + if (status == 0) + break; + + (*cl->cl_foreach_close) ((unsigned char) type, foreach_context); + goto return_error; + } + + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + (*cl->cl_foreach_close) ((unsigned char) type, foreach_context); + break; + + case _SLANG_BCST_WHILE: + loop_name = "while"; + + if (num_blocks != 2) + goto wrong_num_blocks_error; + + type = blks[1]->bc_main_type; + while (1) + { + if (SLang_Error) + goto return_error; + + inner_interp (block); + if (Lang_Break) break; + + if (-1 == pop_ctrl_integer (&ctrl)) + goto return_error; + + if (ctrl == 0) break; + + if (type) + { + inner_interp (blks[1]); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + } + break; + + case _SLANG_BCST_DOWHILE: + loop_name = "do...while"; + + if (num_blocks != 2) + goto wrong_num_blocks_error; + + while (1) + { + if (SLang_Error) + goto return_error; + + Lang_Break_Condition = /* Lang_Continue = */ 0; + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + inner_interp (blks[1]); + if (-1 == pop_ctrl_integer (&ctrl)) + goto return_error; + + if (ctrl == 0) break; + } + break; + + case _SLANG_BCST_CFOR: + loop_name = "for"; + + /* we need 4 blocks: first 3 control, the last is code */ + if (num_blocks != 4) goto wrong_num_blocks_error; + + inner_interp (block); + while (1) + { + if (SLang_Error) + goto return_error; + + inner_interp(blks[1]); /* test */ + if (-1 == pop_ctrl_integer (&ctrl)) + goto return_error; + + if (ctrl == 0) break; + inner_interp(blks[3]); /* code */ + if (Lang_Break) break; + inner_interp(blks[2]); /* bump */ + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + break; + + case _SLANG_BCST_FOR: + loop_name = "_for"; + + if (num_blocks != 1) + goto wrong_num_blocks_error; + + /* 3 elements: first, last, step */ + if ((-1 == SLang_pop_integer (&ctrl)) + || (-1 == SLang_pop_integer (&last)) + || (-1 == SLang_pop_integer (&first))) + goto return_error; + + i = first; + while (1) + { + /* It is ugly to have this test here but I do not know of a + * simple way to do this without using two while loops. + */ + if (ctrl >= 0) + { + if (i > last) break; + } + else if (i < last) break; + + if (SLang_Error) goto return_error; + + SLclass_push_int_obj (SLANG_INT_TYPE, i); + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + + i += ctrl; + } + break; + + case _SLANG_BCST_LOOP: + loop_name = "loop"; + if (num_blocks != 1) + goto wrong_num_blocks_error; + + if (-1 == SLang_pop_integer (&ctrl)) + goto return_error; + while (ctrl > 0) + { + ctrl--; + + if (SLang_Error) + goto return_error; + + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + break; + + case _SLANG_BCST_FOREVER: + loop_name = "forever"; + + if (num_blocks != 1) + goto wrong_num_blocks_error; + + while (1) + { + if (SLang_Error) + goto return_error; + + inner_interp (block); + if (Lang_Break) break; + Lang_Break_Condition = /* Lang_Continue = */ 0; + } + break; + + default: SLang_verror(SL_INTERNAL_ERROR, "Unknown loop type"); + return; + } + Lang_Break = /* Lang_Continue = */ 0; + Lang_Break_Condition = Lang_Return; + return; + + wrong_num_blocks_error: + SLang_verror (SL_SYNTAX_ERROR, "Wrong number of blocks for '%s' construct", loop_name); + + /* drop */ + return_error: + do_traceback (loop_name, 0, NULL); +} + +static void lang_do_and_orelse (unsigned char stype, SLBlock_Type *addr, SLBlock_Type *addr_max) +{ + int test = 0; + int is_or; + + is_or = (stype == _SLANG_BCST_ORELSE); + + while (addr <= addr_max) + { + if (addr->bc_main_type == _SLANG_BC_LINE_NUM) + { + addr++; + continue; + } + + inner_interp (addr->b.blk); + if (SLang_Error + || Lang_Break_Condition + || (-1 == pop_ctrl_integer (&test))) + return; + + if (is_or == (test != 0)) + break; + + /* if (((stype == _SLANG_BCST_ANDELSE) && (test == 0)) + * || ((stype == _SLANG_BCST_ORELSE) && test)) + * break; + */ + + addr++; + } + SLclass_push_int_obj (SLANG_INT_TYPE, test); +} + +static void do_else_if (SLBlock_Type *zero_block, SLBlock_Type *non_zero_block) +{ + int test; + + if (-1 == pop_ctrl_integer (&test)) + return; + + if (test == 0) + non_zero_block = zero_block; + + if (non_zero_block != NULL) + inner_interp (non_zero_block->b.blk); +} + +int _SLang_trace_fun (char *f) +{ + if (NULL == (f = SLang_create_slstring (f))) + return -1; + + SLang_free_slstring (Trace_Function); + Trace_Function = f; + _SLang_Trace = 1; + return 0; +} + +int _SLdump_objects (char *prefix, SLang_Object_Type *x, unsigned int n, int dir) +{ + char *s; + SLang_Class_Type *cl; + + while (n) + { + cl = _SLclass_get_class (x->data_type); + + if (NULL == (s = _SLstringize_object (x))) + s = "??"; + + call_dump_routine ("%s[%s]:%s\n", prefix, cl->cl_name, s); + + SLang_free_slstring (s); + + x += dir; + n--; + } + return 0; +} + +static SLBlock_Type *Exit_Block_Ptr; +static SLBlock_Type *Global_User_Block[5]; +static SLBlock_Type **User_Block_Ptr = Global_User_Block; +char *_SLang_Current_Function_Name = NULL; + +static int execute_slang_fun (_SLang_Function_Type *fun) +{ + register unsigned int i; + register SLang_Object_Type *frame, *lvf; + register unsigned int n_locals; + _SLBlock_Header_Type *header; + /* SLBlock_Type *val; */ + SLBlock_Type *exit_block_save; + SLBlock_Type **user_block_save; + SLBlock_Type *user_blocks[5]; + char *save_fname; + + exit_block_save = Exit_Block_Ptr; + user_block_save = User_Block_Ptr; + User_Block_Ptr = user_blocks; + *(user_blocks) = NULL; + *(user_blocks + 1) = NULL; + *(user_blocks + 2) = NULL; + *(user_blocks + 3) = NULL; + *(user_blocks + 4) = NULL; + + Exit_Block_Ptr = NULL; + + save_fname = _SLang_Current_Function_Name; + _SLang_Current_Function_Name = fun->name; + + _SL_increment_frame_pointer (); + + /* need loaded? */ + if (fun->nlocals == AUTOLOAD_NUM_LOCALS) + { + header = NULL; + if (-1 == SLang_load_file(fun->v.autoload_filename)) + goto the_return; + + if (fun->nlocals == AUTOLOAD_NUM_LOCALS) + { + SLang_verror (SL_UNDEFINED_NAME, "%s: Function did not autoload", + _SLang_Current_Function_Name); + goto the_return; + } + } + + n_locals = fun->nlocals; + + /* let the error propagate through since it will do no harm + and allow us to restore stack. */ + + /* set new stack frame */ + lvf = frame = Local_Variable_Frame; + i = n_locals; + if ((lvf + i) > Local_Variable_Stack + SLANG_MAX_LOCAL_STACK) + { + SLang_verror(SL_STACK_OVERFLOW, "%s: Local Variable Stack Overflow", + _SLang_Current_Function_Name); + goto the_return; + } + + /* Make sure we do not allow this header to get destroyed by something + * like: define crash () { eval ("define crash ();") } + */ + header = fun->v.header; + header->num_refs++; + + while (i--) + { + lvf++; + lvf->data_type = SLANG_UNDEFINED_TYPE; + } + Local_Variable_Frame = lvf; + + /* read values of function arguments */ + i = fun->nargs; + while (i > 0) + { + i--; + (void) SLang_pop (Local_Variable_Frame - i); + } + + if (SLang_Enter_Function != NULL) (*SLang_Enter_Function)(_SLang_Current_Function_Name); + + if (_SLang_Trace) + { + int stack_depth; + + stack_depth = _SLstack_depth (); + + if ((Trace_Function != NULL) + && (0 == strcmp (Trace_Function, _SLang_Current_Function_Name)) + && (Trace_Mode == 0)) + Trace_Mode = 1; + + if (Trace_Mode) + { + /* The local variable frame grows backwards */ + trace_dump (">>%s (%d args)\n", + _SLang_Current_Function_Name, + Local_Variable_Frame, + (int) fun->nargs, + -1); + Trace_Mode++; + } + + inner_interp (header->body); + Lang_Break_Condition = Lang_Return = Lang_Break = 0; + if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr); + + if (Trace_Mode) + { + Trace_Mode--; + stack_depth = _SLstack_depth () - stack_depth; + + trace_dump ("<<%s (returning %d values)\n", + _SLang_Current_Function_Name, + _SLStack_Pointer - stack_depth, + stack_depth, + 1); + + if (Trace_Mode == 1) + Trace_Mode = 0; + } + } + else + { + inner_interp (header->body); + Lang_Break_Condition = Lang_Return = Lang_Break = 0; + if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr); + } + + if (SLang_Exit_Function != NULL) (*SLang_Exit_Function)(_SLang_Current_Function_Name); + + if (SLang_Error) + do_traceback(fun->name, n_locals, +#if _SLANG_HAS_DEBUG_CODE + fun->file +#else + NULL +#endif + ); + + /* free local variables.... */ + lvf = Local_Variable_Frame; + while (lvf > frame) + { +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [lvf->data_type]) +#endif + SLang_free_object (lvf); + lvf--; + } + Local_Variable_Frame = lvf; + + if (header->num_refs == 1) + free_function_header (header); + else + header->num_refs--; + + the_return: + + Lang_Break_Condition = Lang_Return = Lang_Break = 0; + Exit_Block_Ptr = exit_block_save; + User_Block_Ptr = user_block_save; + _SLang_Current_Function_Name = save_fname; + _SL_decrement_frame_pointer (); + + if (SLang_Error) + return -1; + + return 0; +} + +static void do_traceback (char *name, unsigned int locals, char *file) +{ + char *s; + unsigned int i; + SLang_Object_Type *objp; + unsigned short stype; + + /* FIXME: Priority=low + * I need to make this configurable!!! That is, let the + * application decide whether or not a usage error should result in a + * traceback. + */ + if (SLang_Error == SL_USAGE_ERROR) + return; + + if (SLang_Traceback == 0) + return; + + call_dump_routine ("S-Lang Traceback: %s\n", name); + if (SLang_Traceback < 0) + return; + + if (file != NULL) + call_dump_routine ("File: %s\n", file); + + if (locals == 0) + return; + + call_dump_routine (" Local Variables:\n"); + + for (i = 0; i < locals; i++) + { + SLang_Class_Type *cl; + char *class_name; + + objp = Local_Variable_Frame - i; + stype = objp->data_type; + + s = _SLstringize_object (objp); + cl = _SLclass_get_class (stype); + class_name = cl->cl_name; + + call_dump_routine ("\t$%d: Type: %s,\tValue:\t", i, class_name); + + if (s == NULL) call_dump_routine("??\n"); + else + { + char *q = ""; +#ifndef HAVE_VSNPRINTF + char buf[256]; + if (strlen (s) >= sizeof (buf)) + { + strncpy (buf, s, sizeof(buf)); + s = buf; + s[sizeof(buf) - 1] = 0; + } +#endif + if (SLANG_STRING_TYPE == stype) q = "\""; + call_dump_routine ("%s%s%s\n", q, s, q); + } + } +} + +static void do_app_unary (SLang_App_Unary_Type *nt) +{ + if (-1 == do_unary (nt->unary_op, nt->name_type)) + do_traceback (nt->name, 0, NULL); +} + +static int inner_interp_nametype (SLang_Name_Type *nt) +{ + SLBlock_Type bc_blks[2]; + + bc_blks[0].b.nt_blk = nt; + bc_blks[0].bc_main_type = nt->name_type; + bc_blks[1].bc_main_type = 0; + return inner_interp(bc_blks); +} + +int _SLang_dereference_ref (SLang_Ref_Type *ref) +{ + if (ref == NULL) + { + SLang_Error = SL_INTERNAL_ERROR; + return -1; + } + + if (ref->is_global == 0) + { + SLang_Object_Type *obj = ref->v.local_obj; + if (obj > Local_Variable_Frame) + { + SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope"); + return -1; + } + return _SLpush_slang_obj (ref->v.local_obj); + } + + (void) inner_interp_nametype (ref->v.nt); + return 0; +} + +int _SLang_is_ref_initialized (SLang_Ref_Type *ref) +{ + unsigned char type; + + if (ref == NULL) + { + SLang_Error = SL_INTERNAL_ERROR; + return -1; + } + + if (ref->is_global == 0) + { + SLang_Object_Type *obj = ref->v.local_obj; + if (obj > Local_Variable_Frame) + { + SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope"); + return -1; + } + type = ref->v.local_obj->data_type; + } + else + { + SLang_Name_Type *nt = ref->v.nt; + if ((nt->name_type != SLANG_GVARIABLE) + && (nt->name_type != SLANG_PVARIABLE)) + return 1; + type = ((SLang_Global_Var_Type *)nt)->obj.data_type; + } + return type != SLANG_UNDEFINED_TYPE; +} + +int _SLang_uninitialize_ref (SLang_Ref_Type *ref) +{ + SLang_Object_Type *obj; + + if (ref == NULL) + { + SLang_Error = SL_INTERNAL_ERROR; + return -1; + } + + if (ref->is_global == 0) + { + obj = ref->v.local_obj; + if (obj > Local_Variable_Frame) + { + SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope"); + return -1; + } + obj = ref->v.local_obj; + } + else + { + SLang_Name_Type *nt = ref->v.nt; + if ((nt->name_type != SLANG_GVARIABLE) + && (nt->name_type != SLANG_PVARIABLE)) + return -1; + obj = &((SLang_Global_Var_Type *)nt)->obj; + } + SLang_free_object (obj); + obj->data_type = SLANG_UNDEFINED_TYPE; + obj->v.ptr_val = NULL; + return 0; +} + +void (*SLang_Interrupt)(void); +static int Last_Error; +void (*SLang_User_Clear_Error)(void); +void _SLang_clear_error (void) +{ + if (Last_Error <= 0) + { + Last_Error = 0; + return; + } + Last_Error--; + if (SLang_User_Clear_Error != NULL) (*SLang_User_Clear_Error)(); +} + +int _SLpush_slang_obj (SLang_Object_Type *obj) +{ + unsigned char subtype; + SLang_Class_Type *cl; + + if (obj == NULL) return SLang_push_null (); + + subtype = obj->data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type[subtype]) + return SLang_push (obj); +#endif + + cl = _SLclass_get_class (subtype); + return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v); +} + +_INLINE_ +static int push_local_variable (int i) +{ + SLang_Class_Type *cl; + SLang_Object_Type *obj; + unsigned char subtype; + + obj = Local_Variable_Frame - i; + subtype = obj->data_type; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type[subtype]) + return SLang_push (obj); + if (subtype == SLANG_STRING_TYPE) + return _SLang_dup_and_push_slstring (obj->v.s_val); +#endif + + cl = _SLclass_get_class (subtype); + return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v); +} + +static int push_intrinsic_variable (SLang_Intrin_Var_Type *ivar) +{ + SLang_Class_Type *cl; + unsigned char stype; + + stype = ivar->type; + cl = _SLclass_get_class (stype); + + if (-1 == (*cl->cl_push_intrinsic) (stype, ivar->addr)) + { + do_name_type_error ((SLang_Name_Type *) ivar); + return -1; + } + return 0; +} + +static int dereference_object (void) +{ + SLang_Object_Type obj; + SLang_Class_Type *cl; + unsigned char type; + int ret; + + if (-1 == SLang_pop (&obj)) + return -1; + + type = obj.data_type; + + cl = _SLclass_get_class (type); + ret = (*cl->cl_dereference)(type, (VOID_STAR) &obj.v); + + SLang_free_object (&obj); + return ret; +} + +static int case_function (void) +{ + unsigned char type; + SLang_Object_Type obj; + SLang_Object_Type *swobjptr; + + swobjptr = Switch_Obj_Ptr - 1; + + if ((swobjptr < Switch_Objects) + || (0 == (type = swobjptr->data_type))) + { + SLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case' keyword"); + return -1; + } + + if (-1 == SLang_pop (&obj)) + return -1; + + if (obj.data_type != type) + { + SLang_Class_Type *a_cl, *b_cl; + + a_cl = _SLclass_get_class (obj.data_type); + b_cl = _SLclass_get_class (type); + + if (NULL == _SLclass_get_binary_fun (SLANG_EQ, a_cl, b_cl, &a_cl, 0)) + { + (void) SLclass_push_int_obj (SLANG_INT_TYPE, 0); + SLang_free_object (&obj); + return 0; + } + } + + (void) do_binary_ab (SLANG_EQ, swobjptr, &obj); + SLang_free_object (&obj); + return 0; +} + +static void tmp_variable_function (SLBlock_Type *addr) +{ + SLang_Object_Type *obj; + + switch (addr->bc_sub_type) + { + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + obj = &addr->b.nt_gvar_blk->obj; + break; + + case SLANG_LVARIABLE: + obj = Local_Variable_Frame - addr->b.i_blk; + break; + + default: + SLang_Error = SL_INTERNAL_ERROR; + return; + } + + /* There is no need to go through higher level routines since we are + * not creating or destroying extra copies. + */ + if (-1 == SLang_push (obj)) + return; + + obj->data_type = SLANG_UNDEFINED_TYPE; + obj->v.ptr_val = NULL; +} + + +static int +do_inner_interp_error (SLBlock_Type *err_block, + SLBlock_Type *addr_start, + SLBlock_Type *addr) +{ + int save_err, slerr; + + /* Someday I can use the these variable to provide extra information + * about what went wrong. + */ + (void) addr_start; + (void) addr; + + if (err_block == NULL) + goto return_error; + + if (SLang_Error < 0) /* errors less than 0 are severe */ + goto return_error; + + save_err = Last_Error++; + slerr = SLang_Error; + SLang_Error = 0; + inner_interp (err_block->b.blk); + + if (Last_Error <= save_err) + { + /* Caught error and cleared it */ + Last_Error = save_err; + if ((Lang_Break_Condition == 0) + /* An error may have cleared the error and then caused the + * function to return. We will allow that but let's not allow + * 'break' nor 'continue' statements until later. + */ + || Lang_Return) + return 0; + + /* drop--- either a break or continue was called */ + } + + Last_Error = save_err; + SLang_Error = slerr; + + return_error: +#if _SLANG_HAS_DEBUG_CODE + while (addr >= addr_start) + { + if (addr->bc_main_type == _SLANG_BC_LINE_NUM) + { + char buf[256]; + sprintf (buf, "(Error occurred on line %lu)", addr->b.l_blk); + do_traceback (buf, 0, NULL); + break; + } + /* Special hack for 16 bit systems to prevent pointer wrapping. */ +#if defined(__16_BIT_SYSTEM__) + if (addr == addr_start) + break; +#endif + addr--; + } +#endif + return -1; +} + + +#define GATHER_STATISTICS 0 +#if GATHER_STATISTICS +static unsigned int Bytecodes[0xFFFF]; + +static void print_stats (void) +{ + unsigned int i; + unsigned long total; + FILE *fp = fopen ("stats.txt", "w"); + if (fp == NULL) + return; + + total = 0; + for (i = 0; i < 0xFFFF; i++) + total += Bytecodes[i]; + + if (total == 0) + total = 1; + + for (i = 0; i < 0xFFFF; i++) + { + if (Bytecodes[i]) + fprintf (fp, "0x%04X %9u %e\n", i, Bytecodes[i], Bytecodes[i]/(double) total); + } + fclose (fp); +} + +static void add_to_statistics (SLBlock_Type *b) +{ + unsigned short x, y; + + x = b->bc_main_type; + if (x == 0) + { + Bytecodes[0] += 1; + return; + } + b++; + y = b->bc_main_type; + + Bytecodes[(x << 8) | y] += 1; +} + +#endif + +/* inner interpreter */ +/* The return value from this function is only meaningful when it is used + * to process blocks for the switch statement. If it returns 0, the calling + * routine should pass the next block to it. Otherwise it will + * return non-zero, with or without error. + */ +static int inner_interp (SLBlock_Type *addr_start) +{ + SLBlock_Type *block, *err_block, *addr; +#if GATHER_STATISTICS + static int inited = 0; + + if (inited == 0) + { + (void) SLang_add_cleanup_function (print_stats); + inited = 1; + } +#endif + + /* for systems that have no real interrupt facility (e.g. go32 on dos) */ + if (SLang_Interrupt != NULL) (*SLang_Interrupt)(); + + block = err_block = NULL; + addr = addr_start; + +#if GATHER_STATISTICS + add_to_statistics (addr); +#endif + while (1) + { + switch (addr->bc_main_type) + { + case 0: + return 1; + case _SLANG_BC_LVARIABLE: + push_local_variable (addr->b.i_blk); + break; + case _SLANG_BC_GVARIABLE: + if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj)) + do_name_type_error (addr->b.nt_blk); + break; + + case _SLANG_BC_IVARIABLE: + case _SLANG_BC_RVARIABLE: + push_intrinsic_variable (addr->b.nt_ivar_blk); + break; + + case _SLANG_BC_INTRINSIC: + execute_intrinsic_fun (addr->b.nt_ifun_blk); + if (SLang_Error) + do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); + break; + + case _SLANG_BC_FUNCTION: + execute_slang_fun (addr->b.nt_fun_blk); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_MATH_UNARY: + case _SLANG_BC_APP_UNARY: + /* Make sure we treat these like function calls since the + * parser took sin(x) to be a function call. + */ + if (0 == _SL_increment_frame_pointer ()) + { + do_app_unary (addr->b.nt_unary_blk); + (void) _SL_decrement_frame_pointer (); + } + break; + + case _SLANG_BC_ICONST: + SLclass_push_int_obj (SLANG_INT_TYPE, addr->b.iconst_blk->i); + break; + +#if SLANG_HAS_FLOAT + case _SLANG_BC_DCONST: + SLang_push_double (addr->b.dconst_blk->d); + break; +#endif + + case _SLANG_BC_PVARIABLE: + if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj)) + do_name_type_error (addr->b.nt_blk); + break; + + case _SLANG_BC_PFUNCTION: + execute_slang_fun (addr->b.nt_fun_blk); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_BINARY: + do_binary (addr->b.i_blk); + break; + + case _SLANG_BC_LITERAL: +#if !_SLANG_OPTIMIZE_FOR_SPEED + case _SLANG_BC_LITERAL_INT: + case _SLANG_BC_LITERAL_STR: +#endif + { + SLang_Class_Type *cl = _SLclass_get_class (addr->bc_sub_type); + (*cl->cl_push_literal) (addr->bc_sub_type, (VOID_STAR) &addr->b.ptr_blk); + } + break; +#if _SLANG_OPTIMIZE_FOR_SPEED + case _SLANG_BC_LITERAL_INT: + SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk); + break; + + case _SLANG_BC_LITERAL_STR: + _SLang_dup_and_push_slstring (addr->b.s_blk); + break; +#endif + case _SLANG_BC_BLOCK: + switch (addr->bc_sub_type) + { + case _SLANG_BCST_ERROR_BLOCK: + err_block = addr; + break; + + case _SLANG_BCST_EXIT_BLOCK: + Exit_Block_Ptr = addr->b.blk; + break; + + case _SLANG_BCST_USER_BLOCK0: + case _SLANG_BCST_USER_BLOCK1: + case _SLANG_BCST_USER_BLOCK2: + case _SLANG_BCST_USER_BLOCK3: + case _SLANG_BCST_USER_BLOCK4: + User_Block_Ptr[addr->bc_sub_type - _SLANG_BCST_USER_BLOCK0] = addr->b.blk; + break; + + case _SLANG_BCST_LOOP: + case _SLANG_BCST_WHILE: + case _SLANG_BCST_FOR: + case _SLANG_BCST_FOREVER: + case _SLANG_BCST_CFOR: + case _SLANG_BCST_DOWHILE: + case _SLANG_BCST_FOREACH: + if (block == NULL) block = addr; + lang_do_loops(addr->bc_sub_type, block, 1 + (unsigned int) (addr - block)); + block = NULL; + break; + + case _SLANG_BCST_IFNOT: +#if _SLANG_OPTIMIZE_FOR_SPEED + { + int i; + + if ((0 == pop_ctrl_integer (&i)) && (i == 0)) + inner_interp (addr->b.blk); + } +#else + do_else_if (addr, NULL); +#endif + break; + + case _SLANG_BCST_IF: +#if _SLANG_OPTIMIZE_FOR_SPEED + { + int i; + + if ((0 == pop_ctrl_integer (&i)) && i) + inner_interp (addr->b.blk); + } +#else + do_else_if (NULL, addr); +#endif + break; + + case _SLANG_BCST_NOTELSE: + do_else_if (block, addr); + block = NULL; + break; + + case _SLANG_BCST_ELSE: + do_else_if (addr, block); + block = NULL; + break; + + case _SLANG_BCST_SWITCH: + if (Switch_Obj_Ptr == Switch_Obj_Max) + { + SLang_doerror("switch nesting too deep"); + break; + } + (void) SLang_pop (Switch_Obj_Ptr); + Switch_Obj_Ptr++; + + if (block == NULL) block = addr; + while ((SLang_Error == 0) + && (block <= addr) + && (Lang_Break_Condition == 0) + && (0 == inner_interp (block->b.blk))) + block++; + Switch_Obj_Ptr--; + SLang_free_object (Switch_Obj_Ptr); + Switch_Obj_Ptr->data_type = 0; + block = NULL; + break; + + case _SLANG_BCST_ANDELSE: + case _SLANG_BCST_ORELSE: + if (block == NULL) block = addr; + lang_do_and_orelse (addr->bc_sub_type, block, addr); + block = NULL; + break; + + default: + if (block == NULL) block = addr; + break; + } + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_RETURN: + Lang_Break_Condition = Lang_Return = Lang_Break = 1; return 1; + case _SLANG_BC_BREAK: + Lang_Break_Condition = Lang_Break = 1; return 1; + case _SLANG_BC_CONTINUE: + Lang_Break_Condition = /* Lang_Continue = */ 1; return 1; + + case _SLANG_BC_EXCH: + (void) SLreverse_stack (2); + break; + + case _SLANG_BC_LABEL: + { + int test; + if ((0 == SLang_pop_integer (&test)) + && (test == 0)) + return 0; + } + break; + + case _SLANG_BC_LOBJPTR: + (void)_SLang_push_ref (0, (VOID_STAR)(Local_Variable_Frame - addr->b.i_blk)); + break; + + case _SLANG_BC_GOBJPTR: + (void)_SLang_push_ref (1, (VOID_STAR)addr->b.nt_blk); + break; + + case _SLANG_BC_X_ERROR: + if (err_block != NULL) + { + inner_interp(err_block->b.blk); + if (SLang_Error) err_block = NULL; + } + else SLang_verror(SL_SYNTAX_ERROR, "No ERROR_BLOCK"); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_X_USER0: + case _SLANG_BC_X_USER1: + case _SLANG_BC_X_USER2: + case _SLANG_BC_X_USER3: + case _SLANG_BC_X_USER4: + if (User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0] != NULL) + { + inner_interp(User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0]); + } + else SLang_verror(SL_SYNTAX_ERROR, "No block for X_USERBLOCK"); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_CALL_DIRECT: + (*addr->b.call_function) (); + break; + + case _SLANG_BC_CALL_DIRECT_FRAME: + do_bc_call_direct_frame (addr->b.call_function); + break; + + case _SLANG_BC_UNARY: + do_unary (addr->b.i_blk, _SLANG_BC_UNARY); + break; + + case _SLANG_BC_UNARY_FUNC: + /* Make sure we treat these like function calls since the + * parser took abs(x) to be a function call. + */ + if (0 == _SL_increment_frame_pointer ()) + { + do_unary (addr->b.i_blk, _SLANG_BC_UNARY); + (void) _SL_decrement_frame_pointer (); + } + break; + + case _SLANG_BC_DEREF_ASSIGN: + set_deref_lvalue (addr); + break; + case _SLANG_BC_SET_LOCAL_LVALUE: + set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk); + break; + case _SLANG_BC_SET_GLOBAL_LVALUE: + if (-1 == set_lvalue_obj (addr->bc_sub_type, &addr->b.nt_gvar_blk->obj)) + do_name_type_error (addr->b.nt_blk); + break; + case _SLANG_BC_SET_INTRIN_LVALUE: + set_intrin_lvalue (addr); + break; + case _SLANG_BC_SET_STRUCT_LVALUE: + set_struct_lvalue (addr); + break; + + case _SLANG_BC_FIELD: + (void) push_struct_field (addr->b.s_blk); + break; + + case _SLANG_BC_SET_ARRAY_LVALUE: + set_array_lvalue (addr->bc_sub_type); + break; + +#if _SLANG_HAS_DEBUG_CODE + case _SLANG_BC_LINE_NUM: + break; +#endif + + case _SLANG_BC_TMP: + tmp_variable_function (addr); + break; + +#if _SLANG_OPTIMIZE_FOR_SPEED + case _SLANG_BC_LVARIABLE_AGET: + if (0 == push_local_variable (addr->b.i_blk)) + do_bc_call_direct_frame (_SLarray_aget); + break; + + case _SLANG_BC_LVARIABLE_APUT: + if (0 == push_local_variable (addr->b.i_blk)) + do_bc_call_direct_frame (_SLarray_aput); + break; + case _SLANG_BC_INTEGER_PLUS: + if (0 == SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk)) + do_binary (SLANG_PLUS); + break; + + case _SLANG_BC_INTEGER_MINUS: + if (0 == SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk)) + do_binary (SLANG_MINUS); + break; +#endif +#if 0 + case _SLANG_BC_ARG_LVARIABLE: + (void) SLang_start_arg_list (); + push_local_variable (addr->b.i_blk); + break; +#endif + case _SLANG_BC_EARG_LVARIABLE: + push_local_variable (addr->b.i_blk); + (void) SLang_end_arg_list (); + break; + +#if USE_COMBINED_BYTECODES + case _SLANG_BC_CALL_DIRECT_INTRINSIC: + (*addr->b.call_function) (); + addr++; + execute_intrinsic_fun (addr->b.nt_ifun_blk); + if (SLang_Error) + do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); + break; + + case _SLANG_BC_INTRINSIC_CALL_DIRECT: + execute_intrinsic_fun (addr->b.nt_ifun_blk); + if (SLang_Error) + { + do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); + break; + } + addr++; + (*addr->b.call_function) (); + break; + + case _SLANG_BC_CALL_DIRECT_LSTR: + (*addr->b.call_function) (); + addr++; + _SLang_dup_and_push_slstring (addr->b.s_blk); + break; + + case _SLANG_BC_CALL_DIRECT_SLFUN: + (*addr->b.call_function) (); + addr++; + execute_slang_fun (addr->b.nt_fun_blk); + if (Lang_Break_Condition) goto handle_break_condition; + break; + + case _SLANG_BC_CALL_DIRECT_INTRSTOP: + (*addr->b.call_function) (); + addr++; + /* drop */ + case _SLANG_BC_INTRINSIC_STOP: + execute_intrinsic_fun (addr->b.nt_ifun_blk); + if (SLang_Error == 0) + return 1; + do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); + break; + + case _SLANG_BC_CALL_DIRECT_EARG_LVAR: + (*addr->b.call_function) (); + addr++; + push_local_variable (addr->b.i_blk); + (void) SLang_end_arg_list (); + break; + + case _SLANG_BC_CALL_DIRECT_LINT: + (*addr->b.call_function) (); + addr++; + SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk); + break; + + case _SLANG_BC_CALL_DIRECT_LVAR: + (*addr->b.call_function) (); + addr++; + push_local_variable (addr->b.i_blk); + break; +#endif /* USE_COMBINED_BYTECODES */ + + default: + SLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type); + } + + /* Someday I plan to add a 'signal' intrinsic function. Then when a + * signal is caught, a variable will be set to one and that value of + * that variable will need to be monitored here, e.g., + * if (Handle_Signal) handle_signal (); + * It would be nice to check only one variable instead of Handle_Signal + * and SLang_Error. Perhaps I should phase out SLang_Error = xxx + * and used something like: SLang_set_error (code); Then, I could + * use: + * if (Handle_Condition) + * { + * Handle_Condition = 0; + * if (SLang_Error) .... + * else if (Handle_Signal) handle_signal (); + * else.... + * } + */ + if (SLang_Error) + { + if (-1 == do_inner_interp_error (err_block, addr_start, addr)) + return 1; + if (SLang_Error) + return 1; + + /* Otherwise, error cleared. Continue onto next bytecode. + * Someday I need to add something to indicate where the + * next statement begins since continuing on the next + * bytecode is not really what is desired. + */ + if (Lang_Break_Condition) goto handle_break_condition; + } + addr++; + } + + handle_break_condition: + /* Get here if Lang_Break_Condition != 0, which implies that either + * Lang_Return, Lang_Break, or Lang_Continue is non zero + */ + if (Lang_Return) + Lang_Break = 1; + + return 1; +} + +/*}}}*/ + +/* The functions below this point are used to implement the parsed token + * to byte-compiled code. + */ +/* static SLang_Name_Type **Static_Hash_Table; */ + +static SLang_Name_Type **Locals_Hash_Table; +static int Local_Variable_Number; +static unsigned int Function_Args_Number; +int _SLang_Auto_Declare_Globals = 0; +int (*SLang_Auto_Declare_Var_Hook) (char *); + +static SLang_NameSpace_Type *This_Static_NameSpace; +static SLang_NameSpace_Type *Global_NameSpace; + +#if _SLANG_HAS_DEBUG_CODE +static char *This_Compile_Filename; +#endif +static SLBlock_Type SLShort_Blocks[6]; +/* These are initialized in add_table below. I cannot init a Union!! */ + +static int Lang_Defining_Function; +static void (*Default_Variable_Mode) (_SLang_Token_Type *); +static void (*Default_Define_Function) (char *, unsigned long); + +static int push_compile_context (char *); +static int pop_compile_context (void); + +typedef struct +{ + int block_type; + SLBlock_Type *block; /* beginning of block definition */ + SLBlock_Type *block_ptr; /* current location */ + SLBlock_Type *block_max; /* end of definition */ + SLang_NameSpace_Type *static_namespace; +} +Block_Context_Type; + +static Block_Context_Type Block_Context_Stack [SLANG_MAX_BLOCK_STACK_LEN]; +static unsigned int Block_Context_Stack_Len; + +static SLBlock_Type *Compile_ByteCode_Ptr; +static SLBlock_Type *This_Compile_Block; +static SLBlock_Type *This_Compile_Block_Max; +static int This_Compile_Block_Type; +#define COMPILE_BLOCK_TYPE_FUNCTION 1 +#define COMPILE_BLOCK_TYPE_BLOCK 2 +#define COMPILE_BLOCK_TYPE_TOP_LEVEL 3 + +/* If it returns 0, DO NOT FREE p */ +static int lang_free_branch (SLBlock_Type *p) +{ + /* Note: we look at 0,2,4, since these blocks are 0 terminated */ + if ((p == SLShort_Blocks) + || (p == SLShort_Blocks + 2) + || (p == SLShort_Blocks + 4) + ) + return 0; + + while (1) + { + SLang_Class_Type *cl; + + switch (p->bc_main_type) + { + case _SLANG_BC_BLOCK: + if (lang_free_branch(p->b.blk)) + SLfree((char *)p->b.blk); + break; + + case _SLANG_BC_LITERAL: + case _SLANG_BC_LITERAL_STR: + /* No user types should be here. */ + cl = _SLclass_get_class (p->bc_sub_type); + (*cl->cl_byte_code_destroy) (p->bc_sub_type, (VOID_STAR) &p->b.ptr_blk); + break; + + case _SLANG_BC_FIELD: + case _SLANG_BC_SET_STRUCT_LVALUE: + SLang_free_slstring (p->b.s_blk); + break; + + default: + break; + + case 0: + return 1; + } + p++; + } +} + +static void free_function_header (_SLBlock_Header_Type *h) +{ + if (h->num_refs > 1) + { + h->num_refs--; + return; + } + + if (h->body != NULL) + { + if (lang_free_branch (h->body)) + SLfree ((char *) h->body); + } + + SLfree ((char *) h); +} + +static int push_block_context (int type) +{ + Block_Context_Type *c; + unsigned int num; + SLBlock_Type *b; + + if (Block_Context_Stack_Len == SLANG_MAX_BLOCK_STACK_LEN) + { + SLang_verror (SL_STACK_OVERFLOW, "Block stack overflow"); + return -1; + } + + num = 5; /* 40 bytes */ + if (NULL == (b = (SLBlock_Type *) SLcalloc (num, sizeof (SLBlock_Type)))) + return -1; + + c = Block_Context_Stack + Block_Context_Stack_Len; + c->block = This_Compile_Block; + c->block_ptr = Compile_ByteCode_Ptr; + c->block_max = This_Compile_Block_Max; + c->block_type = This_Compile_Block_Type; + c->static_namespace = This_Static_NameSpace; + + Compile_ByteCode_Ptr = This_Compile_Block = b; + This_Compile_Block_Max = b + num; + This_Compile_Block_Type = type; + + Block_Context_Stack_Len += 1; + return 0; +} + +static int pop_block_context (void) +{ + Block_Context_Type *c; + + if (Block_Context_Stack_Len == 0) + return -1; + + Block_Context_Stack_Len -= 1; + c = Block_Context_Stack + Block_Context_Stack_Len; + + This_Compile_Block = c->block; + This_Compile_Block_Max = c->block_max; + This_Compile_Block_Type = c->block_type; + Compile_ByteCode_Ptr = c->block_ptr; + This_Static_NameSpace = c->static_namespace; + + return 0; +} + +int _SLcompile_push_context (SLang_Load_Type *load_object) +{ + if (-1 == push_compile_context (load_object->name)) + return -1; + + if (NULL == (This_Static_NameSpace = _SLns_allocate_namespace (load_object->name, SLSTATIC_HASH_TABLE_SIZE))) + { + pop_compile_context (); + return -1; + } + + if (-1 == push_block_context (COMPILE_BLOCK_TYPE_TOP_LEVEL)) + { + pop_compile_context (); + return -1; + } + + return 0; +} + +int _SLcompile_pop_context (void) +{ + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + Compile_ByteCode_Ptr->bc_main_type = 0; + if (lang_free_branch (This_Compile_Block)) + SLfree ((char *) This_Compile_Block); + } + + (void) pop_block_context (); + (void) pop_compile_context (); + + if (This_Compile_Block == NULL) + return 0; + +#if 0 + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_INTERNAL_ERROR, "Not at top-level"); + return -1; + } +#endif + + return 0; +} + +/*{{{ Hash and Name Table Functions */ + +static SLang_Name_Type *locate_name_in_table (char *name, unsigned long hash, + SLang_Name_Type **table, unsigned int table_size) +{ + SLang_Name_Type *t; + char ch; + + t = table [(unsigned int) (hash % table_size)]; + ch = *name++; + + while (t != NULL) + { + if ((ch == t->name[0]) + && (0 == strcmp (t->name + 1, name))) + break; + + t = t->next; + } + + return t; +} + +static SLang_Name_Type *locate_namespace_encoded_name (char *name, int err_on_bad_ns) +{ + char *ns, *ns1; + SLang_NameSpace_Type *table; + SLang_Name_Type *nt; + + ns = name; + name = strchr (name, '-'); + if ((name == NULL) || (name [1] != '>')) + name = ns; + + ns1 = SLang_create_nslstring (ns, (unsigned int) (name - ns)); + if (ns1 == NULL) + return NULL; + if (ns != name) + name += 2; + ns = ns1; + + if (*ns == 0) + { + /* Use Global Namespace */ + SLang_free_slstring (ns); + return locate_name_in_table (name, _SLcompute_string_hash (name), + Global_NameSpace->table, Global_NameSpace->table_size); + } + + if (NULL == (table = _SLns_find_namespace (ns))) + { + if (err_on_bad_ns) + SLang_verror (SL_SYNTAX_ERROR, "Unable to find namespace called %s", ns); + SLang_free_slstring (ns); + return NULL; + } + SLang_free_slstring (ns); + + /* FIXME: the hash table size should be stored in the hash table itself */ + nt = locate_name_in_table (name, _SLcompute_string_hash (name), + table->table, table->table_size); + if (nt == NULL) + return NULL; + + switch (nt->name_type) + { + /* These are private and cannot be accessed through the namespace. */ + case SLANG_PVARIABLE: + case SLANG_PFUNCTION: + return NULL; + } + return nt; +} + +static SLang_Name_Type *locate_hashed_name (char *name, unsigned long hash) +{ + SLang_Name_Type *t; + + if (Lang_Defining_Function) + { + t = locate_name_in_table (name, hash, Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE); + if (t != NULL) + return t; + } + + if ((This_Static_NameSpace != NULL) + && (NULL != (t = locate_name_in_table (name, hash, This_Static_NameSpace->table, This_Static_NameSpace->table_size)))) + return t; + + t = locate_name_in_table (name, hash, Global_NameSpace->table, Global_NameSpace->table_size); + if (NULL != t) + return t; + + return locate_namespace_encoded_name (name, 1); +} + +SLang_Name_Type *_SLlocate_name (char *name) +{ + return locate_hashed_name (name, _SLcompute_string_hash (name)); +} + +static SLang_Name_Type * +add_name_to_hash_table (char *name, unsigned long hash, + unsigned int sizeof_obj, unsigned char name_type, + SLang_Name_Type **table, unsigned int table_size, + int check_existing) +{ + SLang_Name_Type *t; + + if (check_existing) + { + t = locate_name_in_table (name, hash, table, table_size); + if (t != NULL) + return t; + } + + if (-1 == _SLcheck_identifier_syntax (name)) + return NULL; + + t = (SLang_Name_Type *) SLmalloc (sizeof_obj); + if (t == NULL) + return t; + + memset ((char *) t, 0, sizeof_obj); + if (NULL == (t->name = _SLstring_dup_hashed_string (name, hash))) + { + SLfree ((char *) t); + return NULL; + } + t->name_type = name_type; + + hash = hash % table_size; + t->next = table [(unsigned int)hash]; + table [(unsigned int) hash] = t; + + return t; +} + +static SLang_Name_Type * +add_global_name (char *name, unsigned long hash, + unsigned char name_type, unsigned int sizeof_obj, + SLang_NameSpace_Type *ns) +{ + SLang_Name_Type *nt; + SLang_Name_Type **table; + unsigned int table_size; + + table = ns->table; + table_size = ns->table_size; + + nt = locate_name_in_table (name, hash, table, table_size); + if (nt != NULL) + { + if (nt->name_type == name_type) + return nt; + + SLang_verror (SL_DUPLICATE_DEFINITION, "%s cannot be re-defined", name); + return NULL; + } + + return add_name_to_hash_table (name, hash, sizeof_obj, name_type, + table, table_size, 0); +} + +static int add_intrinsic_function (SLang_NameSpace_Type *ns, + char *name, FVOID_STAR addr, unsigned char ret_type, + unsigned int nargs, va_list ap) +{ + SLang_Intrin_Fun_Type *f; + unsigned int i; + + if (-1 == init_interpreter ()) + return -1; + + if (ns == NULL) ns = Global_NameSpace; + + if (nargs > SLANG_MAX_INTRIN_ARGS) + { + SLang_verror (SL_APPLICATION_ERROR, "Function %s requires too many arguments", name); + return -1; + } + + if (ret_type == SLANG_FLOAT_TYPE) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Function %s is not permitted to return float", name); + return -1; + } + + f = (SLang_Intrin_Fun_Type *) add_global_name (name, _SLcompute_string_hash (name), + SLANG_INTRINSIC, sizeof (SLang_Intrin_Fun_Type), + ns); + + if (f == NULL) + return -1; + + f->i_fun = addr; + f->num_args = nargs; + f->return_type = ret_type; + + for (i = 0; i < nargs; i++) + f->arg_types [i] = va_arg (ap, unsigned int); + + return 0; +} + +int SLadd_intrinsic_function (char *name, FVOID_STAR addr, unsigned char ret_type, + unsigned int nargs, ...) +{ + va_list ap; + int status; + + va_start (ap, nargs); + status = add_intrinsic_function (NULL, name, addr, ret_type, nargs, ap); + va_end (ap); + + return status; +} + +int SLns_add_intrinsic_function (SLang_NameSpace_Type *ns, + char *name, FVOID_STAR addr, unsigned char ret_type, + unsigned int nargs, ...) +{ + va_list ap; + int status; + + va_start (ap, nargs); + status = add_intrinsic_function (ns, name, addr, ret_type, nargs, ap); + va_end (ap); + + return status; +} + +int SLns_add_intrinsic_variable (SLang_NameSpace_Type *ns, + char *name, VOID_STAR addr, unsigned char data_type, int ro) +{ + SLang_Intrin_Var_Type *v; + + if (-1 == init_interpreter ()) + return -1; + + if (ns == NULL) ns = Global_NameSpace; + + v = (SLang_Intrin_Var_Type *)add_global_name (name, + _SLcompute_string_hash (name), + (ro ? SLANG_RVARIABLE : SLANG_IVARIABLE), + sizeof (SLang_Intrin_Var_Type), + ns); + if (v == NULL) + return -1; + + v->addr = addr; + v->type = data_type; + return 0; +} + +int SLadd_intrinsic_variable (char *name, VOID_STAR addr, unsigned char data_type, int ro) +{ + return SLns_add_intrinsic_variable (NULL, name, addr, data_type, ro); +} + +static int +add_slang_function (char *name, unsigned char type, unsigned long hash, + unsigned int num_args, unsigned int num_locals, +#if _SLANG_HAS_DEBUG_CODE + char *file, +#endif + _SLBlock_Header_Type *h, + SLang_NameSpace_Type *ns) +{ + _SLang_Function_Type *f; + +#if _SLANG_HAS_DEBUG_CODE + if ((file != NULL) + && (NULL == (file = SLang_create_slstring (file)))) + return -1; +#endif + + f = (_SLang_Function_Type *)add_global_name (name, hash, + type, + sizeof (_SLang_Function_Type), + ns); + if (f == NULL) + { +#if _SLANG_HAS_DEBUG_CODE + SLang_free_slstring (file); /* NULL ok */ +#endif + return -1; + } + + if (f->v.header != NULL) + { + if (f->nlocals == AUTOLOAD_NUM_LOCALS) + SLang_free_slstring ((char *)f->v.autoload_filename); /* autoloaded filename */ + else + free_function_header (f->v.header); + } + +#if _SLANG_HAS_DEBUG_CODE + if (f->file != NULL) SLang_free_slstring (f->file); + f->file = file; +#endif + f->v.header = h; + f->nlocals = num_locals; + f->nargs = num_args; + + return 0; +} + +int SLang_autoload (char *name, char *file) +{ + _SLang_Function_Type *f; + unsigned long hash; + + hash = _SLcompute_string_hash (name); + f = (_SLang_Function_Type *)locate_name_in_table (name, hash, Global_NameSpace->table, Global_NameSpace->table_size); + + if ((f != NULL) + && (f->name_type == SLANG_FUNCTION) + && (f->v.header != NULL) + && (f->nlocals != AUTOLOAD_NUM_LOCALS)) + { + /* already loaded */ + return 0; + } + + file = SLang_create_slstring (file); + if (-1 == add_slang_function (name, SLANG_FUNCTION, hash, 0, AUTOLOAD_NUM_LOCALS, +#if _SLANG_HAS_DEBUG_CODE + file, +#endif + (_SLBlock_Header_Type *) file, + Global_NameSpace)) + { + SLang_free_slstring (file); + return -1; + } + + return 0; +} + +SLang_Name_Type *_SLlocate_global_name (char *name) +{ + unsigned long hash; + + hash = _SLcompute_string_hash (name); + return locate_name_in_table (name, hash, Global_NameSpace->table, + Global_NameSpace->table_size); +} + +/*}}}*/ + +static void free_local_variable_table (void) +{ + unsigned int i; + SLang_Name_Type *t, *t1; + + for (i = 0; i < SLLOCALS_HASH_TABLE_SIZE; i++) + { + t = Locals_Hash_Table [i]; + while (t != NULL) + { + SLang_free_slstring (t->name); + t1 = t->next; + SLfree ((char *) t); + t = t1; + } + Locals_Hash_Table [i] = NULL; + } + Local_Variable_Number = 0; +} + +/* call inner interpreter or return for more */ +static void lang_try_now(void) +{ + Compile_ByteCode_Ptr++; + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + return; + + Compile_ByteCode_Ptr->bc_main_type = 0; /* so next command stops after this */ + + /* now do it */ + inner_interp (This_Compile_Block); + (void) lang_free_branch (This_Compile_Block); + Compile_ByteCode_Ptr = This_Compile_Block; +} + +SLang_Name_Type *SLang_get_fun_from_ref (SLang_Ref_Type *ref) +{ + if (ref->is_global) + { + SLang_Name_Type *nt = ref->v.nt; + + switch (nt->name_type) + { + case SLANG_PFUNCTION: + case SLANG_FUNCTION: + case SLANG_INTRINSIC: + case SLANG_MATH_UNARY: + case SLANG_APP_UNARY: + return nt; + } + SLang_verror (SL_TYPE_MISMATCH, + "Reference to a function expected. Found &%s", + nt->name); + } + + SLang_verror (SL_TYPE_MISMATCH, + "Reference to a function expected"); + return NULL; +} + +int SLexecute_function (SLang_Name_Type *nt) +{ + unsigned char type; + char *name; + + if (SLang_Error) + return -1; + + type = nt->name_type; + name = nt->name; + + switch (type) + { + case SLANG_PFUNCTION: + case SLANG_FUNCTION: + execute_slang_fun ((_SLang_Function_Type *) nt); + break; + + case SLANG_INTRINSIC: + execute_intrinsic_fun ((SLang_Intrin_Fun_Type *) nt); + break; + + case SLANG_MATH_UNARY: + case SLANG_APP_UNARY: + inner_interp_nametype (nt); + break; + + default: + SLang_verror (SL_TYPE_MISMATCH, "%s is not a function", name); + return -1; + } + + if (SLang_Error) + { + SLang_verror (SLang_Error, "Error while executing %s", name); + return -1; + } + + return 1; +} + +int SLang_execute_function (char *name) +{ + SLang_Name_Type *entry; + + if (NULL == (entry = SLang_get_function (name))) + return 0; + + return SLexecute_function (entry); +} + +/* return S-Lang function or NULL */ +SLang_Name_Type *SLang_get_function (char *name) +{ + SLang_Name_Type *entry; + + if (NULL == (entry = locate_namespace_encoded_name (name, 0))) + return NULL; + + if ((entry->name_type == SLANG_FUNCTION) + || (entry->name_type == SLANG_INTRINSIC)) + return entry; + + return NULL; +} + +static void lang_begin_function (void) +{ + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_SYNTAX_ERROR, "Function nesting is illegal"); + return; + } + Lang_Defining_Function = 1; + (void) push_block_context (COMPILE_BLOCK_TYPE_FUNCTION); +} + +#if USE_COMBINED_BYTECODES +static void optimize_block (SLBlock_Type *b) +{ + while (1) + { + switch (b->bc_main_type) + { + case 0: + return; + + default: + b++; + break; + + case _SLANG_BC_CALL_DIRECT: + b++; + switch (b->bc_main_type) + { + case 0: + return; + case _SLANG_BC_INTRINSIC: + if ((b+1)->bc_main_type == 0) + { + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_INTRSTOP; + return; + } + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_INTRINSIC; + b++; + break; + case _SLANG_BC_LITERAL_STR: + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LSTR; + b++; + break; + case _SLANG_BC_FUNCTION: + case _SLANG_BC_PFUNCTION: + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_SLFUN; + b++; + break; + case _SLANG_BC_EARG_LVARIABLE: + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_EARG_LVAR; + b++; + break; + case _SLANG_BC_LITERAL_INT: + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LINT; + b++; + break; + case _SLANG_BC_LVARIABLE: + (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LVAR; + b++; + break; + } + break; + + case _SLANG_BC_INTRINSIC: + b++; + switch (b->bc_main_type) + { + case _SLANG_BC_CALL_DIRECT: + (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_CALL_DIRECT; + b++; + break; +#if 0 + case _SLANG_BC_BLOCK: + (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_BLOCK; + b++; + break; +#endif + + case 0: + (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_STOP; + return; + } + break; + } + } +} + +#endif + + +/* name will be NULL if the object is to simply terminate the function + * definition. See SLang_restart. + */ +static int lang_define_function (char *name, unsigned char type, unsigned long hash, + SLang_NameSpace_Type *ns) +{ + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_FUNCTION) + { + SLang_verror (SL_SYNTAX_ERROR, "Premature end of function"); + return -1; + } + + /* terminate function */ + Compile_ByteCode_Ptr->bc_main_type = 0; + + if (name != NULL) + { + _SLBlock_Header_Type *h; + + h = (_SLBlock_Header_Type *)SLmalloc (sizeof (_SLBlock_Header_Type)); + if (h != NULL) + { + h->num_refs = 1; + h->body = This_Compile_Block; + +#if USE_COMBINED_BYTECODES + optimize_block (h->body); +#endif + + if (-1 == add_slang_function (name, type, hash, + Function_Args_Number, + Local_Variable_Number, +#if _SLANG_HAS_DEBUG_CODE + This_Compile_Filename, +#endif + h, ns)) + SLfree ((char *) h); + } + /* Drop through for clean-up */ + } + + free_local_variable_table (); + + Function_Args_Number = 0; + Lang_Defining_Function = 0; + + if (SLang_Error) return -1; + /* SLang_restart will finish this if there is a slang error. */ + + pop_block_context (); + + /* A function is only defined at top-level */ + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_INTERNAL_ERROR, "Not at top-level"); + return -1; + } + Compile_ByteCode_Ptr = This_Compile_Block; + return 0; +} + +static void define_static_function (char *name, unsigned long hash) +{ + (void) lang_define_function (name, SLANG_FUNCTION, hash, This_Static_NameSpace); +} + +static void define_private_function (char *name, unsigned long hash) +{ + (void) lang_define_function (name, SLANG_PFUNCTION, hash, This_Static_NameSpace); +} + +static void define_public_function (char *name, unsigned long hash) +{ + (void) lang_define_function (name, SLANG_FUNCTION, hash, Global_NameSpace); +} + +static void lang_end_block (void) +{ + SLBlock_Type *node, *branch; + unsigned char mtype; + + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK) + { + SLang_verror (SL_SYNTAX_ERROR, "Not defining a block"); + return; + } + + /* terminate the block */ + Compile_ByteCode_Ptr->bc_main_type = 0; + branch = This_Compile_Block; + + /* Try to save some space by using the cached blocks. */ + if (Compile_ByteCode_Ptr == branch + 1) + { + mtype = branch->bc_main_type; + if (((mtype == _SLANG_BC_BREAK) + || (mtype == _SLANG_BC_CONTINUE) + || (mtype == _SLANG_BC_RETURN)) + && (SLang_Error == 0)) + { + SLfree ((char *)branch); + branch = SLShort_Blocks + 2 * (int) (mtype - _SLANG_BC_RETURN); + } + } + +#if USE_COMBINED_BYTECODES + optimize_block (branch); +#endif + + pop_block_context (); + node = Compile_ByteCode_Ptr++; + + node->bc_main_type = _SLANG_BC_BLOCK; + node->bc_sub_type = 0; + node->b.blk = branch; +} + +static int lang_begin_block (void) +{ + return push_block_context (COMPILE_BLOCK_TYPE_BLOCK); +} + +static int lang_check_space (void) +{ + unsigned int n; + SLBlock_Type *p; + + if (NULL == (p = This_Compile_Block)) + { + SLang_verror (SL_INTERNAL_ERROR, "Top-level block not present"); + return -1; + } + + /* Allow 1 extra for terminator */ + if (Compile_ByteCode_Ptr + 1 < This_Compile_Block_Max) + return 0; + + n = (unsigned int) (This_Compile_Block_Max - p); + + /* enlarge the space by 2 objects */ + n += 2; + + if (NULL == (p = (SLBlock_Type *) SLrealloc((char *)p, n * sizeof(SLBlock_Type)))) + return -1; + + This_Compile_Block_Max = p + n; + n = (unsigned int) (Compile_ByteCode_Ptr - This_Compile_Block); + This_Compile_Block = p; + Compile_ByteCode_Ptr = p + n; + + return 0; +} + +/* returns positive number if name is a function or negative number if it + is a variable. If it is intrinsic, it returns magnitude of 1, else 2 */ +int SLang_is_defined(char *name) +{ + SLang_Name_Type *t; + + if (-1 == init_interpreter ()) + return -1; + + t = locate_namespace_encoded_name (name, 0); + if (t == NULL) + return 0; + + switch (t->name_type) + { + case SLANG_FUNCTION: + /* case SLANG_PFUNCTION: */ + return 2; + case SLANG_GVARIABLE: + /* case SLANG_PVARIABLE: */ + return -2; + + case SLANG_ICONSTANT: + case SLANG_DCONSTANT: + case SLANG_RVARIABLE: + case SLANG_IVARIABLE: + return -1; + + case SLANG_INTRINSIC: + default: + return 1; + } +} + +static int add_global_variable (char *name, char name_type, unsigned long hash, + SLang_NameSpace_Type *ns) +{ + SLang_Name_Type *g; + + /* Note the importance of checking if it is already defined or not. For example, + * suppose X is defined as an intrinsic variable. Then S-Lang code like: + * !if (is_defined("X")) { variable X; } + * will not result in a global variable X. On the other hand, this would + * not be an issue if 'variable' statements always were not processed + * immediately. That is, as it is now, 'if (0) {variable ZZZZ;}' will result + * in the variable ZZZZ being defined because of the immediate processing. + * The current solution is to do: if (0) { eval("variable ZZZZ;"); } + */ + /* hash = _SLcompute_string_hash (name); */ + g = locate_name_in_table (name, hash, ns->table, ns->table_size); + + if (g != NULL) + { + if (g->name_type == name_type) + return 0; + } + + if (NULL == add_global_name (name, hash, name_type, + sizeof (SLang_Global_Var_Type), ns)) + return -1; + + return 0; +} + +int SLadd_global_variable (char *name) +{ + if (-1 == init_interpreter ()) + return -1; + + return add_global_variable (name, SLANG_GVARIABLE, + _SLcompute_string_hash (name), + Global_NameSpace); +} + +static int add_local_variable (char *name, unsigned long hash) +{ + SLang_Local_Var_Type *t; + + /* local variable */ + if (Local_Variable_Number >= SLANG_MAX_LOCAL_VARIABLES) + { + SLang_verror (SL_SYNTAX_ERROR, "Too many local variables"); + return -1; + } + + if (NULL != locate_name_in_table (name, hash, Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE)) + { + SLang_verror (SL_SYNTAX_ERROR, "Local variable %s has already been defined", name); + return -1; + } + + t = (SLang_Local_Var_Type *) + add_name_to_hash_table (name, hash, + sizeof (SLang_Local_Var_Type), SLANG_LVARIABLE, + Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE, 0); + if (t == NULL) + return -1; + + t->local_var_number = Local_Variable_Number; + Local_Variable_Number++; + return 0; +} + +static void (*Compile_Mode_Function) (_SLang_Token_Type *); +static void compile_basic_token_mode (_SLang_Token_Type *); + +/* if an error occurs, discard current object, block, function, etc... */ +void SLang_restart (int localv) +{ + int save = SLang_Error; + + SLang_Error = SL_UNKNOWN_ERROR; + + _SLcompile_ptr = _SLcompile; + Compile_Mode_Function = compile_basic_token_mode; + + Lang_Break = /* Lang_Continue = */ Lang_Return = 0; + Trace_Mode = 0; + + while (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK) + lang_end_block(); + + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_FUNCTION) + { + /* Terminate function definition and free variables */ + lang_define_function (NULL, SLANG_FUNCTION, 0, Global_NameSpace); + if (lang_free_branch (This_Compile_Block)) + SLfree((char *)This_Compile_Block); + } + Lang_Defining_Function = 0; + + SLang_Error = save; + + if (SLang_Error == SL_STACK_OVERFLOW) + { + /* This loop guarantees that the stack is properly cleaned. */ + while (_SLStack_Pointer != _SLRun_Stack) + { + SLdo_pop (); + } + } + + while ((This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) + && (0 == pop_block_context ())) + ; + + if (localv) + { + Next_Function_Num_Args = SLang_Num_Function_Args = 0; + Local_Variable_Frame = Local_Variable_Stack; + Recursion_Depth = 0; + Frame_Pointer = _SLStack_Pointer; + Frame_Pointer_Depth = 0; + Switch_Obj_Ptr = Switch_Objects; + while (Switch_Obj_Ptr < Switch_Obj_Max) + { + SLang_free_object (Switch_Obj_Ptr); + Switch_Obj_Ptr++; + } + Switch_Obj_Ptr = Switch_Objects; + } +} + +static void compile_directive (unsigned char sub_type) +{ + /* This function is called only from compile_directive_mode which is + * only possible when a block is available. + */ + + /* use BLOCK */ + Compile_ByteCode_Ptr--; + Compile_ByteCode_Ptr->bc_sub_type = sub_type; + + lang_try_now (); +} + +static void compile_unary (int op, unsigned char mt) +{ + Compile_ByteCode_Ptr->bc_main_type = mt; + Compile_ByteCode_Ptr->b.i_blk = op; + Compile_ByteCode_Ptr->bc_sub_type = 0; + + lang_try_now (); +} + + +static void compile_binary (int op) +{ + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_BINARY; + Compile_ByteCode_Ptr->b.i_blk = op; + Compile_ByteCode_Ptr->bc_sub_type = 0; + + lang_try_now (); +} + +#if _SLANG_OPTIMIZE_FOR_SPEED +static int try_compressed_bytecode (unsigned char last_bc, unsigned char bc) +{ + if (Compile_ByteCode_Ptr != This_Compile_Block) + { + SLBlock_Type *b; + b = Compile_ByteCode_Ptr - 1; + if (b->bc_main_type == last_bc) + { + Compile_ByteCode_Ptr = b; + b->bc_main_type = bc; + lang_try_now (); + return 0; + } + } + return -1; +} +#endif + +static void compile_fast_binary (int op, unsigned char bc) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + if (0 == try_compressed_bytecode (_SLANG_BC_LITERAL_INT, bc)) + return; +#else + (void) bc; +#endif + compile_binary (op); +} + +/* This is a hack */ +typedef struct _Special_NameTable_Type +{ + char *name; + int (*fun) (struct _Special_NameTable_Type *, _SLang_Token_Type *); + VOID_STAR blk_data; + unsigned char main_type; +} +Special_NameTable_Type; + +static int handle_special (Special_NameTable_Type *nt, _SLang_Token_Type *tok) +{ + (void) tok; + Compile_ByteCode_Ptr->bc_main_type = nt->main_type; + Compile_ByteCode_Ptr->b.ptr_blk = nt->blk_data; + return 0; +} + +static int handle_special_file (Special_NameTable_Type *nt, _SLang_Token_Type *tok) +{ + char *name; + + (void) nt; (void) tok; + + if (This_Static_NameSpace == NULL) name = "***Unknown***"; + else + name = This_Static_NameSpace->name; + + name = SLang_create_slstring (name); + if (name == NULL) + return -1; + + Compile_ByteCode_Ptr->b.s_blk = name; + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL_STR; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE; + return 0; +} + +static int handle_special_line (Special_NameTable_Type *nt, _SLang_Token_Type *tok) +{ + (void) nt; + +#if _SLANG_HAS_DEBUG_CODE + Compile_ByteCode_Ptr->b.l_blk = (long) tok->line_number; +#endif + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_UINT_TYPE; + + return 0; +} + +static Special_NameTable_Type Special_Name_Table [] = +{ + {"EXECUTE_ERROR_BLOCK", handle_special, NULL, _SLANG_BC_X_ERROR}, + {"X_USER_BLOCK0", handle_special, NULL, _SLANG_BC_X_USER0}, + {"X_USER_BLOCK1", handle_special, NULL, _SLANG_BC_X_USER1}, + {"X_USER_BLOCK2", handle_special, NULL, _SLANG_BC_X_USER2}, + {"X_USER_BLOCK3", handle_special, NULL, _SLANG_BC_X_USER3}, + {"X_USER_BLOCK4", handle_special, NULL, _SLANG_BC_X_USER4}, + {"__FILE__", handle_special_file, NULL, 0}, + {"__LINE__", handle_special_line, NULL, 0}, +#if 0 + {"__NAMESPACE__", handle_special_namespace, NULL, 0}, +#endif + {NULL, NULL, NULL, 0} +}; + +static void compile_hashed_identifier (char *name, unsigned long hash, _SLang_Token_Type *tok) +{ + SLang_Name_Type *entry; + unsigned char name_type; + + entry = locate_hashed_name (name, hash); + + if (entry == NULL) + { + Special_NameTable_Type *nt = Special_Name_Table; + + while (nt->name != NULL) + { + if (strcmp (name, nt->name)) + { + nt++; + continue; + } + + if (0 == (*nt->fun)(nt, tok)) + lang_try_now (); + return; + } + + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + + name_type = entry->name_type; + Compile_ByteCode_Ptr->bc_main_type = name_type; + + if (name_type == SLANG_LVARIABLE) + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number; + else + Compile_ByteCode_Ptr->b.nt_blk = entry; + + lang_try_now (); +} + +static void compile_tmp_variable (char *name, unsigned long hash) +{ + SLang_Name_Type *entry; + unsigned char name_type; + + if (NULL == (entry = locate_hashed_name (name, hash))) + { + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + + name_type = entry->name_type; + switch (name_type) + { + case SLANG_LVARIABLE: + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number; + break; + + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + Compile_ByteCode_Ptr->b.nt_blk = entry; + break; + + default: + SLang_verror (SL_SYNTAX_ERROR, "__tmp(%s) does not specifiy a variable", name); + return; + } + + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_TMP; + Compile_ByteCode_Ptr->bc_sub_type = name_type; + + lang_try_now (); +} + +static void compile_simple (unsigned char main_type) +{ + Compile_ByteCode_Ptr->bc_main_type = main_type; + Compile_ByteCode_Ptr->bc_sub_type = 0; + Compile_ByteCode_Ptr->b.blk = NULL; + lang_try_now (); +} + +static void compile_identifier (char *name, _SLang_Token_Type *tok) +{ + compile_hashed_identifier (name, _SLcompute_string_hash (name), tok); +} + +static void compile_call_direct (int (*f) (void), unsigned char byte_code) +{ + Compile_ByteCode_Ptr->b.call_function = f; + Compile_ByteCode_Ptr->bc_main_type = byte_code; + Compile_ByteCode_Ptr->bc_sub_type = 0; + lang_try_now (); +} + +static void compile_lvar_call_direct (int (*f)(void), unsigned char bc, + unsigned char frame_op) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + if (0 == try_compressed_bytecode (_SLANG_BC_LVARIABLE, bc)) + return; +#else + (void) bc; +#endif + + compile_call_direct (f, frame_op); +} + +static void compile_integer (long i, unsigned char bc_main_type, unsigned char bc_sub_type) +{ + Compile_ByteCode_Ptr->b.l_blk = i; + Compile_ByteCode_Ptr->bc_main_type = bc_main_type; + Compile_ByteCode_Ptr->bc_sub_type = bc_sub_type; + + lang_try_now (); +} + +#if SLANG_HAS_FLOAT +static void compile_double (char *str, unsigned char type) +{ + double d; + unsigned int factor = 1; + double *ptr; + +#if 1 + d = _SLang_atof (str); +#else + if (1 != sscanf (str, "%lf", &d)) + { + SLang_verror (SL_SYNTAX_ERROR, "Unable to convert %s to double", str); + return; + } +#endif + +#if SLANG_HAS_COMPLEX + if (type == SLANG_COMPLEX_TYPE) factor = 2; +#endif + if (NULL == (ptr = (double *) SLmalloc(factor * sizeof(double)))) + return; + + Compile_ByteCode_Ptr->b.double_blk = ptr; +#if SLANG_HAS_COMPLEX + if (type == SLANG_COMPLEX_TYPE) + *ptr++ = 0; +#endif + *ptr = d; + + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; + Compile_ByteCode_Ptr->bc_sub_type = type; + lang_try_now (); +} + +static void compile_float (char *s) +{ + float x; + +#if 1 + x = (float) _SLang_atof (s); +#else + if (1 != sscanf (s, "%f", &x)) + { + SLang_verror (SL_SYNTAX_ERROR, "Unable to convert %s to float", s); + return; + } +#endif + Compile_ByteCode_Ptr->b.float_blk = x; + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_FLOAT_TYPE; + lang_try_now (); +} + +#endif + +static void compile_string (char *s, unsigned long hash) +{ + if (NULL == (Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string (s, hash))) + return; + + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL_STR; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE; + + lang_try_now (); +} + +static void compile_bstring (SLang_BString_Type *s) +{ + if (NULL == (Compile_ByteCode_Ptr->b.bs_blk = SLbstring_dup (s))) + return; + + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; + Compile_ByteCode_Ptr->bc_sub_type = SLANG_BSTRING_TYPE; + + lang_try_now (); +} + +/* assign_type is one of _SLANG_BCST_ASSIGN, ... values */ +static void compile_assign (unsigned char assign_type, + char *name, unsigned long hash) +{ + SLang_Name_Type *v; + unsigned char main_type; + SLang_Class_Type *cl; + + v = locate_hashed_name (name, hash); + if (v == NULL) + { + if ((_SLang_Auto_Declare_Globals == 0) + || (NULL != strchr (name, '-')) /* namespace->name form */ + || Lang_Defining_Function + || (assign_type != _SLANG_BCST_ASSIGN) + || (This_Static_NameSpace == NULL)) + { + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + /* Note that function local variables are not at top level */ + + /* Variables that are automatically declared are given static + * scope. + */ + if ((NULL != SLang_Auto_Declare_Var_Hook) + && (-1 == (*SLang_Auto_Declare_Var_Hook) (name))) + return; + + if ((-1 == add_global_variable (name, SLANG_GVARIABLE, hash, This_Static_NameSpace)) + || (NULL == (v = locate_hashed_name (name, hash)))) + return; + } + + switch (v->name_type) + { + case SLANG_LVARIABLE: + main_type = _SLANG_BC_SET_LOCAL_LVALUE; + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number; + break; + + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + main_type = _SLANG_BC_SET_GLOBAL_LVALUE; + Compile_ByteCode_Ptr->b.nt_blk = v; + break; + + case SLANG_IVARIABLE: + cl = _SLclass_get_class (((SLang_Intrin_Var_Type *)v)->type); + if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR) + { + SLang_verror (SL_SYNTAX_ERROR, "Assignment to %s is not allowed", name); + return; + } + main_type = _SLANG_BC_SET_INTRIN_LVALUE; + Compile_ByteCode_Ptr->b.nt_blk = v; + break; + + case SLANG_RVARIABLE: + SLang_verror (SL_READONLY_ERROR, "%s is read-only", name); + return; + + default: + SLang_verror (SL_DUPLICATE_DEFINITION, "%s may not be used as an lvalue", name); + return; + } + + Compile_ByteCode_Ptr->bc_sub_type = assign_type; + Compile_ByteCode_Ptr->bc_main_type = main_type; + + lang_try_now (); +} + +static void compile_deref_assign (char *name, unsigned long hash) +{ + SLang_Name_Type *v; + + v = locate_hashed_name (name, hash); + + if (v == NULL) + { + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + + switch (v->name_type) + { + case SLANG_LVARIABLE: + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number; + break; + + case SLANG_GVARIABLE: + case SLANG_PVARIABLE: + Compile_ByteCode_Ptr->b.nt_blk = v; + break; + + default: + /* FIXME: Priority=low + * This could be made to work. It is not a priority because + * I cannot imagine application intrinsics which are references. + */ + SLang_verror (SL_NOT_IMPLEMENTED, "Deref assignment to %s is not allowed", name); + return; + } + + Compile_ByteCode_Ptr->bc_sub_type = v->name_type; + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_DEREF_ASSIGN; + + lang_try_now (); +} + +static void +compile_struct_assign (_SLang_Token_Type *t) +{ + Compile_ByteCode_Ptr->bc_sub_type = _SLANG_BCST_ASSIGN + (t->type - _STRUCT_ASSIGN_TOKEN); + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_SET_STRUCT_LVALUE; + Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string (t->v.s_val, t->hash); + lang_try_now (); +} + +static void +compile_array_assign (_SLang_Token_Type *t) +{ + Compile_ByteCode_Ptr->bc_sub_type = _SLANG_BCST_ASSIGN + (t->type - _ARRAY_ASSIGN_TOKEN); + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_SET_ARRAY_LVALUE; + Compile_ByteCode_Ptr->b.s_blk = NULL; + lang_try_now (); +} + +static void compile_dot(_SLang_Token_Type *t) +{ + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_FIELD; + Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string(t->v.s_val, t->hash); + lang_try_now (); +} + +static void compile_ref (char *name, unsigned long hash) +{ + SLang_Name_Type *entry; + unsigned char main_type; + + if (NULL == (entry = locate_hashed_name (name, hash))) + { + SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); + return; + } + + main_type = entry->name_type; + + if (main_type == SLANG_LVARIABLE) + { + main_type = _SLANG_BC_LOBJPTR; + Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *)entry)->local_var_number; + } + else + { + main_type = _SLANG_BC_GOBJPTR; + Compile_ByteCode_Ptr->b.nt_blk = entry; + } + + Compile_ByteCode_Ptr->bc_main_type = main_type; + lang_try_now (); +} + +static void compile_break (unsigned char break_type, + int requires_block, int requires_fun, + char *str) +{ + if ((requires_fun + && (Lang_Defining_Function == 0)) + || (requires_block + && (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK))) + { + SLang_verror (SL_SYNTAX_ERROR, "misplaced %s", str); + return; + } + + Compile_ByteCode_Ptr->bc_main_type = break_type; + Compile_ByteCode_Ptr->bc_sub_type = 0; + + lang_try_now (); +} + +static void compile_public_variable_mode (_SLang_Token_Type *t) +{ + if (t->type == IDENT_TOKEN) + { + /* If the variable is already defined in the static hash table, + * generate an error. + */ + if ((This_Static_NameSpace != NULL) + && (NULL != locate_name_in_table (t->v.s_val, t->hash, This_Static_NameSpace->table, This_Static_NameSpace->table_size))) + { + SLang_verror (SL_DUPLICATE_DEFINITION, + "%s already has static or private linkage in this unit", + t->v.s_val); + return; + } + add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, Global_NameSpace); + } + else if (t->type == CBRACKET_TOKEN) + Compile_Mode_Function = compile_basic_token_mode; + else + SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); +} + +static void compile_local_variable_mode (_SLang_Token_Type *t) +{ + if (t->type == IDENT_TOKEN) + add_local_variable (t->v.s_val, t->hash); + else if (t->type == CBRACKET_TOKEN) + Compile_Mode_Function = compile_basic_token_mode; + else + SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); +} + +static void compile_static_variable_mode (_SLang_Token_Type *t) +{ + if (t->type == IDENT_TOKEN) + add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, This_Static_NameSpace); + else if (t->type == CBRACKET_TOKEN) + Compile_Mode_Function = compile_basic_token_mode; + else + SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); +} + +static void compile_private_variable_mode (_SLang_Token_Type *t) +{ + if (t->type == IDENT_TOKEN) + add_global_variable (t->v.s_val, SLANG_PVARIABLE, t->hash, This_Static_NameSpace); + else if (t->type == CBRACKET_TOKEN) + Compile_Mode_Function = compile_basic_token_mode; + else + SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); +} + +static void compile_function_mode (_SLang_Token_Type *t) +{ + if (-1 == lang_check_space ()) + return; + + if (t->type != IDENT_TOKEN) + SLang_verror (SL_SYNTAX_ERROR, "Expecting function name"); + else + lang_define_function (t->v.s_val, SLANG_FUNCTION, t->hash, Global_NameSpace); + + Compile_Mode_Function = compile_basic_token_mode; +} + +/* An error block is not permitted to contain continue or break statements. + * This restriction may be removed later but for now reject them. + */ +static int check_error_block (void) +{ + SLBlock_Type *p; + unsigned char t; + + /* Back up to the block and then scan it. */ + p = (Compile_ByteCode_Ptr - 1)->b.blk; + + while (0 != (t = p->bc_main_type)) + { + if ((t == _SLANG_BC_BREAK) + || (t == _SLANG_BC_CONTINUE)) + { + SLang_verror (SL_SYNTAX_ERROR, + "An ERROR_BLOCK is not permitted to contain continue or break statements"); + return -1; + } + p++; + } + return 0; +} + +/* The only allowed tokens are the directives and another block start. + * The mode is only active if a block is available. The inner_interp routine + * expects such safety checks. + */ +static void compile_directive_mode (_SLang_Token_Type *t) +{ + int bc_sub_type; + + if (-1 == lang_check_space ()) + return; + + bc_sub_type = -1; + + switch (t->type) + { + case FOREVER_TOKEN: + bc_sub_type = _SLANG_BCST_FOREVER; + break; + + case IFNOT_TOKEN: + bc_sub_type = _SLANG_BCST_IFNOT; + break; + + case IF_TOKEN: + bc_sub_type = _SLANG_BCST_IF; + break; + + case ANDELSE_TOKEN: + bc_sub_type = _SLANG_BCST_ANDELSE; + break; + + case SWITCH_TOKEN: + bc_sub_type = _SLANG_BCST_SWITCH; + break; + + case EXITBLK_TOKEN: + if (Lang_Defining_Function == 0) + { + SLang_verror (SL_SYNTAX_ERROR, "misplaced EXIT_BLOCK"); + break; + } + bc_sub_type = _SLANG_BCST_EXIT_BLOCK; + break; + + case ERRBLK_TOKEN: + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_SYNTAX_ERROR, "misplaced ERROR_BLOCK"); + break; + } + if (0 == check_error_block ()) + bc_sub_type = _SLANG_BCST_ERROR_BLOCK; + break; + + case USRBLK0_TOKEN: + case USRBLK1_TOKEN: + case USRBLK2_TOKEN: + case USRBLK3_TOKEN: + case USRBLK4_TOKEN: + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) + { + SLang_verror (SL_SYNTAX_ERROR, "misplaced USER_BLOCK"); + break; + } + bc_sub_type = _SLANG_BCST_USER_BLOCK0 + (t->type - USRBLK0_TOKEN); + break; + + case NOTELSE_TOKEN: + bc_sub_type = _SLANG_BCST_NOTELSE; + break; + + case ELSE_TOKEN: + bc_sub_type = _SLANG_BCST_ELSE; + break; + + case LOOP_TOKEN: + bc_sub_type = _SLANG_BCST_LOOP; + break; + + case DOWHILE_TOKEN: + bc_sub_type = _SLANG_BCST_DOWHILE; + break; + + case WHILE_TOKEN: + bc_sub_type = _SLANG_BCST_WHILE; + break; + + case ORELSE_TOKEN: + bc_sub_type = _SLANG_BCST_ORELSE; + break; + + case _FOR_TOKEN: + bc_sub_type = _SLANG_BCST_FOR; + break; + + case FOR_TOKEN: + bc_sub_type = _SLANG_BCST_CFOR; + break; + + case FOREACH_TOKEN: + bc_sub_type = _SLANG_BCST_FOREACH; + break; + + case OBRACE_TOKEN: + lang_begin_block (); + break; + + default: + SLang_verror (SL_SYNTAX_ERROR, "Expecting directive token. Found 0x%X", t->type); + break; + } + + /* Reset this pointer first because compile_directive may cause a + * file to be loaded. + */ + Compile_Mode_Function = compile_basic_token_mode; + + if (bc_sub_type != -1) + compile_directive (bc_sub_type); +} + +static unsigned int Assign_Mode_Type; +static void compile_assign_mode (_SLang_Token_Type *t) +{ + if (t->type != IDENT_TOKEN) + { + SLang_verror (SL_SYNTAX_ERROR, "Expecting identifier for assignment"); + return; + } + + compile_assign (Assign_Mode_Type, t->v.s_val, t->hash); + Compile_Mode_Function = compile_basic_token_mode; +} + +static void compile_basic_token_mode (_SLang_Token_Type *t) +{ + if (-1 == lang_check_space ()) + return; + + switch (t->type) + { + case PUSH_TOKEN: + case NOP_TOKEN: + case EOF_TOKEN: + case READONLY_TOKEN: + case DO_TOKEN: + case VARIABLE_TOKEN: + case SEMICOLON_TOKEN: + default: + SLang_verror (SL_SYNTAX_ERROR, "Unknown or unsupported token type 0x%X", t->type); + break; + + case DEREF_TOKEN: + compile_call_direct (dereference_object, _SLANG_BC_CALL_DIRECT); + break; + + case STRUCT_TOKEN: + compile_call_direct (_SLstruct_define_struct, _SLANG_BC_CALL_DIRECT); + break; + + case TYPEDEF_TOKEN: + compile_call_direct (_SLstruct_define_typedef, _SLANG_BC_CALL_DIRECT); + break; + + case TMP_TOKEN: + compile_tmp_variable (t->v.s_val, t->hash); + break; + + case DOT_TOKEN: /* X . field */ + compile_dot (t); + break; + + case COMMA_TOKEN: + break; /* do nothing */ + + case IDENT_TOKEN: + compile_hashed_identifier (t->v.s_val, t->hash, t); + break; + + case _REF_TOKEN: + compile_ref (t->v.s_val, t->hash); + break; + + case ARG_TOKEN: + compile_call_direct (SLang_start_arg_list, _SLANG_BC_CALL_DIRECT); + break; + + case EARG_TOKEN: + compile_lvar_call_direct (SLang_end_arg_list, _SLANG_BC_EARG_LVARIABLE, _SLANG_BC_CALL_DIRECT); + break; + + case COLON_TOKEN: + if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK) + compile_simple (_SLANG_BC_LABEL); + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case POP_TOKEN: + compile_call_direct (SLdo_pop, _SLANG_BC_CALL_DIRECT); + break; + + case CASE_TOKEN: + if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK) + SLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case'"); + else + compile_call_direct (case_function, _SLANG_BC_CALL_DIRECT); + break; + + case CHAR_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_CHAR_TYPE); + break; + case SHORT_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_SHORT_TYPE); + break; + case INT_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL_INT, SLANG_INT_TYPE); + break; + case UCHAR_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_UCHAR_TYPE); + break; + case USHORT_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_USHORT_TYPE); + break; + case UINT_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL_INT, SLANG_UINT_TYPE); + break; + case LONG_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_LONG_TYPE); + break; + case ULONG_TOKEN: + compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_ULONG_TYPE); + break; + +#if SLANG_HAS_FLOAT + case FLOAT_TOKEN: + compile_float (t->v.s_val); + break; + + case DOUBLE_TOKEN: + compile_double (t->v.s_val, SLANG_DOUBLE_TYPE); + break; +#endif +#if SLANG_HAS_COMPLEX + case COMPLEX_TOKEN: + compile_double (t->v.s_val, SLANG_COMPLEX_TYPE); + break; +#endif + + case STRING_TOKEN: + compile_string (t->v.s_val, t->hash); + break; + + case _BSTRING_TOKEN: + compile_bstring (SLbstring_create ((unsigned char *)t->v.s_val, (unsigned int) t->hash)); + break; + + case BSTRING_TOKEN: + compile_bstring (t->v.b_val); + break; + + case _NULL_TOKEN: + compile_identifier ("NULL", t); + break; + + case _INLINE_WILDCARD_ARRAY_TOKEN: + compile_call_direct (_SLarray_wildcard_array, _SLANG_BC_CALL_DIRECT); + break; + + case _INLINE_ARRAY_TOKEN: + compile_call_direct (_SLarray_inline_array, _SLANG_BC_CALL_DIRECT_FRAME); + break; + + case _INLINE_IMPLICIT_ARRAY_TOKEN: + compile_call_direct (_SLarray_inline_implicit_array, _SLANG_BC_CALL_DIRECT_FRAME); + break; + + case ARRAY_TOKEN: + compile_lvar_call_direct (_SLarray_aget, _SLANG_BC_LVARIABLE_AGET, _SLANG_BC_CALL_DIRECT_FRAME); + break; + + /* Note: I need to add the other _ARRAY assign tokens. */ + case _ARRAY_PLUSEQS_TOKEN: + case _ARRAY_MINUSEQS_TOKEN: + case _ARRAY_TIMESEQS_TOKEN: + case _ARRAY_DIVEQS_TOKEN: + case _ARRAY_BOREQS_TOKEN: + case _ARRAY_BANDEQS_TOKEN: + case _ARRAY_POST_MINUSMINUS_TOKEN: + case _ARRAY_MINUSMINUS_TOKEN: + case _ARRAY_POST_PLUSPLUS_TOKEN: + case _ARRAY_PLUSPLUS_TOKEN: + compile_array_assign (t); + break; + + case _ARRAY_ASSIGN_TOKEN: + compile_lvar_call_direct (_SLarray_aput, _SLANG_BC_LVARIABLE_APUT, _SLANG_BC_CALL_DIRECT_FRAME); + break; + + case _STRUCT_ASSIGN_TOKEN: + case _STRUCT_PLUSEQS_TOKEN: + case _STRUCT_MINUSEQS_TOKEN: + case _STRUCT_TIMESEQS_TOKEN: + case _STRUCT_DIVEQS_TOKEN: + case _STRUCT_BOREQS_TOKEN: + case _STRUCT_BANDEQS_TOKEN: + case _STRUCT_POST_MINUSMINUS_TOKEN: + case _STRUCT_MINUSMINUS_TOKEN: + case _STRUCT_POST_PLUSPLUS_TOKEN: + case _STRUCT_PLUSPLUS_TOKEN: + compile_struct_assign (t); + break; + + case _SCALAR_ASSIGN_TOKEN: + case _SCALAR_PLUSEQS_TOKEN: + case _SCALAR_MINUSEQS_TOKEN: + case _SCALAR_TIMESEQS_TOKEN: + case _SCALAR_DIVEQS_TOKEN: + case _SCALAR_BOREQS_TOKEN: + case _SCALAR_BANDEQS_TOKEN: + case _SCALAR_POST_MINUSMINUS_TOKEN: + case _SCALAR_MINUSMINUS_TOKEN: + case _SCALAR_POST_PLUSPLUS_TOKEN: + case _SCALAR_PLUSPLUS_TOKEN: + compile_assign (_SLANG_BCST_ASSIGN + (t->type - _SCALAR_ASSIGN_TOKEN), + t->v.s_val, t->hash); + break; + + case _DEREF_ASSIGN_TOKEN: + compile_deref_assign (t->v.s_val, t->hash); + break; + + /* For processing RPN tokens */ + case ASSIGN_TOKEN: + case PLUSEQS_TOKEN: + case MINUSEQS_TOKEN: + case TIMESEQS_TOKEN: + case DIVEQS_TOKEN: + case BOREQS_TOKEN: + case BANDEQS_TOKEN: + case POST_MINUSMINUS_TOKEN: + case MINUSMINUS_TOKEN: + case POST_PLUSPLUS_TOKEN: + case PLUSPLUS_TOKEN: + Compile_Mode_Function = compile_assign_mode; + Assign_Mode_Type = _SLANG_BCST_ASSIGN + (t->type - ASSIGN_TOKEN); + break; + + case LT_TOKEN: + compile_binary (SLANG_LT); + break; + + case LE_TOKEN: + compile_binary (SLANG_LE); + break; + + case GT_TOKEN: + compile_binary (SLANG_GT); + break; + + case GE_TOKEN: + compile_binary (SLANG_GE); + break; + + case EQ_TOKEN: + compile_binary (SLANG_EQ); + break; + + case NE_TOKEN: + compile_binary (SLANG_NE); + break; + + case AND_TOKEN: + compile_binary (SLANG_AND); + break; + + case ADD_TOKEN: + compile_fast_binary (SLANG_PLUS, _SLANG_BC_INTEGER_PLUS); + break; + + case SUB_TOKEN: + compile_fast_binary (SLANG_MINUS, _SLANG_BC_INTEGER_MINUS); + break; + + case TIMES_TOKEN: + compile_binary (SLANG_TIMES); + break; + + case DIV_TOKEN: + compile_binary (SLANG_DIVIDE); + break; + + case POW_TOKEN: + compile_binary (SLANG_POW); + break; + + case BXOR_TOKEN: + compile_binary (SLANG_BXOR); + break; + + case BAND_TOKEN: + compile_binary (SLANG_BAND); + break; + + case BOR_TOKEN: + compile_binary (SLANG_BOR); + break; + + case SHR_TOKEN: + compile_binary (SLANG_SHR); + break; + + case SHL_TOKEN: + compile_binary (SLANG_SHL); + break; + + case MOD_TOKEN: + compile_binary (SLANG_MOD); + break; + + case OR_TOKEN: + compile_binary (SLANG_OR); + break; + + case NOT_TOKEN: + compile_unary (SLANG_NOT, _SLANG_BC_UNARY); + break; + + case BNOT_TOKEN: + compile_unary (SLANG_BNOT, _SLANG_BC_UNARY); + break; + + case MUL2_TOKEN: + compile_unary (SLANG_MUL2, _SLANG_BC_UNARY_FUNC); + break; + + case CHS_TOKEN: + compile_unary (SLANG_CHS, _SLANG_BC_UNARY_FUNC); + break; + + case ABS_TOKEN: + compile_unary (SLANG_ABS, _SLANG_BC_UNARY_FUNC); + break; + + case SQR_TOKEN: + compile_unary (SLANG_SQR, _SLANG_BC_UNARY_FUNC); + break; + + case SIGN_TOKEN: + compile_unary (SLANG_SIGN, _SLANG_BC_UNARY_FUNC); + break; + + case BREAK_TOKEN: + compile_break (_SLANG_BC_BREAK, 1, 0, "break"); + break; + + case RETURN_TOKEN: + compile_break (_SLANG_BC_RETURN, 0, 1, "return"); + break; + + case CONT_TOKEN: + compile_break (_SLANG_BC_CONTINUE, 1, 0, "continue"); + break; + + case EXCH_TOKEN: + compile_break (_SLANG_BC_EXCH, 0, 0, ""); /* FIXME: Priority=low */ + break; + + case STATIC_TOKEN: + if (Lang_Defining_Function == 0) + Compile_Mode_Function = compile_static_variable_mode; + else + SLang_verror (SL_NOT_IMPLEMENTED, "static variables not permitted in functions"); + break; + + case PRIVATE_TOKEN: + if (Lang_Defining_Function == 0) + Compile_Mode_Function = compile_private_variable_mode; + else + SLang_verror (SL_NOT_IMPLEMENTED, "private variables not permitted in functions"); + break; + + case PUBLIC_TOKEN: + if (Lang_Defining_Function == 0) + Compile_Mode_Function = compile_public_variable_mode; + else + SLang_verror (SL_NOT_IMPLEMENTED, "public variables not permitted in functions"); + break; + + case OBRACKET_TOKEN: + if (Lang_Defining_Function == 0) + Compile_Mode_Function = Default_Variable_Mode; + else + Compile_Mode_Function = compile_local_variable_mode; + break; + + case OPAREN_TOKEN: + lang_begin_function (); + break; + + case DEFINE_STATIC_TOKEN: + if (Lang_Defining_Function) + define_static_function (t->v.s_val, t->hash); + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case DEFINE_PRIVATE_TOKEN: + if (Lang_Defining_Function) + define_private_function (t->v.s_val, t->hash); + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case DEFINE_PUBLIC_TOKEN: + if (Lang_Defining_Function) + define_public_function (t->v.s_val, t->hash); + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case DEFINE_TOKEN: + if (Lang_Defining_Function) + (*Default_Define_Function) (t->v.s_val, t->hash); + else + SLang_Error = SL_SYNTAX_ERROR; + break; + + case CPAREN_TOKEN: + if (Lang_Defining_Function) + Compile_Mode_Function = compile_function_mode; + else SLang_Error = SL_SYNTAX_ERROR; + break; + + case CBRACE_TOKEN: + lang_end_block (); + Compile_Mode_Function = compile_directive_mode; + break; + + case OBRACE_TOKEN: + lang_begin_block (); + break; + + case FARG_TOKEN: + Function_Args_Number = Local_Variable_Number; + break; + +#if _SLANG_HAS_DEBUG_CODE + case LINE_NUM_TOKEN: + Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LINE_NUM; + Compile_ByteCode_Ptr->b.l_blk = t->v.long_val; + lang_try_now (); + break; +#endif + case POUND_TOKEN: + compile_call_direct (_SLarray_matrix_multiply, _SLANG_BC_CALL_DIRECT); + break; + } +} + +void _SLcompile (_SLang_Token_Type *t) +{ + if (SLang_Error == 0) + { + if (Compile_Mode_Function != compile_basic_token_mode) + { + if (Compile_Mode_Function == NULL) + Compile_Mode_Function = compile_basic_token_mode; +#if _SLANG_HAS_DEBUG_CODE + if (t->type == LINE_NUM_TOKEN) + { + compile_basic_token_mode (t); + return; + } +#endif + } + + (*Compile_Mode_Function) (t); + } + + if (SLang_Error) + { + Compile_Mode_Function = compile_basic_token_mode; + SLang_restart (0); + } +} + +void (*_SLcompile_ptr)(_SLang_Token_Type *) = _SLcompile; + +typedef struct _Compile_Context_Type +{ + struct _Compile_Context_Type *next; + SLang_NameSpace_Type *static_namespace; + void (*compile_variable_mode) (_SLang_Token_Type *); + void (*define_function) (char *, unsigned long); + int lang_defining_function; + int local_variable_number; + unsigned int function_args_number; + SLang_Name_Type **locals_hash_table; + void (*compile_mode_function)(_SLang_Token_Type *); +#if _SLANG_HAS_DEBUG_CODE + char *compile_filename; +#endif +} +Compile_Context_Type; + +static Compile_Context_Type *Compile_Context_Stack; + +/* The only way the push/pop_context functions can get called is via + * an eval type function. That can only happen when executed from a + * top level block. This means that Compile_ByteCode_Ptr can always be + * rest back to the beginning of a block. + */ + +static int pop_compile_context (void) +{ + Compile_Context_Type *cc; + + if (NULL == (cc = Compile_Context_Stack)) + return -1; + + This_Static_NameSpace = cc->static_namespace; + Compile_Context_Stack = cc->next; + Default_Variable_Mode = cc->compile_variable_mode; + Default_Define_Function = cc->define_function; + Compile_Mode_Function = cc->compile_mode_function; + + Lang_Defining_Function = cc->lang_defining_function; + Local_Variable_Number = cc->local_variable_number; + Function_Args_Number = cc->function_args_number; + +#if _SLANG_HAS_DEBUG_CODE + SLang_free_slstring (This_Compile_Filename); + This_Compile_Filename = cc->compile_filename; +#endif + + SLfree ((char *) Locals_Hash_Table); + Locals_Hash_Table = cc->locals_hash_table; + + SLfree ((char *) cc); + + return 0; +} + +static int push_compile_context (char *name) +{ + Compile_Context_Type *cc; + SLang_Name_Type **lns; + + cc = (Compile_Context_Type *)SLmalloc (sizeof (Compile_Context_Type)); + if (cc == NULL) + return -1; + memset ((char *) cc, 0, sizeof (Compile_Context_Type)); + + lns = (SLang_Name_Type **) SLcalloc (sizeof (SLang_Name_Type *), SLLOCALS_HASH_TABLE_SIZE); + if (lns == NULL) + { + SLfree ((char *) cc); + return -1; + } + +#if _SLANG_HAS_DEBUG_CODE + if ((name != NULL) + && (NULL == (name = SLang_create_slstring (name)))) + { + SLfree ((char *) cc); + SLfree ((char *) lns); + return -1; + } + + cc->compile_filename = This_Compile_Filename; + This_Compile_Filename = name; +#endif + + cc->static_namespace = This_Static_NameSpace; + cc->compile_variable_mode = Default_Variable_Mode; + cc->define_function = Default_Define_Function; + cc->locals_hash_table = Locals_Hash_Table; + + cc->lang_defining_function = Lang_Defining_Function; + cc->local_variable_number = Local_Variable_Number; + cc->function_args_number = Function_Args_Number; + cc->locals_hash_table = Locals_Hash_Table; + cc->compile_mode_function = Compile_Mode_Function; + + cc->next = Compile_Context_Stack; + Compile_Context_Stack = cc; + + Compile_Mode_Function = compile_basic_token_mode; + Default_Variable_Mode = compile_public_variable_mode; + Default_Define_Function = define_public_function; + Lang_Defining_Function = 0; + Local_Variable_Number = 0; + Function_Args_Number = 0; + Locals_Hash_Table = lns; + return 0; +} + +static int init_interpreter (void) +{ + SLang_NameSpace_Type *ns; + + if (Global_NameSpace != NULL) + return 0; + + if (NULL == (ns = _SLns_allocate_namespace ("***GLOBAL***", SLGLOBALS_HASH_TABLE_SIZE))) + return -1; + if (-1 == _SLns_set_namespace_name (ns, "Global")) + return -1; + Global_NameSpace = ns; + + _SLRun_Stack = (SLang_Object_Type *) SLcalloc (SLANG_MAX_STACK_LEN, + sizeof (SLang_Object_Type)); + if (_SLRun_Stack == NULL) + return -1; + + _SLStack_Pointer = _SLRun_Stack; + _SLStack_Pointer_Max = _SLRun_Stack + SLANG_MAX_STACK_LEN; + + SLShort_Blocks[0].bc_main_type = _SLANG_BC_RETURN; + SLShort_Blocks[2].bc_main_type = _SLANG_BC_BREAK; + SLShort_Blocks[4].bc_main_type = _SLANG_BC_CONTINUE; + + Num_Args_Stack = (int *) SLmalloc (sizeof (int) * SLANG_MAX_RECURSIVE_DEPTH); + if (Num_Args_Stack == NULL) + { + SLfree ((char *) _SLRun_Stack); + return -1; + } + Recursion_Depth = 0; + Frame_Pointer_Stack = (unsigned int *) SLmalloc (sizeof (unsigned int) * SLANG_MAX_RECURSIVE_DEPTH); + if (Frame_Pointer_Stack == NULL) + { + SLfree ((char *) _SLRun_Stack); + SLfree ((char *)Num_Args_Stack); + return -1; + } + Frame_Pointer_Depth = 0; + Frame_Pointer = _SLRun_Stack; + + Default_Variable_Mode = compile_public_variable_mode; + Default_Define_Function = define_public_function; + return 0; +} + +static int add_generic_table (SLang_NameSpace_Type *ns, + SLang_Name_Type *table, char *pp_name, + unsigned int entry_len) +{ + SLang_Name_Type *t, **ns_table; + char *name; + unsigned int table_size; + + if (-1 == init_interpreter ()) + return -1; + + if (ns == NULL) + ns = Global_NameSpace; + + ns_table = ns->table; + table_size = ns->table_size; + + if ((pp_name != NULL) + && (-1 == SLdefine_for_ifdef (pp_name))) + return -1; + + t = table; + while (NULL != (name = t->name)) + { + unsigned long hash; + + /* Backward compatibility: '.' WAS used as hash marker */ + if (*name == '.') + { + name++; + t->name = name; + } + + if (NULL == (name = SLang_create_slstring (name))) + return -1; + + t->name = name; + + hash = _SLcompute_string_hash (name); + hash = hash % table_size; + + t->next = ns_table [(unsigned int) hash]; + ns_table [(unsigned int) hash] = t; + + t = (SLang_Name_Type *) ((char *)t + entry_len); + } + + return 0; +} + +int SLadd_intrin_fun_table (SLang_Intrin_Fun_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type)); +} + +int SLadd_intrin_var_table (SLang_Intrin_Var_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type)); +} + +int SLadd_app_unary_table (SLang_App_Unary_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type)); +} + +int SLadd_math_unary_table (SLang_Math_Unary_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type)); +} + +int SLadd_iconstant_table (SLang_IConstant_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type)); +} + +#if SLANG_HAS_FLOAT +int SLadd_dconstant_table (SLang_DConstant_Type *tbl, char *pp) +{ + return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type)); +} +#endif + +/* ----------- */ +int SLns_add_intrin_fun_table (SLang_NameSpace_Type *ns, SLang_Intrin_Fun_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type)); +} + +int SLns_add_intrin_var_table (SLang_NameSpace_Type *ns, SLang_Intrin_Var_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type)); +} + +int SLns_add_app_unary_table (SLang_NameSpace_Type *ns, SLang_App_Unary_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type)); +} + +int SLns_add_math_unary_table (SLang_NameSpace_Type *ns, SLang_Math_Unary_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type)); +} + +int SLns_add_iconstant_table (SLang_NameSpace_Type *ns, SLang_IConstant_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type)); +} + +#if SLANG_HAS_FLOAT +int SLns_add_dconstant_table (SLang_NameSpace_Type *ns, SLang_DConstant_Type *tbl, char *pp) +{ + return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type)); +} +#endif + +/* what is a bitmapped value: + * 1 intrin fun + * 2 user fun + * 4 intrin var + * 8 user defined var + */ +SLang_Array_Type *_SLang_apropos (char *namespace_name, char *pat, unsigned int what) +{ + SLang_NameSpace_Type *ns; + + if (namespace_name == NULL) + namespace_name = "Global"; + + if (*namespace_name == 0) + ns = This_Static_NameSpace; + else ns = _SLns_find_namespace (namespace_name); + + return _SLnspace_apropos (ns, pat, what); +} + +void _SLang_implements_intrinsic (char *name) +{ + if (This_Static_NameSpace == NULL) + { + SLang_verror (SL_INTRINSIC_ERROR, "No namespace available"); + return; + } + + (void) _SLns_set_namespace_name (This_Static_NameSpace, name); + + Default_Define_Function = define_static_function; + Default_Variable_Mode = compile_static_variable_mode; +} + +void _SLang_use_namespace_intrinsic (char *name) +{ + SLang_NameSpace_Type *ns; + + if (NULL == (ns = _SLns_find_namespace (name))) + { + SLang_verror (SL_INTRINSIC_ERROR, "Namespace %s does not exist", name); + return; + } + This_Static_NameSpace = ns; + if (Global_NameSpace == ns) + { + Default_Define_Function = define_public_function; + Default_Variable_Mode = compile_public_variable_mode; + } + else + { + Default_Define_Function = define_static_function; + Default_Variable_Mode = compile_static_variable_mode; + } +} + + +char *_SLang_cur_namespace_intrinsic (void) +{ + if (This_Static_NameSpace == NULL) + return "Global"; + + if (This_Static_NameSpace->namespace_name == NULL) + return ""; + + return This_Static_NameSpace->namespace_name; +} diff --git a/mdk-stage1/slang/slang.h b/mdk-stage1/slang/slang.h new file mode 100644 index 000000000..900b14043 --- /dev/null +++ b/mdk-stage1/slang/slang.h @@ -0,0 +1,1930 @@ +#ifndef DAVIS_SLANG_H_ +#define DAVIS_SLANG_H_ +/* -*- mode: C; mode: fold; -*- */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#define SLANG_VERSION 10404 +#define SLANG_VERSION_STRING "1.4.4" + +/*{{{ System Dependent Macros and Typedefs */ + +#if defined(__WATCOMC__) && defined(DOS) +# ifndef __MSDOS__ +# define __MSDOS__ +# endif +# ifndef DOS386 +# define DOS386 +# endif +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif /* __watcomc__ */ + +#if defined(unix) || defined(__unix) +# ifndef __unix__ +# define __unix__ 1 +# endif +#endif + +#if !defined(__GO32__) +# ifdef __unix__ +# define REAL_UNIX_SYSTEM +# endif +#endif + +/* Set of the various defines for pc systems. This includes OS/2 */ +#ifdef __GO32__ +# ifndef __DJGPP__ +# define __DJGPP__ 1 +# endif +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif + +#ifdef __BORLANDC__ +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif + +#ifdef __MSDOS__ +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif + +#if defined(OS2) || defined(__os2__) +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +# ifndef __os2__ +# define __os2__ +# endif +#endif + +#if defined(__NT__) || defined(__MINGW32__) || defined(__CYGWIN32__) +# ifndef IBMPC_SYSTEM +# define IBMPC_SYSTEM +# endif +#endif + +#if defined(IBMPC_SYSTEM) || defined(VMS) +# ifdef REAL_UNIX_SYSTEM +# undef REAL_UNIX_SYSTEM +# endif +#endif + +#ifdef __cplusplus +extern "C" { +#endif +#if 0 +} +#endif + +#include <stdio.h> +#include <stdarg.h> +#if defined(__STDC__) || defined(__BORLANDC__) || defined(__cplusplus) +# include <stddef.h> /* for offsetof */ +#endif + +/* ---------------------------- Generic Macros ----------------------------- */ + +/* __SC__ is defined for Symantec C++ + DOS386 is defined for -mx memory model, 32 bit DOS extender. */ + +#if defined(__SC__) && !defined(DOS386) +# include <dos.h> +#endif + +#if defined(__BORLANDC__) +# include <alloc.h> +#endif + +#if defined (__cplusplus) || defined(__STDC__) || defined(IBMPC_SYSTEM) + typedef void *VOID_STAR; +#else + typedef unsigned char *VOID_STAR; +#endif + +typedef int (*FVOID_STAR)(void); + +#if defined(__MSDOS_) && defined(__BORLANDC__) +# define SLFREE(buf) farfree((void far *)(buf)) +# define SLMALLOC(x) farmalloc((unsigned long) (x)) +# define SLREALLOC(buf, n) farrealloc((void far *) (buf), (unsigned long) (n)) +# define SLCALLOC(n, m) farcalloc((unsigned long) (n), (unsigned long) (m)) +#else +# if defined(VMS) && !defined(__DECC) +# define SLFREE VAXC$FREE_OPT +# define SLMALLOC VAXC$MALLOC_OPT +# define SLREALLOC VAXC$REALLOC_OPT +# define SLCALLOC VAXC$CALLOC_OPT +# else +# define SLFREE(x) free((char *)(x)) +# define SLMALLOC malloc +# define SLREALLOC realloc +# define SLCALLOC calloc +# endif +#endif + + extern char *SLdebug_malloc (unsigned long); + extern char *SLdebug_calloc (unsigned long, unsigned long); + extern char *SLdebug_realloc (char *, unsigned long); + extern void SLdebug_free (char *); + extern void SLmalloc_dump_statistics (void); + extern char *SLstrcpy(register char *, register char *); + extern int SLstrcmp(register char *, register char *); + extern char *SLstrncpy(char *, register char *, register int); + + extern void SLmemset (char *, char, int); + extern char *SLmemchr (register char *, register char, register int); + extern char *SLmemcpy (char *, char *, int); + extern int SLmemcmp (char *, char *, int); + +/*}}}*/ + +/*{{{ Interpreter Typedefs */ + +typedef struct _SLang_Name_Type +{ + char *name; + struct _SLang_Name_Type *next; + char name_type; + /* These values must be less than 0x10 because they map directly + * to byte codes. See _slang.h. + */ +#define SLANG_LVARIABLE 0x01 +#define SLANG_GVARIABLE 0x02 +#define SLANG_IVARIABLE 0x03 /* intrinsic variables */ + /* Note!!! For Macro MAKE_VARIABLE below to work, SLANG_IVARIABLE Must + be 1 less than SLANG_RVARIABLE!!! */ +#define SLANG_RVARIABLE 0x04 /* read only variable */ +#define SLANG_INTRINSIC 0x05 +#define SLANG_FUNCTION 0x06 +#define SLANG_MATH_UNARY 0x07 +#define SLANG_APP_UNARY 0x08 +#define SLANG_ICONSTANT 0x09 +#define SLANG_DCONSTANT 0x0A +#define SLANG_PVARIABLE 0x0B /* private */ +#define SLANG_PFUNCTION 0x0C /* private */ + + /* Rest of fields depend on name type */ +} +SLang_Name_Type; + +typedef struct +{ + char *name; + struct _SLang_Name_Type *next; /* this is for the hash table */ + char name_type; + + FVOID_STAR i_fun; /* address of object */ + + /* Do not change this without modifying slang.c:execute_intrinsic_fun */ +#define SLANG_MAX_INTRIN_ARGS 7 + unsigned char arg_types [SLANG_MAX_INTRIN_ARGS]; + unsigned char num_args; + unsigned char return_type; +} +SLang_Intrin_Fun_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + VOID_STAR addr; + unsigned char type; +} +SLang_Intrin_Var_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + int unary_op; +} +SLang_App_Unary_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + + int unary_op; +} +SLang_Math_Unary_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + int i; +} +SLang_IConstant_Type; + +typedef struct +{ + char *name; + SLang_Name_Type *next; + char name_type; + double d; +} +SLang_DConstant_Type; + +typedef struct +{ + char *field_name; + unsigned int offset; + unsigned char type; + unsigned char read_only; +} +SLang_IStruct_Field_Type; + +extern int SLadd_intrin_fun_table (SLang_Intrin_Fun_Type *, char *); +extern int SLadd_intrin_var_table (SLang_Intrin_Var_Type *, char *); +extern int SLadd_app_unary_table (SLang_App_Unary_Type *, char *); +extern int SLadd_math_unary_table (SLang_Math_Unary_Type *, char *); +extern int SLadd_iconstant_table (SLang_IConstant_Type *, char *); +extern int SLadd_dconstant_table (SLang_DConstant_Type *, char *); +extern int SLadd_istruct_table (SLang_IStruct_Field_Type *, VOID_STAR, char *); + +typedef struct _SLang_NameSpace_Type SLang_NameSpace_Type; + +extern int SLns_add_intrin_fun_table (SLang_NameSpace_Type *, SLang_Intrin_Fun_Type *, char *); +extern int SLns_add_intrin_var_table (SLang_NameSpace_Type *, SLang_Intrin_Var_Type *, char *); +extern int SLns_add_app_unary_table (SLang_NameSpace_Type *, SLang_App_Unary_Type *, char *); +extern int SLns_add_math_unary_table (SLang_NameSpace_Type *, SLang_Math_Unary_Type *, char *); +extern int SLns_add_iconstant_table (SLang_NameSpace_Type *, SLang_IConstant_Type *, char *); +extern int SLns_add_dconstant_table (SLang_NameSpace_Type *, SLang_DConstant_Type *, char *); +extern int SLns_add_istruct_table (SLang_NameSpace_Type *, SLang_IStruct_Field_Type *, VOID_STAR, char *); + +extern SLang_NameSpace_Type *SLns_create_namespace (char *); +extern void SLns_delete_namespace (SLang_NameSpace_Type *); + +typedef struct SLang_Load_Type +{ + int type; + + VOID_STAR client_data; + /* Pointer to data that client needs for loading */ + + int auto_declare_globals; + /* if non-zero, undefined global variables are declared as static */ + + char *(*read)(struct SLang_Load_Type *); + /* function to call to read next line from obj. */ + + unsigned int line_num; + /* Number of lines read, used for error reporting */ + + int parse_level; + /* 0 if at top level of parsing */ + + char *name; + /* Name of this object, e.g., filename. This name should be unique because + * it alone determines the name space for static objects associated with + * the compilable unit. + */ + + unsigned long reserved[4]; + /* For future expansion */ +} SLang_Load_Type; + +extern SLang_Load_Type *SLallocate_load_type (char *); +extern void SLdeallocate_load_type (SLang_Load_Type *); + +/* Returns SLang_Error upon failure */ +extern int SLang_load_object (SLang_Load_Type *); +extern int (*SLang_Load_File_Hook)(char *); +extern int (*SLang_Auto_Declare_Var_Hook) (char *); + +extern int SLang_generate_debug_info (int); + + +#if defined(ultrix) && !defined(__GNUC__) +# ifndef NO_PROTOTYPES +# define NO_PROTOTYPES +# endif +#endif + +#ifndef NO_PROTOTYPES +# define _PROTO(x) x +#else +# define _PROTO(x) () +#endif + +typedef struct SL_OOBinary_Type +{ + unsigned char data_type; /* partner type for binary op */ + + int (*binary_function)_PROTO((int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR)); + + int (*binary_result) _PROTO((int, unsigned char, unsigned char, unsigned char *)); + struct SL_OOBinary_Type *next; +} +SL_OOBinary_Type; + +typedef struct _SL_Typecast_Type +{ + unsigned char data_type; /* to_type */ + int allow_implicit; + + int (*typecast)_PROTO((unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR)); + struct _SL_Typecast_Type *next; +} +SL_Typecast_Type; + +typedef struct _SLang_Struct_Type SLang_Struct_Type; + +#if defined(SL_APP_WANTS_FOREACH) +/* It is up to the application to define struct _SLang_Foreach_Context_Type */ +typedef struct _SLang_Foreach_Context_Type SLang_Foreach_Context_Type; +#else +typedef int SLang_Foreach_Context_Type; +#endif + +typedef struct +{ + unsigned char cl_class_type; +#define SLANG_CLASS_TYPE_MMT 0 +#define SLANG_CLASS_TYPE_SCALAR 1 +#define SLANG_CLASS_TYPE_VECTOR 2 +#define SLANG_CLASS_TYPE_PTR 3 + + unsigned int cl_data_type; /* SLANG_INTEGER_TYPE, etc... */ + char *cl_name; /* slstring type */ + + unsigned int cl_sizeof_type; + VOID_STAR cl_transfer_buf; /* cl_sizeof_type bytes*/ + + /* Methods */ + + /* Most of the method functions are prototyped: + * int method (unsigned char type, VOID_STAR addr); + * Here, @type@ represents the type of object that the method is asked + * to deal with. The second parameter @addr@ will contain the ADDRESS of + * the object. For example, if type is SLANG_INT_TYPE, then @addr@ will + * actually be int *. Similary, if type is SLANG_STRING_TYPE, + * then @addr@ will contain the address of the string, i.e., char **. + */ + + void (*cl_destroy)_PROTO((unsigned char, VOID_STAR)); + /* Prototype: void destroy(unsigned type, VOID_STAR val) + * Called to delete/free the object */ + + char *(*cl_string)_PROTO((unsigned char, VOID_STAR)); + /* Prototype: char *to_string (unsigned char t, VOID_STAR p); + * Here p is a pointer to the object for which a string representation + * is to be returned. The returned pointer is to be a MALLOCED string. + */ + + /* Prototype: void push(unsigned char type, VOID_STAR v); + * Push a copy of the object of type @type@ at address @v@ onto the + * stack. + */ + int (*cl_push)_PROTO((unsigned char, VOID_STAR)); + + /* Prototype: int pop(unsigned char type, VOID_STAR v); + * Pops value from stack and assign it to object, whose address is @v@. + */ + int (*cl_pop)_PROTO((unsigned char, VOID_STAR)); + + int (*cl_unary_op_result_type)_PROTO((int, unsigned char, unsigned char *)); + int (*cl_unary_op)_PROTO((int, unsigned char, VOID_STAR, unsigned int, VOID_STAR)); + + int (*cl_app_unary_op_result_type)_PROTO((int, unsigned char, unsigned char *)); + int (*cl_app_unary_op)_PROTO((int, unsigned char, VOID_STAR, unsigned int, VOID_STAR)); + + /* If this function is non-NULL, it will be called for sin, cos, etc... */ +#define SLMATH_SIN 1 +#define SLMATH_COS 2 +#define SLMATH_TAN 3 +#define SLMATH_ATAN 4 +#define SLMATH_ASIN 5 +#define SLMATH_ACOS 6 +#define SLMATH_EXP 7 +#define SLMATH_LOG 8 +#define SLMATH_SQRT 9 +#define SLMATH_LOG10 10 +#define SLMATH_REAL 11 +#define SLMATH_IMAG 12 +#define SLMATH_SINH 13 +#define SLMATH_COSH 14 +#define SLMATH_TANH 15 +#define SLMATH_ATANH 16 +#define SLMATH_ASINH 17 +#define SLMATH_ACOSH 18 +#define SLMATH_TODOUBLE 19 +#define SLMATH_CONJ 20 + + int (*cl_math_op)_PROTO((int, unsigned char, VOID_STAR, unsigned int, VOID_STAR)); + int (*cl_math_op_result_type)_PROTO((int, unsigned char, unsigned char *)); + + SL_OOBinary_Type *cl_binary_ops; + SL_Typecast_Type *cl_typecast_funs; + + void (*cl_byte_code_destroy)_PROTO((unsigned char, VOID_STAR)); + void (*cl_user_destroy_fun)_PROTO((unsigned char, VOID_STAR)); + int (*cl_init_array_object)_PROTO((unsigned char, VOID_STAR)); + int (*cl_datatype_deref)_PROTO((unsigned char)); + SLang_Struct_Type *cl_struct_def; + int (*cl_dereference) _PROTO((unsigned char, VOID_STAR)); + int (*cl_acopy) (unsigned char, VOID_STAR, VOID_STAR); + int (*cl_apop) _PROTO((unsigned char, VOID_STAR)); + int (*cl_apush) _PROTO((unsigned char, VOID_STAR)); + int (*cl_push_literal) _PROTO((unsigned char, VOID_STAR)); + void (*cl_adestroy)_PROTO((unsigned char, VOID_STAR)); + int (*cl_push_intrinsic)_PROTO((unsigned char, VOID_STAR)); + int (*cl_void_typecast)_PROTO((unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR)); + + int (*cl_anytype_typecast)_PROTO((unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR)); + + /* Array access functions */ + int (*cl_aput) (unsigned char, unsigned int); + int (*cl_aget) (unsigned char, unsigned int); + int (*cl_anew) (unsigned char, unsigned int); + + /* length method */ + int (*cl_length) (unsigned char, VOID_STAR, unsigned int *); + + /* foreach */ + SLang_Foreach_Context_Type *(*cl_foreach_open) (unsigned char, unsigned int); + void (*cl_foreach_close) (unsigned char, SLang_Foreach_Context_Type *); + int (*cl_foreach) (unsigned char, SLang_Foreach_Context_Type *); + + /* Structure access: get and put (assign to) fields */ + int (*cl_sput) (unsigned char, char *); + int (*cl_sget) (unsigned char, char *); + + /* File I/O */ + int (*cl_fread) (unsigned char, FILE *, VOID_STAR, unsigned int, unsigned int *); + int (*cl_fwrite) (unsigned char, FILE *, VOID_STAR, unsigned int, unsigned int *); + int (*cl_fdread) (unsigned char, int, VOID_STAR, unsigned int, unsigned int *); + int (*cl_fdwrite) (unsigned char, int, VOID_STAR, unsigned int, unsigned int *); + + int (*cl_to_bool) (unsigned char, int *); + + int (*cl_cmp)(unsigned char, VOID_STAR, VOID_STAR, int *); + +} SLang_Class_Type; + +/* These are the low-level functions for building push/pop methods. They + * know nothing about memory management. For SLANG_CLASS_TYPE_MMT, use the + * MMT push/pop functions instead. + */ +extern int SLclass_push_double_obj (unsigned char, double); +extern int SLclass_push_float_obj (unsigned char, float); +extern int SLclass_push_long_obj (unsigned char, long); +extern int SLclass_push_int_obj (unsigned char, int); +extern int SLclass_push_short_obj (unsigned char, short); +extern int SLclass_push_char_obj (unsigned char, char); +extern int SLclass_push_ptr_obj (unsigned char, VOID_STAR); +extern int SLclass_pop_double_obj (unsigned char, double *); +extern int SLclass_pop_float_obj (unsigned char, float *); +extern int SLclass_pop_long_obj (unsigned char, long *); +extern int SLclass_pop_int_obj (unsigned char, int *); +extern int SLclass_pop_short_obj (unsigned char, short *); +extern int SLclass_pop_char_obj (unsigned char, char *); +extern int SLclass_pop_ptr_obj (unsigned char, VOID_STAR *); + +extern SLang_Class_Type *SLclass_allocate_class (char *); +extern int SLclass_get_class_id (SLang_Class_Type *cl); +extern int SLclass_create_synonym (char *, unsigned char); +extern int SLclass_is_class_defined (unsigned char); + +extern int SLclass_register_class (SLang_Class_Type *, unsigned char, unsigned int, unsigned char); +extern int SLclass_set_string_function (SLang_Class_Type *, char *(*)(unsigned char, VOID_STAR)); +extern int SLclass_set_destroy_function (SLang_Class_Type *, void (*)(unsigned char, VOID_STAR)); +extern int SLclass_set_push_function (SLang_Class_Type *, int (*)(unsigned char, VOID_STAR)); +extern int SLclass_set_pop_function (SLang_Class_Type *, int (*)(unsigned char, VOID_STAR)); + +extern int SLclass_set_aget_function (SLang_Class_Type *, int (*)(unsigned char, unsigned int)); +extern int SLclass_set_aput_function (SLang_Class_Type *, int (*)(unsigned char, unsigned int)); +extern int SLclass_set_anew_function (SLang_Class_Type *, int (*)(unsigned char, unsigned int)); + +extern int SLclass_set_sget_function (SLang_Class_Type *, int (*)(unsigned char, char *)); +extern int SLclass_set_sput_function (SLang_Class_Type *, int (*)(unsigned char, char *)); + +/* Typecast object on the stack to type p1. p2 and p3 should be set to 1 */ +extern int SLclass_typecast (unsigned char, int, int); + +extern int SLclass_add_unary_op (unsigned char, + int (*) (int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*) (int, unsigned char, unsigned char *)); + +extern int +SLclass_add_app_unary_op (unsigned char, + int (*) (int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*) (int, unsigned char, unsigned char *)); + +extern int +SLclass_add_binary_op (unsigned char, unsigned char, + int (*) (int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*) (int, unsigned char, unsigned char, unsigned char *)); + +extern int +SLclass_add_math_op (unsigned char, + int (*)(int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*)(int, unsigned char, unsigned char *)); + +extern int +SLclass_add_typecast (unsigned char /* from */, unsigned char /* to */, + int (*)_PROTO((unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR)), + int /* allow implicit typecasts */ + ); + +extern char *SLclass_get_datatype_name (unsigned char); + +extern double SLcomplex_abs (double *); +extern double *SLcomplex_times (double *, double *, double *); +extern double *SLcomplex_divide (double *, double *, double *); +extern double *SLcomplex_sin (double *, double *); +extern double *SLcomplex_cos (double *, double *); +extern double *SLcomplex_tan (double *, double *); +extern double *SLcomplex_asin (double *, double *); +extern double *SLcomplex_acos (double *, double *); +extern double *SLcomplex_atan (double *, double *); +extern double *SLcomplex_exp (double *, double *); +extern double *SLcomplex_log (double *, double *); +extern double *SLcomplex_log10 (double *, double *); +extern double *SLcomplex_sqrt (double *, double *); +extern double *SLcomplex_sinh (double *, double *); +extern double *SLcomplex_cosh (double *, double *); +extern double *SLcomplex_tanh (double *, double *); +extern double *SLcomplex_pow (double *, double *, double *); +extern double SLmath_hypot (double x, double y); + +/* Not implemented yet */ +extern double *SLcomplex_asinh (double *, double *); +extern double *SLcomplex_acosh (double *, double *); +extern double *SLcomplex_atanh (double *, double *); + +#ifdef _SLANG_SOURCE_ +typedef struct _SLang_MMT_Type SLang_MMT_Type; +#else +typedef int SLang_MMT_Type; +#endif + +extern void SLang_free_mmt (SLang_MMT_Type *); +extern VOID_STAR SLang_object_from_mmt (SLang_MMT_Type *); +extern SLang_MMT_Type *SLang_create_mmt (unsigned char, VOID_STAR); +extern int SLang_push_mmt (SLang_MMT_Type *); +extern SLang_MMT_Type *SLang_pop_mmt (unsigned char); +extern void SLang_inc_mmt (SLang_MMT_Type *); + +/* Maximum number of dimensions of an array. */ +#define SLARRAY_MAX_DIMS 7 +typedef struct _SLang_Array_Type +{ + unsigned char data_type; + unsigned int sizeof_type; + VOID_STAR data; + unsigned int num_elements; + unsigned int num_dims; + int dims [SLARRAY_MAX_DIMS]; + VOID_STAR (*index_fun)_PROTO((struct _SLang_Array_Type *, int *)); + /* This function is designed to allow a type to store an array in + * any manner it chooses. This function returns the address of the data + * value at the specified index location. + */ + unsigned int flags; +#define SLARR_DATA_VALUE_IS_READ_ONLY 1 +#define SLARR_DATA_VALUE_IS_POINTER 2 +#define SLARR_DATA_VALUE_IS_RANGE 4 +#define SLARR_DATA_VALUE_IS_INTRINSIC 8 + SLang_Class_Type *cl; + unsigned int num_refs; +} +SLang_Array_Type; + +extern int SLang_pop_array_of_type (SLang_Array_Type **, unsigned char); +extern int SLang_pop_array (SLang_Array_Type **, int); +extern int SLang_push_array (SLang_Array_Type *, int); +extern void SLang_free_array (SLang_Array_Type *); +extern SLang_Array_Type *SLang_create_array (unsigned char, int, VOID_STAR, int *, unsigned int); +extern SLang_Array_Type *SLang_duplicate_array (SLang_Array_Type *); +extern int SLang_get_array_element (SLang_Array_Type *, int *, VOID_STAR); +extern int SLang_set_array_element (SLang_Array_Type *, int *, VOID_STAR); + + +/*}}}*/ + +/*{{{ Interpreter Function Prototypes */ + + extern volatile int SLang_Error; +/* Non zero if error occurs. Must be reset to zero to continue. */ +/* error codes, severe errors are less than 0 */ +#define SL_APPLICATION_ERROR -2 +#define SL_VARIABLE_UNINITIALIZED -3 +#define SL_INTERNAL_ERROR -5 +#define SL_STACK_OVERFLOW -6 +#define SL_STACK_UNDERFLOW -7 +#define SL_UNDEFINED_NAME -8 +#define SL_SYNTAX_ERROR -9 +#define SL_DUPLICATE_DEFINITION -10 +#define SL_TYPE_MISMATCH -11 +#define SL_OBJ_UNKNOWN -13 +#define SL_UNKNOWN_ERROR -14 +#define SL_TYPE_UNDEFINED_OP_ERROR -16 + +#define SL_INTRINSIC_ERROR 1 +/* Intrinsic error is an error generated by intrinsic functions */ +#define SL_USER_BREAK 2 +#define SL_DIVIDE_ERROR 3 +#define SL_OBJ_NOPEN 4 +#define SL_USER_ERROR 5 +#define SL_USAGE_ERROR 6 +#define SL_READONLY_ERROR 7 +#define SL_INVALID_PARM 8 +#define SL_NOT_IMPLEMENTED 9 +#define SL_MALLOC_ERROR 10 +#define SL_OVERFLOW 11 +#define SL_FLOATING_EXCEPTION 12 + +/* Compatibility */ +#define USER_BREAK SL_USER_BREAK +#define INTRINSIC_ERROR SL_INTRINSIC_ERROR + + extern int SLang_Traceback; + /* If non-zero, dump an S-Lang traceback upon error. Available as + _traceback in S-Lang. */ + + extern char *SLang_User_Prompt; + /* Prompt to use when reading from stdin */ + extern int SLang_Version; + extern char *SLang_Version_String; +extern char *SLang_Doc_Dir; + +extern void (*SLang_VMessage_Hook) (char *, va_list); +extern void SLang_vmessage (char *, ...); + + extern void (*SLang_Error_Hook)(char *); + /* Pointer to application dependent error messaging routine. By default, + messages are displayed on stderr. */ + + extern void (*SLang_Exit_Error_Hook)(char *, va_list); + extern void SLang_exit_error (char *, ...); + extern void (*SLang_Dump_Routine)(char *); + /* Called if S-Lang traceback is enabled as well as other debugging + routines (e.g., trace). By default, these messages go to stderr. */ + + extern void (*SLang_Interrupt)(void); + /* function to call whenever inner interpreter is entered. This is + a good place to set SLang_Error to USER_BREAK. */ + + extern void (*SLang_User_Clear_Error)(void); + /* function that gets called when '_clear_error' is called. */ + + /* If non null, these call C functions before and after a slang function. */ + extern void (*SLang_Enter_Function)(char *); +extern void (*SLang_Exit_Function)(char *); + +extern int SLang_Num_Function_Args; + +/* Functions: */ + +extern int SLang_init_all (void); +/* Initializes interpreter and all modules */ + +extern int SLang_init_slang (void); +/* This function is mandatory and must be called by all applications that + * use the interpreter + */ +extern int SLang_init_posix_process (void); /* process specific intrinsics */ +extern int SLang_init_stdio (void); /* fgets, etc. stdio functions */ +extern int SLang_init_posix_dir (void); +extern int SLang_init_ospath (void); + +extern int SLang_init_slmath (void); +/* called if math functions sin, cos, etc... are needed. */ + + extern int SLang_init_slfile (void); + extern int SLang_init_slunix (void); + /* These functions are obsolte. Use init_stdio, posix_process, etc. */ + +extern int SLang_init_slassoc (void); +/* Assoc Arrays (Hashes) */ + +extern int SLang_init_array (void); +/* Additional arrays functions: transpose, etc... */ + +/* Dynamic linking facility */ +extern int SLang_init_import (void); + + extern int SLang_load_file (char *); + /* Load a file of S-Lang code for interpreting. If the parameter is + * NULL, input comes from stdin. */ + + extern void SLang_restart(int); + /* should be called if an error occurs. If the passed integer is + * non-zero, items are popped off the stack; otherwise, the stack is + * left intact. Any time the stack is believed to be trashed, this routine + * should be called with a non-zero argument (e.g., if setjmp/longjmp is + * called). */ + + extern int SLang_byte_compile_file(char *, int); + /* takes a file of S-Lang code and ``byte-compiles'' it for faster + * loading. The new filename is equivalent to the old except that a `c' is + * appended to the name. (e.g., init.sl --> init.slc). The second + * specified the method; currently, it is not used. + */ + + extern int SLang_autoload(char *, char *); + /* Automatically load S-Lang function p1 from file p2. This function + is also available via S-Lang */ + + extern int SLang_load_string(char *); + /* Like SLang_load_file except input is from a null terminated string. */ + + extern int SLdo_pop(void); + /* pops item off stack and frees any memory associated with it */ + extern int SLdo_pop_n(unsigned int); + /* pops n items off stack and frees any memory associated with them */ + +extern int SLang_pop_integer(int *); +extern int SLang_pop_uinteger(unsigned int *); + /* pops integer *p0 from the stack. Returns 0 upon success and non-zero + * if the stack is empty or a type mismatch occurs, setting SLang_Error. + */ +extern int SLang_pop_char (char *); +extern int SLang_pop_uchar (unsigned char *); +extern int SLang_pop_short(short *); +extern int SLang_pop_ushort(unsigned short *); +extern int SLang_pop_long(long *); +extern int SLang_pop_ulong(unsigned long *); + +extern int SLang_pop_float(float *); +extern int SLang_pop_double(double *, int *, int *); + /* Pops double *p1 from stack. If *p3 is non-zero, *p1 was derived + from the integer *p2. Returns zero upon success. */ + + extern int SLang_pop_complex (double *, double *); + + extern int SLpop_string (char **); + extern int SLang_pop_string(char **, int *); + /* pops string *p0 from stack. If *p1 is non-zero, the string must be + * freed after its use. DO NOT FREE p0 if *p1 IS ZERO! Returns 0 upon + * success */ + + extern int SLang_push_complex (double, double); + + extern int SLang_push_char (char); + extern int SLang_push_uchar (unsigned char); + + extern int SLang_push_integer(int); + extern int SLang_push_uinteger(unsigned int); + /* push integer p1 on stack */ + + extern int SLang_push_short(short); + extern int SLang_push_ushort(unsigned short); + extern int SLang_push_long(long); + extern int SLang_push_ulong(unsigned long); + extern int SLang_push_float(float); + extern int SLang_push_double(double); + /* Push double onto stack */ + + extern int SLang_push_string(char *); + /* Push string p1 onto stack */ + + extern int SLang_push_malloced_string(char *); + /* The normal SLang_push_string pushes an slstring. This one converts + * a normally malloced string to an slstring, and then frees the + * malloced string. So, do NOT use the malloced string after calling + * this routine because it will be freed! The routine returns -1 upon + * error, but the string will be freed. + */ + +extern int SLang_push_null (void); +extern int SLang_pop_null (void); + +extern int SLang_push_value (unsigned char type, VOID_STAR); +extern int SLang_pop_value (unsigned char type, VOID_STAR); +extern void SLang_free_value (unsigned char type, VOID_STAR); + +typedef struct _SLang_Object_Type SLang_Any_Type; + +extern int SLang_pop_anytype (SLang_Any_Type **); +extern int SLang_push_anytype (SLang_Any_Type *); +extern void SLang_free_anytype (SLang_Any_Type *); + +#ifdef _SLANG_SOURCE_ +typedef struct _SLang_Ref_Type SLang_Ref_Type; +#else +typedef int SLang_Ref_Type; +#endif + +extern int SLang_pop_ref (SLang_Ref_Type **); +extern void SLang_free_ref (SLang_Ref_Type *); +extern int SLang_assign_to_ref (SLang_Ref_Type *, unsigned char, VOID_STAR); +extern SLang_Name_Type *SLang_pop_function (void); +extern SLang_Name_Type *SLang_get_fun_from_ref (SLang_Ref_Type *); +extern void SLang_free_function (SLang_Name_Type *f); + + extern int SLang_is_defined(char *); + /* Return non-zero is p1 is defined otherwise returns 0. */ + + extern int SLang_run_hooks(char *, unsigned int, ...); + /* calls S-Lang function p1 pushing p2 strings in the variable argument + * list onto the stack first. + * Returns -1 upon error, 1 if hooks exists and it ran, + * or 0 if hook does not exist. Thus it returns non-zero is hook was called. + */ + +/* These functions return 1 if the indicated function exists and the function + * runs without error. If the function does not exist, the function returns + * 0. Otherwise -1 is returned with SLang_Error set appropriately. + */ +extern int SLexecute_function (SLang_Name_Type *); +extern int SLang_execute_function(char *); + + +extern int SLang_end_arg_list (void); +extern int SLang_start_arg_list (void); + +extern void SLang_verror (int, char *, ...); + +extern void SLang_doerror(char *); + /* set SLang_Error and display p1 as error message */ + +extern int SLang_add_intrinsic_array (char *, /* name */ + unsigned char, /* type */ + int, /* readonly */ + VOID_STAR, /* data */ + unsigned int, ...); /* num dims */ + +extern int SLextract_list_element (char *, unsigned int, char, + char *, unsigned int); + +extern void SLexpand_escaped_string (register char *, register char *, + register char *); + +extern SLang_Name_Type *SLang_get_function (char *); +extern void SLang_release_function (SLang_Name_Type *); + +extern int SLreverse_stack (int); +extern int SLroll_stack (int); +/* If argument p is positive, the top p objects on the stack are rolled + * up. If negative, the stack is rolled down. + */ +extern int SLdup_n (int n); +/* Duplicate top n elements of stack */ + +extern int SLang_peek_at_stack1 (void); +extern int SLang_peek_at_stack (void); +/* Returns type of next object on stack-- -1 upon stack underflow. */ +extern void SLmake_lut (unsigned char *, unsigned char *, unsigned char); + + extern int SLang_guess_type (char *); + +extern int SLstruct_create_struct (unsigned int, + char **, + unsigned char *, + VOID_STAR *); + +/*}}}*/ + +/*{{{ Misc Functions */ + +/* This is an interface to atexit */ +extern int SLang_add_cleanup_function (void (*)(void)); + +extern char *SLmake_string (char *); +extern char *SLmake_nstring (char *, unsigned int); +/* Returns a null terminated string made from the first n characters of the + * string. + */ + +/* The string created by this routine must be freed by SLang_free_slstring + * and nothing else!! Also these strings must not be modified. Use + * SLmake_string if you intend to modify them!! + */ +extern char *SLang_create_nslstring (char *, unsigned int); +extern char *SLang_create_slstring (char *); +extern void SLang_free_slstring (char *); /* handles NULL */ +extern int SLang_pop_slstring (char **); /* free with SLang_free_slstring */ +extern char *SLang_concat_slstrings (char *a, char *b); +extern char *SLang_create_static_slstring (char *); /* adds a string that will not get deleted */ +extern void SLstring_dump_stats (void); + +/* Binary strings */ +/* The binary string is an opaque type. Use the SLbstring_get_pointer function + * to get a pointer and length. + */ +typedef struct _SLang_BString_Type SLang_BString_Type; +extern unsigned char *SLbstring_get_pointer (SLang_BString_Type *, unsigned int *); + +extern SLang_BString_Type *SLbstring_dup (SLang_BString_Type *); +extern SLang_BString_Type *SLbstring_create (unsigned char *, unsigned int); + +/* The create_malloced function used the first argument which is assumed + * to be a pointer to a len + 1 malloced string. The extra byte is for + * \0 termination. + */ +extern SLang_BString_Type *SLbstring_create_malloced (unsigned char *, unsigned int, int); + +/* Create a bstring from an slstring */ +extern SLang_BString_Type *SLbstring_create_slstring (char *); + +extern void SLbstring_free (SLang_BString_Type *); +extern int SLang_pop_bstring (SLang_BString_Type **); +extern int SLang_push_bstring (SLang_BString_Type *); + +extern char *SLmalloc (unsigned int); +extern char *SLcalloc (unsigned int, unsigned int); +extern void SLfree(char *); /* This function handles NULL */ +extern char *SLrealloc (char *, unsigned int); + +extern char *SLcurrent_time_string (void); + +extern int SLatoi(unsigned char *); +extern long SLatol (unsigned char *); +extern unsigned long SLatoul (unsigned char *); + +extern int SLang_pop_fileptr (SLang_MMT_Type **, FILE **); +extern char *SLang_get_name_from_fileptr (SLang_MMT_Type *); + +typedef struct _SLFile_FD_Type SLFile_FD_Type; +extern SLFile_FD_Type *SLfile_create_fd (char *, int); +extern void SLfile_free_fd (SLFile_FD_Type *); +extern int SLfile_push_fd (SLFile_FD_Type *); +extern int SLfile_pop_fd (SLFile_FD_Type **); +extern int SLfile_get_fd (SLFile_FD_Type *, int *); +extern SLFile_FD_Type *SLfile_dup_fd (SLFile_FD_Type *f0); +extern int SLang_init_posix_io (void); + +typedef double (*SLang_To_Double_Fun_Type)(VOID_STAR); +extern SLang_To_Double_Fun_Type SLarith_get_to_double_fun (unsigned char, unsigned int *); + +extern int SLang_set_argc_argv (int, char **); + +/*}}}*/ + +/*{{{ SLang getkey interface Functions */ + +#ifdef REAL_UNIX_SYSTEM +extern int SLang_TT_Baud_Rate; +extern int SLang_TT_Read_FD; +#endif + +extern int SLang_init_tty (int, int, int); +/* Initializes the tty for single character input. If the first parameter *p1 + * is in the range 0-255, it will be used for the abort character; + * otherwise, (unix only) if it is -1, the abort character will be the one + * used by the terminal. If the second parameter p2 is non-zero, flow + * control is enabled. If the last parmeter p3 is zero, output processing + * is NOT turned on. A value of zero is required for the screen management + * routines. Returns 0 upon success. In addition, if SLang_TT_Baud_Rate == + * 0 when this function is called, SLang will attempt to determine the + * terminals baud rate. As far as the SLang library is concerned, if + * SLang_TT_Baud_Rate is less than or equal to zero, the baud rate is + * effectively infinite. + */ + +extern void SLang_reset_tty (void); +/* Resets tty to what it was prior to a call to SLang_init_tty */ +#ifdef REAL_UNIX_SYSTEM +extern void SLtty_set_suspend_state (int); + /* If non-zero argument, terminal driver will be told to react to the + * suspend character. If 0, it will not. + */ +extern int (*SLang_getkey_intr_hook) (void); +#endif + +#define SLANG_GETKEY_ERROR 0xFFFF +extern unsigned int SLang_getkey (void); +/* reads a single key from the tty. If the read fails, 0xFFFF is returned. */ + +#ifdef IBMPC_SYSTEM +extern int SLgetkey_map_to_ansi (int); +#endif + +extern int SLang_ungetkey_string (unsigned char *, unsigned int); +extern int SLang_buffer_keystring (unsigned char *, unsigned int); +extern int SLang_ungetkey (unsigned char); +extern void SLang_flush_input (void); +extern int SLang_input_pending (int); +extern int SLang_Abort_Char; +/* The value of the character (0-255) used to trigger SIGINT */ +extern int SLang_Ignore_User_Abort; +/* If non-zero, pressing the abort character will not result in USER_BREAK + * SLang_Error. */ + +extern int SLang_set_abort_signal (void (*)(int)); +/* If SIGINT is generated, the function p1 will be called. If p1 is NULL + * the SLang_default signal handler is called. This sets SLang_Error to + * USER_BREAK. I suspect most users will simply want to pass NULL. + */ +extern unsigned int SLang_Input_Buffer_Len; + +extern volatile int SLKeyBoard_Quit; + +#ifdef VMS +/* If this function returns -1, ^Y will be added to input buffer. */ +extern int (*SLtty_VMS_Ctrl_Y_Hook) (void); +#endif +/*}}}*/ + +/*{{{ SLang Keymap routines */ + +typedef struct SLKeymap_Function_Type +{ + char *name; + int (*f)(void); +} +SLKeymap_Function_Type; + +#define SLANG_MAX_KEYMAP_KEY_SEQ 14 +typedef struct SLang_Key_Type +{ + struct SLang_Key_Type *next; + union + { + char *s; + FVOID_STAR f; + unsigned int keysym; + } + f; + unsigned char type; /* type of function */ +#define SLKEY_F_INTERPRET 0x01 +#define SLKEY_F_INTRINSIC 0x02 +#define SLKEY_F_KEYSYM 0x03 + unsigned char str[SLANG_MAX_KEYMAP_KEY_SEQ + 1];/* key sequence */ +} +SLang_Key_Type; + +typedef struct SLKeyMap_List_Type +{ + char *name; /* hashed string */ + SLang_Key_Type *keymap; + SLKeymap_Function_Type *functions; /* intrinsic functions */ +} +SLKeyMap_List_Type; + +/* This is arbitrary but I have got to start somewhere */ +#define SLANG_MAX_KEYMAPS 30 +extern SLKeyMap_List_Type SLKeyMap_List[SLANG_MAX_KEYMAPS]; + +extern char *SLang_process_keystring(char *); + +extern int SLkm_define_key (char *, FVOID_STAR, SLKeyMap_List_Type *); + +extern int SLang_define_key(char *, char *, SLKeyMap_List_Type *); +/* Like define_key1 except that p2 is a string that is to be associated with + * a function in the functions field of p3. This routine calls define_key1. + */ + +extern int SLkm_define_keysym (char *, unsigned int, SLKeyMap_List_Type *); + +extern void SLang_undefine_key(char *, SLKeyMap_List_Type *); + +extern SLKeyMap_List_Type *SLang_create_keymap(char *, SLKeyMap_List_Type *); +/* create and returns a pointer to a new keymap named p1 created by copying + * keymap p2. If p2 is NULL, it is up to the calling routine to initialize + * the keymap. + */ + +extern char *SLang_make_keystring(unsigned char *); + +extern SLang_Key_Type *SLang_do_key(SLKeyMap_List_Type *, int (*)(void)); +/* read a key using keymap p1 with getkey function p2 */ + +extern + FVOID_STAR + SLang_find_key_function(char *, SLKeyMap_List_Type *); + +extern SLKeyMap_List_Type *SLang_find_keymap(char *); + +extern int SLang_Last_Key_Char; +extern int SLang_Key_TimeOut_Flag; + +/*}}}*/ + +/*{{{ SLang Readline Interface */ + +typedef struct SLang_Read_Line_Type +{ + struct SLang_Read_Line_Type *prev, *next; + unsigned char *buf; + int buf_len; /* number of chars in the buffer */ + int num; /* num and misc are application specific*/ + int misc; +} SLang_Read_Line_Type; + +/* Maximum size of display */ +#define SLRL_DISPLAY_BUFFER_SIZE 256 + +typedef struct +{ + SLang_Read_Line_Type *root, *tail, *last; + unsigned char *buf; /* edit buffer */ + int buf_len; /* sizeof buffer */ + int point; /* current editing point */ + int tab; /* tab width */ + int len; /* current line size */ + + /* display variables */ + int edit_width; /* length of display field */ + int curs_pos; /* current column */ + int start_column; /* column offset of display */ + int dhscroll; /* amount to use for horiz scroll */ + char *prompt; + + FVOID_STAR last_fun; /* last function executed by rl */ + + /* These two contain an image of what is on the display */ + unsigned char upd_buf1[SLRL_DISPLAY_BUFFER_SIZE]; + unsigned char upd_buf2[SLRL_DISPLAY_BUFFER_SIZE]; + unsigned char *old_upd, *new_upd; /* pointers to previous two buffers */ + int new_upd_len, old_upd_len; /* length of output buffers */ + + SLKeyMap_List_Type *keymap; + + /* tty variables */ + unsigned int flags; /* */ +#define SL_RLINE_NO_ECHO 1 +#define SL_RLINE_USE_ANSI 2 +#define SL_RLINE_BLINK_MATCH 4 + unsigned int (*getkey)(void); /* getkey function -- required */ + void (*tt_goto_column)(int); + void (*tt_insert)(char); + void (*update_hook)(unsigned char *, int, int); + /* The update hook is called with a pointer to a buffer p1 that contains + * an image of what the update hook is suppoed to produce. The length + * of the buffer is p2 and after the update, the cursor is to be placed + * in column p3. + */ + /* This function is only called when blinking matches */ + int (*input_pending)(int); + unsigned long reserved[4]; +} SLang_RLine_Info_Type; + +extern int SLang_RL_EOF_Char; + +extern SLang_Read_Line_Type * SLang_rline_save_line (SLang_RLine_Info_Type *); +extern int SLang_init_readline (SLang_RLine_Info_Type *); +extern int SLang_read_line (SLang_RLine_Info_Type *); +extern int SLang_rline_insert (char *); +extern void SLrline_redraw (SLang_RLine_Info_Type *); +extern int SLang_Rline_Quit; + +/*}}}*/ + +/*{{{ Low Level Screen Output Interface */ + +extern unsigned long SLtt_Num_Chars_Output; +extern int SLtt_Baud_Rate; + +typedef unsigned long SLtt_Char_Type; + +#define SLTT_BOLD_MASK 0x01000000UL +#define SLTT_BLINK_MASK 0x02000000UL +#define SLTT_ULINE_MASK 0x04000000UL +#define SLTT_REV_MASK 0x08000000UL +#define SLTT_ALTC_MASK 0x10000000UL + +extern int SLtt_Screen_Rows; +extern int SLtt_Screen_Cols; +extern int SLtt_Term_Cannot_Insert; +extern int SLtt_Term_Cannot_Scroll; +extern int SLtt_Use_Ansi_Colors; +extern int SLtt_Ignore_Beep; +#if defined(REAL_UNIX_SYSTEM) +extern int SLtt_Force_Keypad_Init; +extern int SLang_TT_Write_FD; +#endif + +#ifndef IBMPC_SYSTEM +extern char *SLtt_Graphics_Char_Pairs; +#endif + +#ifndef __GO32__ +#if defined(VMS) || defined(REAL_UNIX_SYSTEM) +extern int SLtt_Blink_Mode; +extern int SLtt_Use_Blink_For_ACS; +extern int SLtt_Newline_Ok; +extern int SLtt_Has_Alt_Charset; +extern int SLtt_Has_Status_Line; /* if 0, NO. If > 0, YES, IF -1, ?? */ +# ifndef VMS +extern int SLtt_Try_Termcap; +# endif +#endif +#endif + +#if defined(IBMPC_SYSTEM) +extern int SLtt_Msdos_Cheap_Video; +#endif + +typedef unsigned short SLsmg_Char_Type; +#define SLSMG_EXTRACT_CHAR(x) ((x) & 0xFF) +#define SLSMG_EXTRACT_COLOR(x) (((x)>>8)&0xFF) +#define SLSMG_BUILD_CHAR(ch,color) (((SLsmg_Char_Type)(unsigned char)(ch))|((color)<<8)) + +extern int SLtt_flush_output (void); +extern void SLtt_set_scroll_region(int, int); +extern void SLtt_reset_scroll_region(void); +extern void SLtt_reverse_video (int); +extern void SLtt_bold_video (void); +extern void SLtt_begin_insert(void); +extern void SLtt_end_insert(void); +extern void SLtt_del_eol(void); +extern void SLtt_goto_rc (int, int); +extern void SLtt_delete_nlines(int); +extern void SLtt_delete_char(void); +extern void SLtt_erase_line(void); +extern void SLtt_normal_video(void); +extern void SLtt_cls(void); +extern void SLtt_beep(void); +extern void SLtt_reverse_index(int); +extern void SLtt_smart_puts(SLsmg_Char_Type *, SLsmg_Char_Type *, int, int); +extern void SLtt_write_string (char *); +extern void SLtt_putchar(char); +extern int SLtt_init_video (void); +extern int SLtt_reset_video (void); +extern void SLtt_get_terminfo(void); +extern void SLtt_get_screen_size (void); +extern int SLtt_set_cursor_visibility (int); + +extern int SLtt_set_mouse_mode (int, int); + +#if defined(VMS) || defined(REAL_UNIX_SYSTEM) +extern int SLtt_initialize (char *); +extern void SLtt_enable_cursor_keys(void); +extern void SLtt_set_term_vtxxx(int *); +extern void SLtt_set_color_esc (int, char *); +extern void SLtt_wide_width(void); +extern void SLtt_narrow_width(void); +extern void SLtt_set_alt_char_set (int); +extern int SLtt_write_to_status_line (char *, int); +extern void SLtt_disable_status_line (void); +# ifdef REAL_UNIX_SYSTEM +/* These are termcap/terminfo routines that assume SLtt_initialize has + * been called. + */ +extern char *SLtt_tgetstr (char *); +extern int SLtt_tgetnum (char *); +extern int SLtt_tgetflag (char *); + +/* The following are terminfo-only routines -- these prototypes will change + * in V2.x. + */ +extern char *SLtt_tigetent (char *); +extern char *SLtt_tigetstr (char *, char **); +extern int SLtt_tigetnum (char *, char **); +# endif +#endif + +extern SLtt_Char_Type SLtt_get_color_object (int); +extern void SLtt_set_color_object (int, SLtt_Char_Type); +extern void SLtt_set_color (int, char *, char *, char *); +extern void SLtt_set_mono (int, char *, SLtt_Char_Type); +extern void SLtt_add_color_attribute (int, SLtt_Char_Type); +extern void SLtt_set_color_fgbg (int, SLtt_Char_Type, SLtt_Char_Type); + +/*}}}*/ + +/*{{{ SLang Preprocessor Interface */ + +typedef struct +{ + int this_level; + int exec_level; + int prev_exec_level; + char preprocess_char; + char comment_char; + unsigned char flags; +#define SLPREP_BLANK_LINES_OK 1 +#define SLPREP_COMMENT_LINES_OK 2 +} +SLPreprocess_Type; + +extern int SLprep_open_prep (SLPreprocess_Type *); +extern void SLprep_close_prep (SLPreprocess_Type *); +extern int SLprep_line_ok (char *, SLPreprocess_Type *); + extern int SLdefine_for_ifdef (char *); + /* Adds a string to the SLang #ifdef preparsing defines. SLang already + defines MSDOS, UNIX, and VMS on the appropriate system. */ +extern int (*SLprep_exists_hook) (char *, char); + +/*}}}*/ + +/*{{{ SLsmg Screen Management Functions */ + +extern void SLsmg_fill_region (int, int, unsigned int, unsigned int, unsigned char); +extern void SLsmg_set_char_set (int); +#ifndef IBMPC_SYSTEM +extern int SLsmg_Scroll_Hash_Border; +#endif +extern int SLsmg_suspend_smg (void); +extern int SLsmg_resume_smg (void); +extern void SLsmg_erase_eol (void); +extern void SLsmg_gotorc (int, int); +extern void SLsmg_erase_eos (void); +extern void SLsmg_reverse_video (void); +extern void SLsmg_set_color (int); +extern void SLsmg_normal_video (void); +extern void SLsmg_printf (char *, ...); +extern void SLsmg_vprintf (char *, va_list); +extern void SLsmg_write_string (char *); +extern void SLsmg_write_nstring (char *, unsigned int); +extern void SLsmg_write_char (char); +extern void SLsmg_write_nchars (char *, unsigned int); +extern void SLsmg_write_wrapped_string (char *, int, int, unsigned int, unsigned int, int); +extern void SLsmg_cls (void); +extern void SLsmg_refresh (void); +extern void SLsmg_touch_lines (int, unsigned int); +extern void SLsmg_touch_screen (void); +extern int SLsmg_init_smg (void); +extern int SLsmg_reinit_smg (void); +extern void SLsmg_reset_smg (void); +extern SLsmg_Char_Type SLsmg_char_at(void); +extern void SLsmg_set_screen_start (int *, int *); +extern void SLsmg_draw_hline (unsigned int); +extern void SLsmg_draw_vline (int); +extern void SLsmg_draw_object (int, int, unsigned char); +extern void SLsmg_draw_box (int, int, unsigned int, unsigned int); +extern int SLsmg_get_column(void); +extern int SLsmg_get_row(void); +extern void SLsmg_forward (int); +extern void SLsmg_write_color_chars (SLsmg_Char_Type *, unsigned int); +extern unsigned int SLsmg_read_raw (SLsmg_Char_Type *, unsigned int); +extern unsigned int SLsmg_write_raw (SLsmg_Char_Type *, unsigned int); +extern void SLsmg_set_color_in_region (int, int, int, unsigned int, unsigned int); +extern int SLsmg_Display_Eight_Bit; +extern int SLsmg_Tab_Width; + +#define SLSMG_NEWLINE_IGNORED 0 /* default */ +#define SLSMG_NEWLINE_MOVES 1 /* moves to next line, column 0 */ +#define SLSMG_NEWLINE_SCROLLS 2 /* moves but scrolls at bottom of screen */ +#define SLSMG_NEWLINE_PRINTABLE 3 /* prints as ^J */ +extern int SLsmg_Newline_Behavior; + +extern int SLsmg_Backspace_Moves; + +#ifdef IBMPC_SYSTEM +# define SLSMG_HLINE_CHAR 0xC4 +# define SLSMG_VLINE_CHAR 0xB3 +# define SLSMG_ULCORN_CHAR 0xDA +# define SLSMG_URCORN_CHAR 0xBF +# define SLSMG_LLCORN_CHAR 0xC0 +# define SLSMG_LRCORN_CHAR 0xD9 +# define SLSMG_RTEE_CHAR 0xB4 +# define SLSMG_LTEE_CHAR 0xC3 +# define SLSMG_UTEE_CHAR 0xC2 +# define SLSMG_DTEE_CHAR 0xC1 +# define SLSMG_PLUS_CHAR 0xC5 +/* There are several to choose from: 0xB0, 0xB1, and 0xB2 */ +# define SLSMG_CKBRD_CHAR 0xB0 +# define SLSMG_DIAMOND_CHAR 0x04 +# define SLSMG_DEGREE_CHAR 0xF8 +# define SLSMG_PLMINUS_CHAR 0xF1 +# define SLSMG_BULLET_CHAR 0xF9 +# define SLSMG_LARROW_CHAR 0x1B +# define SLSMG_RARROW_CHAR 0x1A +# define SLSMG_DARROW_CHAR 0x19 +# define SLSMG_UARROW_CHAR 0x18 +# define SLSMG_BOARD_CHAR 0xB2 +# define SLSMG_BLOCK_CHAR 0xDB +#else +# if defined(AMIGA) +# define SLSMG_HLINE_CHAR '-' +# define SLSMG_VLINE_CHAR '|' +# define SLSMG_ULCORN_CHAR '+' +# define SLSMG_URCORN_CHAR '+' +# define SLSMG_LLCORN_CHAR '+' +# define SLSMG_LRCORN_CHAR '+' +# define SLSMG_CKBRD_CHAR '#' +# define SLSMG_RTEE_CHAR '+' +# define SLSMG_LTEE_CHAR '+' +# define SLSMG_UTEE_CHAR '+' +# define SLSMG_DTEE_CHAR '+' +# define SLSMG_PLUS_CHAR '+' +# define SLSMG_DIAMOND_CHAR '+' +# define SLSMG_DEGREE_CHAR '\\' +# define SLSMG_PLMINUS_CHAR '#' +# define SLSMG_BULLET_CHAR 'o' +# define SLSMG_LARROW_CHAR '<' +# define SLSMG_RARROW_CHAR '>' +# define SLSMG_DARROW_CHAR 'v' +# define SLSMG_UARROW_CHAR '^' +# define SLSMG_BOARD_CHAR '#' +# define SLSMG_BLOCK_CHAR '#' +# else +# define SLSMG_HLINE_CHAR 'q' +# define SLSMG_VLINE_CHAR 'x' +# define SLSMG_ULCORN_CHAR 'l' +# define SLSMG_URCORN_CHAR 'k' +# define SLSMG_LLCORN_CHAR 'm' +# define SLSMG_LRCORN_CHAR 'j' +# define SLSMG_CKBRD_CHAR 'a' +# define SLSMG_RTEE_CHAR 'u' +# define SLSMG_LTEE_CHAR 't' +# define SLSMG_UTEE_CHAR 'w' +# define SLSMG_DTEE_CHAR 'v' +# define SLSMG_PLUS_CHAR 'n' +# define SLSMG_DIAMOND_CHAR '`' +# define SLSMG_DEGREE_CHAR 'f' +# define SLSMG_PLMINUS_CHAR 'g' +# define SLSMG_BULLET_CHAR '~' +# define SLSMG_LARROW_CHAR ',' +# define SLSMG_RARROW_CHAR '+' +# define SLSMG_DARROW_CHAR '.' +# define SLSMG_UARROW_CHAR '-' +# define SLSMG_BOARD_CHAR 'h' +# define SLSMG_BLOCK_CHAR '0' +# endif /* AMIGA */ +#endif /* IBMPC_SYSTEM */ + +#ifndef IBMPC_SYSTEM +# define SLSMG_COLOR_BLACK 0x000000 +# define SLSMG_COLOR_RED 0x000001 +# define SLSMG_COLOR_GREEN 0x000002 +# define SLSMG_COLOR_BROWN 0x000003 +# define SLSMG_COLOR_BLUE 0x000004 +# define SLSMG_COLOR_MAGENTA 0x000005 +# define SLSMG_COLOR_CYAN 0x000006 +# define SLSMG_COLOR_LGRAY 0x000007 +# define SLSMG_COLOR_GRAY 0x000008 +# define SLSMG_COLOR_BRIGHT_RED 0x000009 +# define SLSMG_COLOR_BRIGHT_GREEN 0x00000A +# define SLSMG_COLOR_BRIGHT_BROWN 0x00000B +# define SLSMG_COLOR_BRIGHT_BLUE 0x00000C +# define SLSMG_COLOR_BRIGHT_CYAN 0x00000D +# define SLSMG_COLOR_BRIGHT_MAGENTA 0x00000E +# define SLSMG_COLOR_BRIGHT_WHITE 0x00000F +#endif + +typedef struct +{ + void (*tt_normal_video)(void); + void (*tt_set_scroll_region)(int, int); + void (*tt_goto_rc)(int, int); + void (*tt_reverse_index)(int); + void (*tt_reset_scroll_region)(void); + void (*tt_delete_nlines)(int); + void (*tt_cls) (void); + void (*tt_del_eol) (void); + void (*tt_smart_puts) (SLsmg_Char_Type *, SLsmg_Char_Type *, int, int); + int (*tt_flush_output) (void); + int (*tt_reset_video) (void); + int (*tt_init_video) (void); + + int *tt_screen_rows; + int *tt_screen_cols; + + int *tt_term_cannot_scroll; + int *tt_has_alt_charset; + int *tt_use_blink_for_acs; + char **tt_graphic_char_pairs; + + long reserved[4]; +} +SLsmg_Term_Type; +extern void SLsmg_set_terminal_info (SLsmg_Term_Type *); + +/*}}}*/ + +/*{{{ SLang Keypad Interface */ + +#define SL_KEY_ERR 0xFFFF + +#define SL_KEY_UP 0x101 +#define SL_KEY_DOWN 0x102 +#define SL_KEY_LEFT 0x103 +#define SL_KEY_RIGHT 0x104 +#define SL_KEY_PPAGE 0x105 +#define SL_KEY_NPAGE 0x106 +#define SL_KEY_HOME 0x107 +#define SL_KEY_END 0x108 +#define SL_KEY_A1 0x109 +#define SL_KEY_A3 0x10A +#define SL_KEY_B2 0x10B +#define SL_KEY_C1 0x10C +#define SL_KEY_C3 0x10D +#define SL_KEY_REDO 0x10E +#define SL_KEY_UNDO 0x10F +#define SL_KEY_BACKSPACE 0x110 +#define SL_KEY_ENTER 0x111 +#define SL_KEY_IC 0x112 +#define SL_KEY_DELETE 0x113 + +#define SL_KEY_F0 0x200 +#define SL_KEY_F(X) (SL_KEY_F0 + X) + +/* I do not intend to use keysymps > 0x1000. Applications can use those. */ +/* Returns 0 upon success or -1 upon error. */ +extern int SLkp_define_keysym (char *, unsigned int); + +/* This function must be called AFTER SLtt_get_terminfo and not before. */ +extern int SLkp_init (void); + +/* This function uses SLang_getkey and assumes that what ever initialization + * is required for SLang_getkey has been performed. + */ +extern int SLkp_getkey (void); + +/*}}}*/ + +/*{{{ SLang Scroll Interface */ + +typedef struct _SLscroll_Type +{ + struct _SLscroll_Type *next; + struct _SLscroll_Type *prev; + unsigned int flags; +} +SLscroll_Type; + +typedef struct +{ + unsigned int flags; + SLscroll_Type *top_window_line; /* list element at top of window */ + SLscroll_Type *bot_window_line; /* list element at bottom of window */ + SLscroll_Type *current_line; /* current list element */ + SLscroll_Type *lines; /* first list element */ + unsigned int nrows; /* number of rows in window */ + unsigned int hidden_mask; /* applied to flags in SLscroll_Type */ + unsigned int line_num; /* current line number (visible) */ + unsigned int num_lines; /* total number of lines (visible) */ + unsigned int window_row; /* row of current_line in window */ + unsigned int border; /* number of rows that form scroll border */ + int cannot_scroll; /* should window scroll or recenter */ +} +SLscroll_Window_Type; + +extern int SLscroll_find_top (SLscroll_Window_Type *); +extern int SLscroll_find_line_num (SLscroll_Window_Type *); +extern unsigned int SLscroll_next_n (SLscroll_Window_Type *, unsigned int); +extern unsigned int SLscroll_prev_n (SLscroll_Window_Type *, unsigned int); +extern int SLscroll_pageup (SLscroll_Window_Type *); +extern int SLscroll_pagedown (SLscroll_Window_Type *); + +/*}}}*/ + +/*{{{ Signal Routines */ + +typedef void SLSig_Fun_Type (int); +extern SLSig_Fun_Type *SLsignal (int, SLSig_Fun_Type *); +extern SLSig_Fun_Type *SLsignal_intr (int, SLSig_Fun_Type *); +extern int SLsig_block_signals (void); +extern int SLsig_unblock_signals (void); +extern int SLsystem (char *); + +extern char *SLerrno_strerror (int); +extern int SLerrno_set_errno (int); + +/*}}}*/ + +/*{{{ Interpreter Macro Definitions */ + +/* The definitions here are for objects that may be on the run-time stack. + * They are actually sub_types of literal and data main_types. The actual + * numbers are historical. + */ +#define SLANG_UNDEFINED_TYPE 0x00 /* MUST be 0 */ +#define SLANG_VOID_TYPE 0x01 /* also matches ANY type */ +#define SLANG_INT_TYPE 0x02 +#define SLANG_DOUBLE_TYPE 0x03 +#define SLANG_CHAR_TYPE 0x04 +#define SLANG_INTP_TYPE 0x05 +/* An object of SLANG_INTP_TYPE should never really occur on the stack. Rather, + * the integer to which it refers will be there instead. It is defined here + * because it is a valid type for MAKE_VARIABLE. + */ +#define SLANG_REF_TYPE 0x06 +/* SLANG_REF_TYPE refers to an object on the stack that is a pointer (reference) + * to some other object. + */ +#define SLANG_COMPLEX_TYPE 0x07 +#define SLANG_NULL_TYPE 0x08 +#define SLANG_UCHAR_TYPE 0x09 +#define SLANG_SHORT_TYPE 0x0A +#define SLANG_USHORT_TYPE 0x0B +#define SLANG_UINT_TYPE 0x0C +#define SLANG_LONG_TYPE 0x0D +#define SLANG_ULONG_TYPE 0x0E +#define SLANG_STRING_TYPE 0x0F +#define SLANG_FLOAT_TYPE 0x10 +#define SLANG_STRUCT_TYPE 0x11 +#define SLANG_ISTRUCT_TYPE 0x12 +#define SLANG_ARRAY_TYPE 0x20 +#define SLANG_DATATYPE_TYPE 0x21 +#define SLANG_FILE_PTR_TYPE 0x22 +#define SLANG_ASSOC_TYPE 0x23 +#define SLANG_ANY_TYPE 0x24 +#define SLANG_BSTRING_TYPE 0x25 +#define SLANG_FILE_FD_TYPE 0x26 + +/* Compatibility */ +#ifdef FLOAT_TYPE +# undef FLOAT_TYPE +#endif +#define VOID_TYPE SLANG_VOID_TYPE +#define INT_TYPE SLANG_INT_TYPE +#define INTP_TYPE SLANG_INTP_TYPE +#define FLOAT_TYPE SLANG_DOUBLE_TYPE +#define ARRAY_TYPE SLANG_ARRAY_TYPE +#define CHAR_TYPE SLANG_CHAR_TYPE +#define STRING_TYPE SLANG_STRING_TYPE + +/* I am reserving values greater than or equal to 128 for user applications. + * The first 127 are reserved for S-Lang. + */ + +/* Binary and Unary Subtypes */ +/* Since the application can define new types and can overload the binary + * and unary operators, these definitions must be present in this file. + * The current implementation assumes both unary and binary are distinct. + */ +#define SLANG_PLUS 0x01 +#define SLANG_MINUS 0x02 +#define SLANG_TIMES 0x03 +#define SLANG_DIVIDE 0x04 +#define SLANG_EQ 0x05 +#define SLANG_NE 0x06 +#define SLANG_GT 0x07 +#define SLANG_GE 0x08 +#define SLANG_LT 0x09 +#define SLANG_LE 0x0A +#define SLANG_POW 0x0B +#define SLANG_OR 0x0C +#define SLANG_AND 0x0D +#define SLANG_BAND 0x0E +#define SLANG_BOR 0x0F +#define SLANG_BXOR 0x10 +#define SLANG_SHL 0x11 +#define SLANG_SHR 0x12 +#define SLANG_MOD 0x13 + +/* UNARY subtypes (may be overloaded) */ +#define SLANG_PLUSPLUS 0x20 +#define SLANG_MINUSMINUS 0x21 +#define SLANG_ABS 0x22 +#define SLANG_SIGN 0x23 +#define SLANG_SQR 0x24 +#define SLANG_MUL2 0x25 +#define SLANG_CHS 0x26 +#define SLANG_NOT 0x27 +#define SLANG_BNOT 0x28 + +extern char *SLang_Error_Message; + +int SLadd_intrinsic_variable (char *, VOID_STAR, unsigned char, int); +int SLadd_intrinsic_function (char *, FVOID_STAR, unsigned char, unsigned int,...); + +int SLns_add_intrinsic_variable (SLang_NameSpace_Type *, char *, VOID_STAR, unsigned char, int); +int SLns_add_intrinsic_function (SLang_NameSpace_Type *, char *, FVOID_STAR, unsigned char, unsigned int,...); + +extern void SLadd_at_handler (long *, char *); + +#define MAKE_INTRINSIC_N(n,f,out,in,a1,a2,a3,a4,a5,a6,a7) \ + {(n), NULL, SLANG_INTRINSIC, (FVOID_STAR) (f), \ + {a1,a2,a3,a4,a5,a6,a7}, (in), (out)} + +#define MAKE_INTRINSIC_7(n,f,out,a1,a2,a3,a4,a5,a6,a7) \ + MAKE_INTRINSIC_N(n,f,out,7,a1,a2,a3,a4,a5,a6,a7) +#define MAKE_INTRINSIC_6(n,f,out,a1,a2,a3,a4,a5,a6) \ + MAKE_INTRINSIC_N(n,f,out,6,a1,a2,a3,a4,a5,a6,0) +#define MAKE_INTRINSIC_5(n,f,out,a1,a2,a3,a4,a5) \ + MAKE_INTRINSIC_N(n,f,out,5,a1,a2,a3,a4,a5,0,0) +#define MAKE_INTRINSIC_4(n,f,out,a1,a2,a3,a4) \ + MAKE_INTRINSIC_N(n,f,out,4,a1,a2,a3,a4,0,0,0) +#define MAKE_INTRINSIC_3(n,f,out,a1,a2,a3) \ + MAKE_INTRINSIC_N(n,f,out,3,a1,a2,a3,0,0,0,0) +#define MAKE_INTRINSIC_2(n,f,out,a1,a2) \ + MAKE_INTRINSIC_N(n,f,out,2,a1,a2,0,0,0,0,0) +#define MAKE_INTRINSIC_1(n,f,out,a1) \ + MAKE_INTRINSIC_N(n,f,out,1,a1,0,0,0,0,0,0) +#define MAKE_INTRINSIC_0(n,f,out) \ + MAKE_INTRINSIC_N(n,f,out,0,0,0,0,0,0,0,0) + +#define MAKE_INTRINSIC_S(n,f,r) \ + MAKE_INTRINSIC_1(n,f,r,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_I(n,f,r) \ + MAKE_INTRINSIC_1(n,f,r,SLANG_INT_TYPE) + +#define MAKE_INTRINSIC_SS(n,f,r) \ + MAKE_INTRINSIC_2(n,f,r,SLANG_STRING_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_SI(n,f,r) \ + MAKE_INTRINSIC_2(n,f,r,SLANG_STRING_TYPE,SLANG_INT_TYPE) +#define MAKE_INTRINSIC_IS(n,f,r) \ + MAKE_INTRINSIC_2(n,f,r,SLANG_INT_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_II(n,f,r) \ + MAKE_INTRINSIC_2(n,f,r,SLANG_INT_TYPE,SLANG_INT_TYPE) + +#define MAKE_INTRINSIC_SSS(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_STRING_TYPE,SLANG_STRING_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_SSI(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_STRING_TYPE,SLANG_STRING_TYPE,SLANG_INT_TYPE) +#define MAKE_INTRINSIC_SIS(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_STRING_TYPE,SLANG_INT_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_SII(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_STRING_TYPE,SLANG_INT_TYPE,SLANG_INT_TYPE) +#define MAKE_INTRINSIC_ISS(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_INT_TYPE,SLANG_STRING_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_ISI(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_INT_TYPE,SLANG_STRING_TYPE,SLANG_INT_TYPE) +#define MAKE_INTRINSIC_IIS(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_INT_TYPE,SLANG_INT_TYPE,SLANG_STRING_TYPE) +#define MAKE_INTRINSIC_III(n,f,r) \ + MAKE_INTRINSIC_3(n,f,r,SLANG_INT_TYPE,SLANG_INT_TYPE,SLANG_INT_TYPE) + +#define MAKE_INTRINSIC(n, f, out, in) \ + MAKE_INTRINSIC_N(n,f,out,in,0,0,0,0,0,0,0) + +#define MAKE_VARIABLE(n, v, t, r) \ + {n, NULL, SLANG_IVARIABLE + (r), (VOID_STAR)(v), (t)} + +#define MAKE_APP_UNARY(n,op) \ + {(n), NULL, SLANG_APP_UNARY, (op)} + +#define MAKE_MATH_UNARY(n,op) \ + {(n), NULL, SLANG_MATH_UNARY, (op)} + +#define MAKE_ICONSTANT(n,val) \ + {(n),NULL, SLANG_ICONSTANT, (val)} + +#define MAKE_DCONSTANT(n,val) \ + {(n),NULL, SLANG_DCONSTANT, (val)} + +#ifndef offsetof +# define offsetof(T,F) ((unsigned int)((char *)&((T *)0L)->F - (char *)0L)) +#endif +#define MAKE_ISTRUCT_FIELD(s,f,n,t,r) {(n), offsetof(s,f), (t), (r)} + +#define SLANG_END_TABLE {NULL} +#define SLANG_END_INTRIN_FUN_TABLE MAKE_INTRINSIC_0(NULL,NULL,0) +#define SLANG_END_DCONST_TABLE MAKE_DCONSTANT(NULL,0) +#define SLANG_END_MATH_UNARY_TABLE MAKE_MATH_UNARY(NULL,0) +#define SLANG_END_INTRIN_VAR_TABLE MAKE_VARIABLE(NULL,NULL,0,0) +#define SLANG_END_ICONST_TABLE MAKE_ICONSTANT(NULL,0) +#define SLANG_END_ISTRUCT_TABLE {NULL, 0, 0, 0} + + + +/*}}}*/ + +/*{{{ Upper/Lowercase Functions */ + +extern void SLang_define_case(int *, int *); +extern void SLang_init_case_tables (void); + +extern unsigned char _SLChg_UCase_Lut[256]; +extern unsigned char _SLChg_LCase_Lut[256]; +#define UPPER_CASE(x) (_SLChg_UCase_Lut[(unsigned char) (x)]) +#define LOWER_CASE(x) (_SLChg_LCase_Lut[(unsigned char) (x)]) +#define CHANGE_CASE(x) (((x) == _SLChg_LCase_Lut[(unsigned char) (x)]) ?\ + _SLChg_UCase_Lut[(unsigned char) (x)] : _SLChg_LCase_Lut[(unsigned char) (x)]) + +/*}}}*/ + +/*{{{ Regular Expression Interface */ + +typedef struct +{ + /* These must be set by calling routine. */ + unsigned char *pat; /* regular expression pattern */ + unsigned char *buf; /* buffer for compiled regexp */ + unsigned int buf_len; /* length of buffer */ + int case_sensitive; /* 1 if match is case sensitive */ + + /* The rest are set by SLang_regexp_compile */ + + int must_match; /* 1 if line must contain substring */ + int must_match_bol; /* true if it must match beginning of line */ + unsigned char must_match_str[16]; /* 15 char null term substring */ + int osearch; /* 1 if ordinary search suffices */ + unsigned int min_length; /* minimum length the match must be */ + int beg_matches[10]; /* offset of start of \( */ + unsigned int end_matches[10]; /* length of nth submatch + * Note that the entire match corresponds + * to \0 + */ + int offset; /* offset to be added to beg_matches */ + int reserved[10]; +} SLRegexp_Type; + +extern unsigned char *SLang_regexp_match(unsigned char *, + unsigned int, + SLRegexp_Type *); + +/* Returns 0 upon success. If failure, the offset into the + * pattern is returned (start = 1). + */ +extern int SLang_regexp_compile (SLRegexp_Type *); +extern char *SLregexp_quote_string (char *, char *, unsigned int); + +/*}}}*/ + +/*{{{ SLang Command Interface */ + +struct _SLcmd_Cmd_Type; /* Pre-declaration is needed below */ +typedef struct +{ + struct _SLcmd_Cmd_Type *table; + int argc; + /* Version 2.0 needs to use a union!! */ + char **string_args; + int *int_args; + double *double_args; + unsigned char *arg_type; + unsigned long reserved[4]; +} SLcmd_Cmd_Table_Type; + +typedef struct _SLcmd_Cmd_Type +{ + int (*cmdfun)(int, SLcmd_Cmd_Table_Type *); + char *cmd; + char *arg_type; +} SLcmd_Cmd_Type; + +extern int SLcmd_execute_string (char *, SLcmd_Cmd_Table_Type *); + +/*}}}*/ + +/*{{{ SLang Search Interface */ + +typedef struct +{ + int cs; /* case sensitive */ + unsigned char key[256]; + int ind[256]; + int key_len; + int dir; +} SLsearch_Type; + +extern int SLsearch_init (char *, int, int, SLsearch_Type *); +/* This routine must first be called before any search can take place. + * The second parameter specifies the direction of the search: greater than + * zero for a forwrd search and less than zero for a backward search. The + * third parameter specifies whether the search is case sensitive or not. + * The last parameter is a pointer to a structure that is filled by this + * function and it is this structure that must be passed to SLsearch. + */ + +extern unsigned char *SLsearch (unsigned char *, unsigned char *, SLsearch_Type *); +/* To use this routine, you must first call 'SLsearch_init'. Then the first + * two parameters p1 and p2 serve to define the region over which the search + * is to take place. The third parameter is the structure that was previously + * initialized by SLsearch_init. + * + * The routine returns a pointer to the match if found otherwise it returns + * NULL. + */ + +/*}}}*/ + +/*{{{ SLang Pathname Interface */ + +/* These function return pointers to the original space */ +extern char *SLpath_basename (char *); +extern char *SLpath_extname (char *); +extern int SLpath_is_absolute_path (char *); + +/* These return malloced strings--- NOT slstrings */ +extern char *SLpath_dircat (char *, char *); +extern char *SLpath_find_file_in_path (char *, char *); +extern char *SLpath_dirname (char *); +extern int SLpath_file_exists (char *); +extern char *SLpath_pathname_sans_extname (char *); + +/*}}}*/ + +extern int SLang_set_module_load_path (char *); + +#define SLANG_MODULE(name) \ + extern int init_##name##_module_ns (char *); \ + extern void deinit_##name##_module (void) + +#if 0 +{ +#endif +#ifdef __cplusplus +} +#endif + +#endif /* _DAVIS_SLANG_H_ */ diff --git a/mdk-stage1/slang/slarith.c b/mdk-stage1/slang/slarith.c new file mode 100644 index 000000000..07ad68687 --- /dev/null +++ b/mdk-stage1/slang/slarith.c @@ -0,0 +1,1656 @@ + +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include <math.h> + +#ifdef HAVE_LOCALE_H +# include <locale.h> +#endif + +#include "slang.h" +#include "_slang.h" + +/* + * This file defines binary and unary operations on all integer types. + * Supported types include: + * + * SLANG_CHAR_TYPE (char) + * SLANG_SHORT_TYPE (short) + * SLANG_INT_TYPE (int) + * SLANG_LONG_TYPE (long) + * SLANG_FLOAT_TYPE (float) + * SLANG_DOUBLE_TYPE (double) + * + * as well as unsigned types. The result-type of an arithmentic operation + * will depend upon the data types involved. I am going to distinguish + * between the boolean operations such as `and' and `or' from the arithmetic + * operations such as `plus'. Since the result of a boolean operation is + * either 1 or 0, a boolean result will be represented by SLANG_CHAR_TYPE. + * Ordinarily I would use an integer but for arrays it makes more sense to + * use a character data type. + * + * So, the following will be assumed (`+' is any arithmetic operator) + * + * char + char = int + * char|short + short = int + * char|short|int + int = int + * char|short|int|long + long = long + * char|short|int|long|float + float = float + * char|short|int|long|float|double + double = double + * + * In the actual implementation, a brute force approach is avoided. Such + * an approach would mean defining different functions for all possible + * combinations of types. Including the unsigned types, and not including + * the complex number type, there are 10 arithmetic types and 10*10=100 + * different combinations of types. Clearly this would be too much. + * + * One approach would be to define binary functions only between operands of + * the same type and then convert types as appropriate. This would require + * just 6 such functions (int, uint, long, ulong, float, double). + * However, many conversion functions are going to be required, particularly + * since we are going to allow typecasting from one arithmetic to another. + * Since the bit pattern of signed and unsigned types are the same, and only + * the interpretation differs, there will be no functions to convert between + * signed and unsigned forms of a given type. + */ + +#define MAX_ARITHMETIC_TYPES 10 + +unsigned char _SLarith_Is_Arith_Type [256]; + +unsigned char _SLarith_Arith_Types[] = +{ + SLANG_CHAR_TYPE, + SLANG_UCHAR_TYPE, + SLANG_SHORT_TYPE, + SLANG_USHORT_TYPE, + SLANG_INT_TYPE, + SLANG_UINT_TYPE, + SLANG_LONG_TYPE, + SLANG_ULONG_TYPE, + SLANG_FLOAT_TYPE, + SLANG_DOUBLE_TYPE, + 0 +}; + +/* Here are a bunch of functions to convert from one type to another. To + * facilitate the process, a macros will be used. + */ + +#define DEFUN_1(f,from_type,to_type) \ +static void f (to_type *y, from_type *x, unsigned int n) \ +{ \ + unsigned int i; \ + for (i = 0; i < n; i++) y[i] = (to_type) x[i]; \ +} + +#define DEFUN_2(f,from_type,to_type,copy_fun) \ +static VOID_STAR f (VOID_STAR xp, unsigned int n) \ +{ \ + from_type *x; \ + to_type *y; \ + x = (from_type *) xp; \ + if (NULL == (y = (to_type *) SLmalloc (sizeof (to_type) * n))) return NULL; \ + copy_fun (y, x, n); \ + return (VOID_STAR) y; \ +} +typedef VOID_STAR (*Convert_Fun_Type)(VOID_STAR, unsigned int); + +DEFUN_1(copy_char_to_char,char,char) +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_char_to_short,char,short) +DEFUN_1(copy_char_to_ushort,char,unsigned short) +#else +# define copy_char_to_short copy_char_to_int +# define copy_char_to_ushort copy_char_to_uint +#endif +DEFUN_1(copy_char_to_int,char,int) +DEFUN_1(copy_char_to_uint,char,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_char_to_long,char,long) +DEFUN_1(copy_char_to_ulong,char,unsigned long) +#else +# define copy_char_to_long copy_char_to_int +# define copy_char_to_ulong copy_char_to_uint +#endif +DEFUN_1(copy_char_to_float,char,float) +DEFUN_1(copy_char_to_double,char,double) + +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_uchar_to_short,unsigned char,short) +DEFUN_1(copy_uchar_to_ushort,unsigned char,unsigned short) +#else +# define copy_uchar_to_short copy_uchar_to_int +# define copy_uchar_to_ushort copy_uchar_to_uint +#endif +DEFUN_1(copy_uchar_to_int,unsigned char,int) +DEFUN_1(copy_uchar_to_uint,unsigned char,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_uchar_to_long,unsigned char,long) +DEFUN_1(copy_uchar_to_ulong,unsigned char,unsigned long) +#else +# define copy_uchar_to_long copy_uchar_to_int +# define copy_uchar_to_ulong copy_uchar_to_uint +#endif +DEFUN_1(copy_uchar_to_float,unsigned char,float) +DEFUN_1(copy_uchar_to_double,unsigned char,double) + +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_short_to_char,short,char) +DEFUN_1(copy_short_to_uchar,short,unsigned char) +DEFUN_1(copy_short_to_short,short,short) +DEFUN_1(copy_short_to_int,short,int) +DEFUN_1(copy_short_to_uint,short,unsigned int) +DEFUN_1(copy_short_to_long,short,long) +DEFUN_1(copy_short_to_ulong,short,unsigned long) +DEFUN_1(copy_short_to_float,short,float) +DEFUN_1(copy_short_to_double,short,double) +DEFUN_1(copy_ushort_to_char,unsigned short,char) +DEFUN_1(copy_ushort_to_uchar,unsigned short,unsigned char) +DEFUN_1(copy_ushort_to_int,unsigned short,int) +DEFUN_1(copy_ushort_to_uint,unsigned short,unsigned int) +DEFUN_1(copy_ushort_to_long,unsigned short,long) +DEFUN_1(copy_ushort_to_ulong,unsigned short,unsigned long) +DEFUN_1(copy_ushort_to_float,unsigned short,float) +DEFUN_1(copy_ushort_to_double,unsigned short,double) +#else +# define copy_short_to_char copy_int_to_char +# define copy_short_to_uchar copy_int_to_uchar +# define copy_short_to_short copy_int_to_int +# define copy_short_to_int copy_int_to_int +# define copy_short_to_uint copy_int_to_int +# define copy_short_to_long copy_int_to_long +# define copy_short_to_ulong copy_int_to_ulong +# define copy_short_to_float copy_int_to_float +# define copy_short_to_double copy_int_to_double +# define copy_ushort_to_char copy_uint_to_char +# define copy_ushort_to_uchar copy_uint_to_uchar +# define copy_ushort_to_int copy_int_to_int +# define copy_ushort_to_uint copy_int_to_int +# define copy_ushort_to_long copy_uint_to_long +# define copy_ushort_to_ulong copy_uint_to_ulong +# define copy_ushort_to_float copy_uint_to_float +# define copy_ushort_to_double copy_uint_to_double +#endif + +DEFUN_1(copy_int_to_char,int,char) +DEFUN_1(copy_int_to_uchar,int,unsigned char) +DEFUN_1(copy_uint_to_char,unsigned int,char) +DEFUN_1(copy_uint_to_uchar,unsigned int,unsigned char) +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_int_to_short,int,short) +DEFUN_1(copy_int_to_ushort,int,unsigned short) +DEFUN_1(copy_uint_to_short,unsigned int,short) +DEFUN_1(copy_uint_to_ushort,unsigned int,unsigned short) +#else +# define copy_int_to_short copy_int_to_int +# define copy_int_to_ushort copy_int_to_int +# define copy_uint_to_short copy_int_to_int +# define copy_uint_to_ushort copy_int_to_int +#endif +DEFUN_1(copy_int_to_int,int,int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_int_to_long,int,long) +DEFUN_1(copy_int_to_ulong,int,unsigned long) +DEFUN_1(copy_uint_to_long,unsigned int,long) +DEFUN_1(copy_uint_to_ulong,unsigned int,unsigned long) +#else +# define copy_int_to_long copy_int_to_int +# define copy_int_to_ulong copy_int_to_int +# define copy_uint_to_long copy_int_to_int +# define copy_uint_to_ulong copy_int_to_int +#endif +DEFUN_1(copy_int_to_float,int,float) +DEFUN_1(copy_int_to_double,int,double) +DEFUN_1(copy_uint_to_float,unsigned int,float) +DEFUN_1(copy_uint_to_double,unsigned int,double) + +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_long_to_char,long,char) +DEFUN_1(copy_long_to_uchar,long,unsigned char) +DEFUN_1(copy_long_to_short,long,short) +DEFUN_1(copy_long_to_ushort,long,unsigned short) +DEFUN_1(copy_long_to_int,long,int) +DEFUN_1(copy_long_to_uint,long,unsigned int) +DEFUN_1(copy_long_to_long,long,long) +DEFUN_1(copy_long_to_float,long,float) +DEFUN_1(copy_long_to_double,long,double) +DEFUN_1(copy_ulong_to_char,unsigned long,char) +DEFUN_1(copy_ulong_to_uchar,unsigned long,unsigned char) +DEFUN_1(copy_ulong_to_short,unsigned long,short) +DEFUN_1(copy_ulong_to_ushort,unsigned long,unsigned short) +DEFUN_1(copy_ulong_to_int,unsigned long,int) +DEFUN_1(copy_ulong_to_uint,unsigned long,unsigned int) +DEFUN_1(copy_ulong_to_float,unsigned long,float) +DEFUN_1(copy_ulong_to_double,unsigned long,double) +#else +#define copy_long_to_char copy_int_to_char +#define copy_long_to_uchar copy_int_to_uchar +#define copy_long_to_short copy_int_to_short +#define copy_long_to_ushort copy_int_to_ushort +#define copy_long_to_int copy_int_to_int +#define copy_long_to_uint copy_int_to_int +#define copy_long_to_long copy_int_to_int +#define copy_long_to_float copy_int_to_float +#define copy_long_to_double copy_int_to_double +#define copy_ulong_to_char copy_uint_to_char +#define copy_ulong_to_uchar copy_uint_to_uchar +#define copy_ulong_to_short copy_uint_to_short +#define copy_ulong_to_ushort copy_uint_to_ushort +#define copy_ulong_to_int copy_int_to_int +#define copy_ulong_to_uint copy_int_to_int +#define copy_ulong_to_float copy_uint_to_float +#define copy_ulong_to_double copy_uint_to_double +#endif + +DEFUN_1(copy_float_to_char,float,char) +DEFUN_1(copy_float_to_uchar,float,unsigned char) +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_float_to_short,float,short) +DEFUN_1(copy_float_to_ushort,float,unsigned short) +#else +# define copy_float_to_short copy_float_to_int +# define copy_float_to_ushort copy_float_to_uint +#endif +DEFUN_1(copy_float_to_int,float,int) +DEFUN_1(copy_float_to_uint,float,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_float_to_long,float,long) +DEFUN_1(copy_float_to_ulong,float,unsigned long) +#else +# define copy_float_to_long copy_float_to_int +# define copy_float_to_ulong copy_float_to_uint +#endif +DEFUN_1(copy_float_to_float,float,float) +DEFUN_1(copy_float_to_double,float,double) + +DEFUN_1(copy_double_to_char,double,char) +DEFUN_1(copy_double_to_uchar,double,unsigned char) +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_1(copy_double_to_short,double,short) +DEFUN_1(copy_double_to_ushort,double,unsigned short) +#else +# define copy_double_to_short copy_double_to_int +# define copy_double_to_ushort copy_double_to_uint +#endif +DEFUN_1(copy_double_to_int,double,int) +DEFUN_1(copy_double_to_uint,double,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_1(copy_double_to_long,double,long) +DEFUN_1(copy_double_to_ulong,double,unsigned long) +#else +# define copy_double_to_long copy_double_to_int +# define copy_double_to_ulong copy_double_to_uint +#endif +DEFUN_1(copy_double_to_float,double,float) +DEFUN_1(copy_double_to_double,double,double) + +DEFUN_2(char_to_int,char,int,copy_char_to_int) +DEFUN_2(char_to_uint,char,unsigned int,copy_char_to_uint) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(char_to_long,char,long,copy_char_to_long) +DEFUN_2(char_to_ulong,char,unsigned long,copy_char_to_ulong) +#else +# define char_to_long char_to_int +# define char_to_ulong char_to_uint +#endif +DEFUN_2(char_to_float,char,float,copy_char_to_float) +DEFUN_2(char_to_double,char,double,copy_char_to_double) + +DEFUN_2(uchar_to_int,unsigned char,int,copy_uchar_to_int) +DEFUN_2(uchar_to_uint,unsigned char,unsigned int,copy_uchar_to_uint) +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(uchar_to_long,unsigned char,long,copy_uchar_to_long) +DEFUN_2(uchar_to_ulong,unsigned char,unsigned long,copy_uchar_to_ulong) +#else +# define uchar_to_long uchar_to_int +# define uchar_to_ulong uchar_to_uint +#endif +DEFUN_2(uchar_to_float,unsigned char,float,copy_uchar_to_float) +DEFUN_2(uchar_to_double,unsigned char,double,copy_uchar_to_double) + +#if SIZEOF_INT != SIZEOF_SHORT +DEFUN_2(short_to_int,short,int,copy_short_to_int) +DEFUN_2(short_to_uint,short,unsigned int,copy_short_to_uint) +DEFUN_2(short_to_long,short,long,copy_short_to_long) +DEFUN_2(short_to_ulong,short,unsigned long,copy_short_to_ulong) +DEFUN_2(short_to_float,short,float,copy_short_to_float) +DEFUN_2(short_to_double,short,double,copy_short_to_double) +DEFUN_2(ushort_to_int,unsigned short,int,copy_ushort_to_int) +DEFUN_2(ushort_to_uint,unsigned short,unsigned int,copy_ushort_to_uint) +DEFUN_2(ushort_to_long,unsigned short,long,copy_ushort_to_long) +DEFUN_2(ushort_to_ulong,unsigned short,unsigned long,copy_ushort_to_ulong) +DEFUN_2(ushort_to_float,unsigned short,float,copy_ushort_to_float) +DEFUN_2(ushort_to_double,unsigned short,double,copy_ushort_to_double) +#else +# define short_to_int NULL +# define short_to_uint NULL +# define short_to_long int_to_long +# define short_to_ulong int_to_ulong +# define short_to_float int_to_float +# define short_to_double int_to_double +# define ushort_to_int NULL +# define ushort_to_uint NULL +# define ushort_to_long uint_to_long +# define ushort_to_ulong uint_to_ulong +# define ushort_to_float uint_to_float +# define ushort_to_double uint_to_double +#endif + +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(int_to_long,int,long,copy_int_to_long) +DEFUN_2(int_to_ulong,int,unsigned long,copy_int_to_ulong) +#else +# define int_to_long NULL +# define int_to_ulong NULL +#endif +DEFUN_2(int_to_float,int,float,copy_int_to_float) +DEFUN_2(int_to_double,int,double,copy_int_to_double) + +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(uint_to_long,unsigned int,long,copy_uint_to_long) +DEFUN_2(uint_to_ulong,unsigned int,unsigned long,copy_uint_to_ulong) +#else +# define uint_to_long NULL +# define uint_to_ulong NULL +#endif +DEFUN_2(uint_to_float,unsigned int,float,copy_uint_to_float) +DEFUN_2(uint_to_double,unsigned int,double,copy_uint_to_double) + +#if SIZEOF_INT != SIZEOF_LONG +DEFUN_2(long_to_float,long,float,copy_long_to_float) +DEFUN_2(long_to_double,long,double,copy_long_to_double) +DEFUN_2(ulong_to_float,unsigned long,float,copy_ulong_to_float) +DEFUN_2(ulong_to_double,unsigned long,double,copy_ulong_to_double) +#else +# define long_to_float int_to_float +# define long_to_double int_to_double +# define ulong_to_float uint_to_float +# define ulong_to_double uint_to_double +#endif + +DEFUN_2(float_to_double,float,double,copy_float_to_double) + +#define TO_DOUBLE_FUN(name,type) \ +static double name (VOID_STAR x) { return (double) *(type *) x; } +TO_DOUBLE_FUN(char_to_one_double,char) +TO_DOUBLE_FUN(uchar_to_one_double,unsigned char) +#if SIZEOF_INT != SIZEOF_SHORT +TO_DOUBLE_FUN(short_to_one_double,short) +TO_DOUBLE_FUN(ushort_to_one_double,unsigned short) +#else +# define short_to_one_double int_to_one_double +# define ushort_to_one_double uint_to_one_double +#endif +TO_DOUBLE_FUN(int_to_one_double,int) +TO_DOUBLE_FUN(uint_to_one_double,unsigned int) +#if SIZEOF_INT != SIZEOF_LONG +TO_DOUBLE_FUN(long_to_one_double,long) +TO_DOUBLE_FUN(ulong_to_one_double,unsigned long) +#else +# define long_to_one_double int_to_one_double +# define ulong_to_one_double uint_to_one_double +#endif +TO_DOUBLE_FUN(float_to_one_double,float) +TO_DOUBLE_FUN(double_to_one_double,double) + +SLang_To_Double_Fun_Type +SLarith_get_to_double_fun (unsigned char type, unsigned int *sizeof_type) +{ + unsigned int da; + SLang_To_Double_Fun_Type to_double; + + switch (type) + { + default: + return NULL; + + case SLANG_CHAR_TYPE: + da = sizeof (char); to_double = char_to_one_double; + break; + case SLANG_UCHAR_TYPE: + da = sizeof (unsigned char); to_double = uchar_to_one_double; + break; + case SLANG_SHORT_TYPE: + da = sizeof (short); to_double = short_to_one_double; + break; + case SLANG_USHORT_TYPE: + da = sizeof (unsigned short); to_double = ushort_to_one_double; + break; + case SLANG_INT_TYPE: + da = sizeof (int); to_double = int_to_one_double; + break; + case SLANG_UINT_TYPE: + da = sizeof (unsigned int); to_double = uint_to_one_double; + break; + case SLANG_LONG_TYPE: + da = sizeof (long); to_double = long_to_one_double; + break; + case SLANG_ULONG_TYPE: + da = sizeof (unsigned long); to_double = ulong_to_one_double; + break; + case SLANG_FLOAT_TYPE: + da = sizeof (float); to_double = float_to_one_double; + break; + case SLANG_DOUBLE_TYPE: + da = sizeof (double); to_double = double_to_one_double; + break; + } + + if (sizeof_type != NULL) *sizeof_type = da; + return to_double; +} + +/* Each element of the matrix determines how the row maps onto the column. + * That is, let the matrix be B_ij. Where the i,j indices refer to + * precedence of the type. Then, + * B_ij->copy_function copies type i to type j. Similarly, + * B_ij->convert_function mallocs a new array of type j and copies i to it. + * + * Since types are always converted to higher levels of precedence for binary + * operations, many of the elements are NULL. + * + * Is the idea clear? + */ +typedef struct +{ + FVOID_STAR copy_function; + Convert_Fun_Type convert_function; +} +Binary_Matrix_Type; + +static Binary_Matrix_Type Binary_Matrix [MAX_ARITHMETIC_TYPES][MAX_ARITHMETIC_TYPES] = +{ + { + {(FVOID_STAR)copy_char_to_char, NULL}, + {(FVOID_STAR)copy_char_to_char, NULL}, + {(FVOID_STAR) copy_char_to_short, NULL}, + {(FVOID_STAR) copy_char_to_ushort, NULL}, + {(FVOID_STAR) copy_char_to_int, char_to_int}, + {(FVOID_STAR) copy_char_to_uint, char_to_uint}, + {(FVOID_STAR) copy_char_to_long, char_to_long}, + {(FVOID_STAR) copy_char_to_ulong, char_to_ulong}, + {(FVOID_STAR) copy_char_to_float, char_to_float}, + {(FVOID_STAR) copy_char_to_double, char_to_double}, + }, + + { + {(FVOID_STAR)copy_char_to_char, NULL}, + {(FVOID_STAR)copy_char_to_char, NULL}, + {(FVOID_STAR) copy_uchar_to_short, NULL}, + {(FVOID_STAR) copy_uchar_to_ushort, NULL}, + {(FVOID_STAR) copy_uchar_to_int, uchar_to_int}, + {(FVOID_STAR) copy_uchar_to_uint, uchar_to_uint}, + {(FVOID_STAR) copy_uchar_to_long, uchar_to_long}, + {(FVOID_STAR) copy_uchar_to_ulong, uchar_to_ulong}, + {(FVOID_STAR) copy_uchar_to_float, uchar_to_float}, + {(FVOID_STAR) copy_uchar_to_double, uchar_to_double}, + }, + + { + {(FVOID_STAR) copy_short_to_char, NULL}, + {(FVOID_STAR) copy_short_to_uchar, NULL}, + {(FVOID_STAR) copy_short_to_short, NULL}, + {(FVOID_STAR) copy_short_to_short, NULL}, + {(FVOID_STAR) copy_short_to_int, short_to_int}, + {(FVOID_STAR) copy_short_to_uint, short_to_uint}, + {(FVOID_STAR) copy_short_to_long, short_to_long}, + {(FVOID_STAR) copy_short_to_ulong, short_to_ulong}, + {(FVOID_STAR) copy_short_to_float, short_to_float}, + {(FVOID_STAR) copy_short_to_double, short_to_double}, + }, + + { + {(FVOID_STAR) copy_ushort_to_char, NULL}, + {(FVOID_STAR) copy_ushort_to_uchar, NULL}, + {(FVOID_STAR) copy_short_to_short, NULL}, + {(FVOID_STAR) copy_short_to_short, NULL}, + {(FVOID_STAR) copy_ushort_to_int, ushort_to_int}, + {(FVOID_STAR) copy_ushort_to_uint, ushort_to_uint}, + {(FVOID_STAR) copy_ushort_to_long, ushort_to_long}, + {(FVOID_STAR) copy_ushort_to_ulong, ushort_to_ulong}, + {(FVOID_STAR) copy_ushort_to_float, ushort_to_float}, + {(FVOID_STAR) copy_ushort_to_double, ushort_to_double}, + }, + + { + {(FVOID_STAR) copy_int_to_char, NULL}, + {(FVOID_STAR) copy_int_to_uchar, NULL}, + {(FVOID_STAR) copy_int_to_short, NULL}, + {(FVOID_STAR) copy_int_to_ushort, NULL}, + {(FVOID_STAR) copy_int_to_int, NULL}, + {(FVOID_STAR) copy_int_to_int, NULL}, + {(FVOID_STAR) copy_int_to_long, int_to_long}, + {(FVOID_STAR) copy_int_to_ulong, int_to_ulong}, + {(FVOID_STAR) copy_int_to_float, int_to_float}, + {(FVOID_STAR) copy_int_to_double, int_to_double}, + }, + + { + {(FVOID_STAR) copy_uint_to_char, NULL}, + {(FVOID_STAR) copy_uint_to_uchar, NULL}, + {(FVOID_STAR) copy_uint_to_short, NULL}, + {(FVOID_STAR) copy_uint_to_ushort, NULL}, + {(FVOID_STAR) copy_int_to_int, NULL}, + {(FVOID_STAR) copy_int_to_int, NULL}, + {(FVOID_STAR) copy_uint_to_long, uint_to_long}, + {(FVOID_STAR) copy_uint_to_ulong, uint_to_ulong}, + {(FVOID_STAR) copy_uint_to_float, uint_to_float}, + {(FVOID_STAR) copy_uint_to_double, uint_to_double}, + }, + + { + {(FVOID_STAR) copy_long_to_char, NULL}, + {(FVOID_STAR) copy_long_to_uchar, NULL}, + {(FVOID_STAR) copy_long_to_short, NULL}, + {(FVOID_STAR) copy_long_to_ushort, NULL}, + {(FVOID_STAR) copy_long_to_int, NULL}, + {(FVOID_STAR) copy_long_to_uint, NULL}, + {(FVOID_STAR) copy_long_to_long, NULL}, + {(FVOID_STAR) copy_long_to_long, NULL}, + {(FVOID_STAR) copy_long_to_float, long_to_float}, + {(FVOID_STAR) copy_long_to_double, long_to_double}, + }, + + { + {(FVOID_STAR) copy_ulong_to_char, NULL}, + {(FVOID_STAR) copy_ulong_to_uchar, NULL}, + {(FVOID_STAR) copy_ulong_to_short, NULL}, + {(FVOID_STAR) copy_ulong_to_ushort, NULL}, + {(FVOID_STAR) copy_ulong_to_int, NULL}, + {(FVOID_STAR) copy_ulong_to_uint, NULL}, + {(FVOID_STAR) copy_long_to_long, NULL}, + {(FVOID_STAR) copy_long_to_long, NULL}, + {(FVOID_STAR) copy_ulong_to_float, ulong_to_float}, + {(FVOID_STAR) copy_ulong_to_double, ulong_to_double}, + }, + + { + {(FVOID_STAR) copy_float_to_char, NULL}, + {(FVOID_STAR) copy_float_to_uchar, NULL}, + {(FVOID_STAR) copy_float_to_short, NULL}, + {(FVOID_STAR) copy_float_to_ushort, NULL}, + {(FVOID_STAR) copy_float_to_int, NULL}, + {(FVOID_STAR) copy_float_to_uint, NULL}, + {(FVOID_STAR) copy_float_to_long, NULL}, + {(FVOID_STAR) copy_float_to_ulong, NULL}, + {(FVOID_STAR) copy_float_to_float, NULL}, + {(FVOID_STAR) copy_float_to_double, float_to_double}, + }, + + { + {(FVOID_STAR) copy_double_to_char, NULL}, + {(FVOID_STAR) copy_double_to_uchar, NULL}, + {(FVOID_STAR) copy_double_to_short, NULL}, + {(FVOID_STAR) copy_double_to_ushort, NULL}, + {(FVOID_STAR) copy_double_to_int, NULL}, + {(FVOID_STAR) copy_double_to_uint, NULL}, + {(FVOID_STAR) copy_double_to_long, NULL}, + {(FVOID_STAR) copy_double_to_ulong, NULL}, + {(FVOID_STAR) copy_double_to_float, NULL}, + {(FVOID_STAR) copy_double_to_double, NULL}, + } +}; + +#define GENERIC_BINARY_FUNCTION int_int_bin_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE int +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define ABS_FUNCTION abs +#define MOD_FUNCTION(a,b) ((a) % (b)) +#define GENERIC_UNARY_FUNCTION int_unary_op +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#define SCALAR_BINARY_FUNCTION int_int_scalar_bin_op +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_int_obj(SLANG_INT_TYPE,(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION int_cmp_function +#include "slarith.inc" + +#define GENERIC_BINARY_FUNCTION uint_uint_bin_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE unsigned int +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define MOD_FUNCTION(a,b) ((a) % (b)) +#define GENERIC_UNARY_FUNCTION uint_unary_op +#define ABS_FUNCTION(a) (a) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0) +#define SCALAR_BINARY_FUNCTION uint_uint_scalar_bin_op +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_int_obj(SLANG_UINT_TYPE,(int)(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION uint_cmp_function +#include "slarith.inc" + +#if SIZEOF_LONG != SIZEOF_INT +#define GENERIC_BINARY_FUNCTION long_long_bin_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE long +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define MOD_FUNCTION(a,b) ((a) % (b)) +#define GENERIC_UNARY_FUNCTION long_unary_op +#define ABS_FUNCTION(a) (((a) >= 0) ? (a) : -(a)) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#define SCALAR_BINARY_FUNCTION long_long_scalar_bin_op +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_long_obj(SLANG_LONG_TYPE,(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION long_cmp_function +#include "slarith.inc" + +#define GENERIC_BINARY_FUNCTION ulong_ulong_bin_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE unsigned long +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define MOD_FUNCTION(a,b) ((a) % (b)) +#define GENERIC_UNARY_FUNCTION ulong_unary_op +#define ABS_FUNCTION(a) (a) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0) +#define SCALAR_BINARY_FUNCTION ulong_ulong_scalar_bin_op +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_long_obj(SLANG_ULONG_TYPE,(long)(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION ulong_cmp_function +#include "slarith.inc" +#else +#define long_long_bin_op int_int_bin_op +#define ulong_ulong_bin_op uint_uint_bin_op +#define long_unary_op int_unary_op +#define ulong_unary_op uint_unary_op +#define long_cmp_function int_cmp_function +#define ulong_cmp_function uint_cmp_function +#endif /* SIZEOF_INT != SIZEOF_LONG */ + +#define GENERIC_BINARY_FUNCTION float_float_bin_op +#define GENERIC_TYPE float +#define POW_FUNCTION(a,b) (float)pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE float +#define MOD_FUNCTION(a,b) (float)fmod((a),(b)) +#define GENERIC_UNARY_FUNCTION float_unary_op +#define ABS_FUNCTION(a) (float)fabs((double) a) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#define SCALAR_BINARY_FUNCTION float_float_scalar_bin_op +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_float_obj(SLANG_FLOAT_TYPE,(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_float_obj(SLANG_FLOAT_TYPE, (x)) +#define CMP_FUNCTION float_cmp_function +#include "slarith.inc" + +#define GENERIC_BINARY_FUNCTION double_double_bin_op +#define GENERIC_TYPE double +#define POW_FUNCTION(a,b) pow((double)(a),(double)(b)) +#define POW_RESULT_TYPE double +#define MOD_FUNCTION(a,b) (float)fmod((a),(b)) +#define GENERIC_UNARY_FUNCTION double_unary_op +#define ABS_FUNCTION(a) fabs(a) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#define SCALAR_BINARY_FUNCTION double_double_scalar_bin_op +#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE,(x)) +#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x)) +#define CMP_FUNCTION double_cmp_function +#include "slarith.inc" + +#define GENERIC_UNARY_FUNCTION char_unary_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE signed char +#define ABS_FUNCTION abs +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#define CMP_FUNCTION char_cmp_function +#include "slarith.inc" + +#define GENERIC_UNARY_FUNCTION uchar_unary_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE unsigned char +#define ABS_FUNCTION(x) (x) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0) +#define CMP_FUNCTION uchar_cmp_function +#include "slarith.inc" + +#if SIZEOF_SHORT != SIZEOF_INT +#define GENERIC_UNARY_FUNCTION short_unary_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE short +#define ABS_FUNCTION abs +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0)) +#define CMP_FUNCTION short_cmp_function +#include "slarith.inc" + +#define GENERIC_UNARY_FUNCTION ushort_unary_op +#define GENERIC_BIT_OPERATIONS +#define GENERIC_TYPE unsigned short +#define ABS_FUNCTION(x) (x) +#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0) +#define CMP_FUNCTION ushort_cmp_function +#include "slarith.inc" +#endif /* SIZEOF_INT != SIZEOF_SHORT */ + +/* Unfortunately, the numbers that were assigned to the data-types were + * not well thought out. So, I need to use the following table. + */ +#define MAXIMUM_ARITH_TYPE_VALUE SLANG_FLOAT_TYPE +#define IS_INTEGER_TYPE(x) \ + (((x) <= MAXIMUM_ARITH_TYPE_VALUE) \ + && (Type_Precedence_Table[x] < 8) && (Type_Precedence_Table[x] != -1)) +#define IS_ARITHMETIC_TYPE(x) \ + (((x) <= MAXIMUM_ARITH_TYPE_VALUE) && (Type_Precedence_Table[x] != -1)) + +#define LONG_PRECEDENCE_VALUE 6 +#define FLOAT_PRECEDENCE_VALUE 8 + +static signed char Type_Precedence_Table [MAXIMUM_ARITH_TYPE_VALUE + 1] = +{ + -1, /* SLANG_UNDEFINED_TYPE */ + -1, /* SLANG_VOID_TYPE */ + 4, /* SLANG_INT_TYPE */ + 9, /* SLANG_DOUBLE_TYPE */ + 0, /* SLANG_CHAR_TYPE */ + -1, /* SLANG_INTP_TYPE */ + -1, /* SLANG_REF_TYPE */ + -1, /* SLANG_COMPLEX_TYPE */ + -1, /* SLANG_NULL_TYPE */ + 1, /* SLANG_UCHAR_TYPE */ + 2, /* SLANG_SHORT_TYPE */ + 3, /* SLANG_USHORT_TYPE */ + 5, /* SLANG_UINT_TYPE */ + 6, /* SLANG_LONG_TYPE */ + 7, /* SLANG_ULONG_TYPE */ + -1, /* SLANG_STRING_TYPE */ + 8 /* SLANG_FLOAT_TYPE */ +}; + +int _SLarith_get_precedence (unsigned char type) +{ + if (type > MAXIMUM_ARITH_TYPE_VALUE) + return -1; + + return Type_Precedence_Table[type]; +} + +unsigned char _SLarith_promote_type (unsigned char t) +{ + switch (t) + { + case SLANG_FLOAT_TYPE: + case SLANG_DOUBLE_TYPE: + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: + case SLANG_INT_TYPE: + case SLANG_UINT_TYPE: + break; + + case SLANG_USHORT_TYPE: +#if SIZEOF_INT == SIZEOF_SHORT + t = SLANG_UINT_TYPE; + break; +#endif + /* drop */ + case SLANG_CHAR_TYPE: + case SLANG_UCHAR_TYPE: + case SLANG_SHORT_TYPE: + default: + t = SLANG_INT_TYPE; + } + + return t; +} + +static unsigned char promote_to_common_type (unsigned char a, unsigned char b) +{ + a = _SLarith_promote_type (a); + b = _SLarith_promote_type (b); + + return (Type_Precedence_Table[a] > Type_Precedence_Table[b]) ? a : b; +} + +static int arith_bin_op_result (int op, unsigned char a_type, unsigned char b_type, + unsigned char *c_type) +{ + switch (op) + { + case SLANG_EQ: + case SLANG_NE: + case SLANG_GT: + case SLANG_GE: + case SLANG_LT: + case SLANG_LE: + case SLANG_OR: + case SLANG_AND: + *c_type = SLANG_CHAR_TYPE; + return 1; + + case SLANG_POW: + if (SLANG_FLOAT_TYPE == promote_to_common_type (a_type, b_type)) + *c_type = SLANG_FLOAT_TYPE; + else + *c_type = SLANG_DOUBLE_TYPE; + return 1; + + case SLANG_BAND: + case SLANG_BXOR: + case SLANG_BOR: + case SLANG_SHL: + case SLANG_SHR: + /* The bit-level operations are defined just for integer types */ + if ((0 == IS_INTEGER_TYPE (a_type)) + || (0 == IS_INTEGER_TYPE(b_type))) + return 0; + break; + + default: + break; + } + + *c_type = promote_to_common_type (a_type, b_type); + return 1; +} + +typedef int (*Bin_Fun_Type) (int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR); + +/* This array of functions must be indexed by precedence after arithmetic + * promotions. + */ +static Bin_Fun_Type Bin_Fun_Map [MAX_ARITHMETIC_TYPES] = +{ + NULL, + NULL, + NULL, + NULL, + int_int_bin_op, + uint_uint_bin_op, + long_long_bin_op, + ulong_ulong_bin_op, + float_float_bin_op, + double_double_bin_op +}; + +static int arith_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + Convert_Fun_Type af, bf; + Bin_Fun_Type binfun; + int a_indx, b_indx, c_indx; + unsigned char c_type; + int ret; + + c_type = promote_to_common_type (a_type, b_type); + + a_indx = Type_Precedence_Table [a_type]; + b_indx = Type_Precedence_Table [b_type]; + c_indx = Type_Precedence_Table [c_type]; + + af = Binary_Matrix[a_indx][c_indx].convert_function; + bf = Binary_Matrix[b_indx][c_indx].convert_function; + binfun = Bin_Fun_Map[c_indx]; + + if ((af != NULL) + && (NULL == (ap = (VOID_STAR) (*af) (ap, na)))) + return -1; + + if ((bf != NULL) + && (NULL == (bp = (VOID_STAR) (*bf) (bp, nb)))) + { + if (af != NULL) SLfree ((char *) ap); + return -1; + } + + ret = (*binfun) (op, a_type, ap, na, b_type, bp, nb, cp); + if (af != NULL) SLfree ((char *) ap); + if (bf != NULL) SLfree ((char *) bp); + + return ret; +} + +static int arith_unary_op_result (int op, unsigned char a, unsigned char *b) +{ + (void) a; + switch (op) + { + default: + return 0; + + case SLANG_SQR: + case SLANG_MUL2: + case SLANG_PLUSPLUS: + case SLANG_MINUSMINUS: + case SLANG_CHS: + case SLANG_ABS: + *b = a; + break; + + case SLANG_NOT: + case SLANG_BNOT: + if (0 == IS_INTEGER_TYPE(a)) + return 0; + *b = a; + break; + + case SLANG_SIGN: + *b = SLANG_INT_TYPE; + break; + } + return 1; +} + +static int integer_pop (unsigned char type, VOID_STAR ptr) +{ + SLang_Object_Type obj; + int i, j; + void (*f)(VOID_STAR, VOID_STAR, unsigned int); + + if (-1 == SLang_pop (&obj)) + return -1; + + if ((obj.data_type > MAXIMUM_ARITH_TYPE_VALUE) + || ((j = Type_Precedence_Table[obj.data_type]) == -1) + || (j >= FLOAT_PRECEDENCE_VALUE)) + { + _SLclass_type_mismatch_error (type, obj.data_type); + SLang_free_object (&obj); + return -1; + } + + i = Type_Precedence_Table[type]; + f = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[j][i].copy_function; + + (*f) (ptr, (VOID_STAR)&obj.v, 1); + + return 0; +} + +static int integer_push (unsigned char type, VOID_STAR ptr) +{ + SLang_Object_Type obj; + int i; + void (*f)(VOID_STAR, VOID_STAR, unsigned int); + + i = Type_Precedence_Table[type]; + f = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[i][i].copy_function; + + obj.data_type = type; + + (*f) ((VOID_STAR)&obj.v, ptr, 1); + + return SLang_push (&obj); +} + +int SLang_pop_char (char *i) +{ + return integer_pop (SLANG_CHAR_TYPE, (VOID_STAR) i); +} + +int SLang_pop_uchar (unsigned char *i) +{ + return integer_pop (SLANG_UCHAR_TYPE, (VOID_STAR) i); +} + +int SLang_pop_short (short *i) +{ + return integer_pop (SLANG_SHORT_TYPE, (VOID_STAR) i); +} + +int SLang_pop_ushort (unsigned short *i) +{ + return integer_pop (SLANG_USHORT_TYPE, (VOID_STAR) i); +} + +int SLang_pop_long (long *i) +{ + return integer_pop (SLANG_LONG_TYPE, (VOID_STAR) i); +} + +int SLang_pop_ulong (unsigned long *i) +{ + return integer_pop (SLANG_ULONG_TYPE, (VOID_STAR) i); +} + +int SLang_pop_integer (int *i) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (SLANG_INT_TYPE, &obj, 0)) + return -1; + *i = obj.v.int_val; + return 0; +#else + return integer_pop (SLANG_INT_TYPE, (VOID_STAR) i); +#endif +} + +int SLang_pop_uinteger (unsigned int *i) +{ + return integer_pop (SLANG_UINT_TYPE, (VOID_STAR) i); +} + +int SLang_push_integer (int i) +{ + return SLclass_push_int_obj (SLANG_INT_TYPE, i); +} +int SLang_push_uinteger (unsigned int i) +{ + return SLclass_push_int_obj (SLANG_UINT_TYPE, (int) i); +} +int SLang_push_char (char i) +{ + return SLclass_push_char_obj (SLANG_CHAR_TYPE, i); +} +int SLang_push_uchar (unsigned char i) +{ + return SLclass_push_char_obj (SLANG_UCHAR_TYPE, (char) i); +} +int SLang_push_short (short i) +{ + return SLclass_push_short_obj (SLANG_SHORT_TYPE, i); +} +int SLang_push_ushort (unsigned short i) +{ + return SLclass_push_short_obj (SLANG_USHORT_TYPE, (unsigned short) i); +} +int SLang_push_long (long i) +{ + return SLclass_push_long_obj (SLANG_LONG_TYPE, i); +} +int SLang_push_ulong (unsigned long i) +{ + return SLclass_push_long_obj (SLANG_ULONG_TYPE, (long) i); +} + +_INLINE_ +int _SLarith_typecast (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + int i, j; + + void (*copy)(VOID_STAR, VOID_STAR, unsigned int); + + i = Type_Precedence_Table[a_type]; + j = Type_Precedence_Table[b_type]; + + copy = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[i][j].copy_function; + + (*copy) (bp, ap, na); + return 1; +} + +#if SLANG_HAS_FLOAT + +int SLang_pop_double(double *x, int *convertp, int *ip) +{ + SLang_Object_Type obj; + int i, convert; + + if (0 != SLang_pop (&obj)) + return -1; + + i = 0; + convert = 0; + + switch (obj.data_type) + { + case SLANG_FLOAT_TYPE: + *x = (double) obj.v.float_val; + break; + + case SLANG_DOUBLE_TYPE: + *x = obj.v.double_val; + break; + + case SLANG_INT_TYPE: + i = (int) obj.v.long_val; + *x = (double) i; + convert = 1; + break; + + case SLANG_CHAR_TYPE: *x = (double) obj.v.char_val; break; + case SLANG_UCHAR_TYPE: *x = (double) obj.v.uchar_val; break; + case SLANG_SHORT_TYPE: *x = (double) obj.v.short_val; break; + case SLANG_USHORT_TYPE: *x = (double) obj.v.ushort_val; break; + case SLANG_UINT_TYPE: *x = (double) obj.v.uint_val; break; + case SLANG_LONG_TYPE: *x = (double) obj.v.long_val; break; + case SLANG_ULONG_TYPE: *x = (double) obj.v.ulong_val; break; + + default: + _SLclass_type_mismatch_error (SLANG_DOUBLE_TYPE, obj.data_type); + SLang_free_object (&obj); + return -1; + } + + if (convertp != NULL) *convertp = convert; + if (ip != NULL) *ip = i; + + return 0; +} + +int SLang_push_double (double x) +{ + return SLclass_push_double_obj (SLANG_DOUBLE_TYPE, x); +} + +int SLang_pop_float (float *x) +{ + double d; + + /* Pop it as a double and let the double function do all the typcasting */ + if (-1 == SLang_pop_double (&d, NULL, NULL)) + return -1; + + *x = (float) d; + return 0; +} + +int SLang_push_float (float f) +{ + return SLclass_push_float_obj (SLANG_FLOAT_TYPE, (double) f); +} + +/* Double */ +static int double_push (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + SLang_push_double (*(double *) ptr); + return 0; +} + +static int double_push_literal (unsigned char type, VOID_STAR ptr) +{ + (void) type; + return SLang_push_double (**(double **)ptr); +} + +static int double_pop (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return SLang_pop_double ((double *) ptr, NULL, NULL); +} + +static void double_byte_code_destroy (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + SLfree (*(char **) ptr); +} + +static int float_push (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + SLang_push_float (*(float *) ptr); + return 0; +} + +static int float_pop (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return SLang_pop_float ((float *) ptr); +} + +#endif /* SLANG_HAS_FLOAT */ + +#if SLANG_HAS_FLOAT +static char Double_Format[16] = "%g"; + +void _SLset_double_format (char *s) +{ + strncpy (Double_Format, s, 15); + Double_Format[15] = 0; +} +#endif + +static char *arith_string (unsigned char type, VOID_STAR v) +{ + char buf [256]; + char *s; + + s = buf; + + switch (type) + { + default: + s = SLclass_get_datatype_name (type); + break; + + case SLANG_CHAR_TYPE: + sprintf (s, "%d", *(char *) v); + break; + case SLANG_UCHAR_TYPE: + sprintf (s, "%u", *(unsigned char *) v); + break; + case SLANG_SHORT_TYPE: + sprintf (s, "%d", *(short *) v); + break; + case SLANG_USHORT_TYPE: + sprintf (s, "%u", *(unsigned short *) v); + break; + case SLANG_INT_TYPE: + sprintf (s, "%d", *(int *) v); + break; + case SLANG_UINT_TYPE: + sprintf (s, "%u", *(unsigned int *) v); + break; + case SLANG_LONG_TYPE: + sprintf (s, "%ld", *(long *) v); + break; + case SLANG_ULONG_TYPE: + sprintf (s, "%lu", *(unsigned long *) v); + break; +#if SLANG_HAS_FLOAT + case SLANG_FLOAT_TYPE: + if (EOF == _SLsnprintf (buf, sizeof (buf), Double_Format, *(float *) v)) + sprintf (s, "%e", *(float *) v); + break; + case SLANG_DOUBLE_TYPE: + if (EOF == _SLsnprintf (buf, sizeof (buf), Double_Format, *(double *) v)) + sprintf (s, "%e", *(double *) v); + break; +#endif + } + + return SLmake_string (s); +} + +static int integer_to_bool (unsigned char type, int *t) +{ + (void) type; + return SLang_pop_integer (t); +} + +static int push_int_literal (unsigned char type, VOID_STAR ptr) +{ + return SLclass_push_int_obj (type, (int) *(long *) ptr); +} + +static int push_char_literal (unsigned char type, VOID_STAR ptr) +{ + return SLclass_push_char_obj (type, (char) *(long *) ptr); +} + +#if SIZEOF_SHORT != SIZEOF_INT +static int push_short_literal (unsigned char type, VOID_STAR ptr) +{ + return SLclass_push_short_obj (type, (short) *(long *) ptr); +} +#endif + +#if SIZEOF_INT != SIZEOF_LONG +static int push_long_literal (unsigned char type, VOID_STAR ptr) +{ + return SLclass_push_long_obj (type, *(long *) ptr); +} +#endif + +typedef struct +{ + char *name; + unsigned char data_type; + unsigned int sizeof_type; + int (*unary_fun)(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); + int (*push_literal) (unsigned char, VOID_STAR); + int (*cmp_fun) (unsigned char, VOID_STAR, VOID_STAR, int *); +} +Integer_Info_Type; + +static Integer_Info_Type Integer_Types [8] = +{ + {"Char_Type", SLANG_CHAR_TYPE, sizeof (char), char_unary_op, push_char_literal, char_cmp_function}, + {"UChar_Type", SLANG_UCHAR_TYPE, sizeof (unsigned char), uchar_unary_op, push_char_literal, uchar_cmp_function}, +#if SIZEOF_INT != SIZEOF_SHORT + {"Short_Type", SLANG_SHORT_TYPE, sizeof (short), short_unary_op, push_short_literal, short_cmp_function}, + {"UShort_Type", SLANG_USHORT_TYPE, sizeof (unsigned short), ushort_unary_op, push_short_literal, ushort_cmp_function}, +#else + {NULL, SLANG_SHORT_TYPE}, + {NULL, SLANG_USHORT_TYPE}, +#endif + + {"Integer_Type", SLANG_INT_TYPE, sizeof (int), int_unary_op, push_int_literal, int_cmp_function}, + {"UInteger_Type", SLANG_UINT_TYPE, sizeof (unsigned int), uint_unary_op, push_int_literal, uint_cmp_function}, + +#if SIZEOF_INT != SIZEOF_LONG + {"Long_Type", SLANG_LONG_TYPE, sizeof (long), long_unary_op, push_long_literal, long_cmp_function}, + {"ULong_Type", SLANG_ULONG_TYPE, sizeof (unsigned long), ulong_unary_op, push_long_literal, ulong_cmp_function} +#else + {NULL, SLANG_LONG_TYPE, 0, NULL, NULL, NULL}, + {NULL, SLANG_ULONG_TYPE, 0, NULL, NULL, NULL} +#endif +}; + +static int create_synonyms (void) +{ + static char *names[8] = + { + "Int16_Type", "UInt16_Type", "Int32_Type", "UInt32_Type", + "Int64_Type", "UInt64_Type", + "Float32_Type", "Float64_Type" + }; + int types[8]; + unsigned int i; + + memset ((char *) types, 0, sizeof (types)); + + /* The assumption is that sizeof(unsigned X) == sizeof (X) */ +#if SIZEOF_INT == 2 + types[0] = SLANG_INT_TYPE; + types[1] = SLANG_UINT_TYPE; +#else +# if SIZEOF_SHORT == 2 + types[0] = SLANG_SHORT_TYPE; + types[1] = SLANG_USHORT_TYPE; +# else +# if SIZEOF_LONG == 2 + types[0] = SLANG_LONG_TYPE; + types[1] = SLANG_ULONG_TYPE; +# endif +# endif +#endif + +#if SIZEOF_INT == 4 + types[2] = SLANG_INT_TYPE; + types[3] = SLANG_UINT_TYPE; +#else +# if SIZEOF_SHORT == 4 + types[2] = SLANG_SHORT_TYPE; + types[3] = SLANG_USHORT_TYPE; +# else +# if SIZEOF_LONG == 4 + types[2] = SLANG_LONG_TYPE; + types[3] = SLANG_ULONG_TYPE; +# endif +# endif +#endif + +#if SIZEOF_INT == 8 + types[4] = SLANG_INT_TYPE; + types[5] = SLANG_UINT_TYPE; +#else +# if SIZEOF_SHORT == 8 + types[4] = SLANG_SHORT_TYPE; + types[5] = SLANG_USHORT_TYPE; +# else +# if SIZEOF_LONG == 8 + types[4] = SLANG_LONG_TYPE; + types[5] = SLANG_ULONG_TYPE; +# endif +# endif +#endif + +#if SLANG_HAS_FLOAT + +#if SIZEOF_FLOAT == 4 + types[6] = SLANG_FLOAT_TYPE; +#else +# if SIZEOF_DOUBLE == 4 + types[6] = SLANG_DOUBLE_TYPE; +# endif +#endif +#if SIZEOF_FLOAT == 8 + types[7] = SLANG_FLOAT_TYPE; +#else +# if SIZEOF_DOUBLE == 8 + types[7] = SLANG_DOUBLE_TYPE; +# endif +#endif + +#endif + + if ((-1 == SLclass_create_synonym ("Int_Type", SLANG_INT_TYPE)) + || (-1 == SLclass_create_synonym ("UInt_Type", SLANG_UINT_TYPE))) + return -1; + + for (i = 0; i < 8; i++) + { + if (types[i] == 0) continue; + + if (-1 == SLclass_create_synonym (names[i], types[i])) + return -1; + } + +#if SIZEOF_INT == SIZEOF_SHORT + if ((-1 == SLclass_create_synonym ("Short_Type", SLANG_INT_TYPE)) + || (-1 == SLclass_create_synonym ("UShort_Type", SLANG_UINT_TYPE)) + || (-1 == _SLclass_copy_class (SLANG_SHORT_TYPE, SLANG_INT_TYPE)) + || (-1 == _SLclass_copy_class (SLANG_USHORT_TYPE, SLANG_UINT_TYPE))) + return -1; +#endif +#if SIZEOF_INT == SIZEOF_LONG + if ((-1 == SLclass_create_synonym ("Long_Type", SLANG_INT_TYPE)) + || (-1 == SLclass_create_synonym ("ULong_Type", SLANG_UINT_TYPE)) + || (-1 == _SLclass_copy_class (SLANG_LONG_TYPE, SLANG_INT_TYPE)) + || (-1 == _SLclass_copy_class (SLANG_ULONG_TYPE, SLANG_UINT_TYPE))) + return -1; +#endif + return 0; +} + +int _SLarith_register_types (void) +{ + SLang_Class_Type *cl; + int a_type, b_type; + int i, j; + +#if defined(HAVE_SETLOCALE) && defined(LC_NUMERIC) + /* make sure decimal point it used --- the parser requires it */ + (void) setlocale (LC_NUMERIC, "C"); +#endif + + for (i = 0; i < 8; i++) + { + Integer_Info_Type *info; + + info = Integer_Types + i; + + if (info->name == NULL) + { + /* This happens when the object is the same size as an integer + * For this case, we really want to copy the integer class. + * We will handle that when the synonym is created. + */ + continue; + } + + if (NULL == (cl = SLclass_allocate_class (info->name))) + return -1; + + (void) SLclass_set_string_function (cl, arith_string); + (void) SLclass_set_push_function (cl, integer_push); + (void) SLclass_set_pop_function (cl, integer_pop); + cl->cl_push_literal = info->push_literal; + cl->cl_to_bool = integer_to_bool; + + cl->cl_cmp = info->cmp_fun; + + if (-1 == SLclass_register_class (cl, info->data_type, info->sizeof_type, + SLANG_CLASS_TYPE_SCALAR)) + return -1; + if (-1 == SLclass_add_unary_op (info->data_type, info->unary_fun, arith_unary_op_result)) + return -1; + + _SLarith_Is_Arith_Type [info->data_type] = 1; + } + +#if SLANG_HAS_FLOAT + if (NULL == (cl = SLclass_allocate_class ("Double_Type"))) + return -1; + (void) SLclass_set_push_function (cl, double_push); + (void) SLclass_set_pop_function (cl, double_pop); + (void) SLclass_set_string_function (cl, arith_string); + cl->cl_byte_code_destroy = double_byte_code_destroy; + cl->cl_push_literal = double_push_literal; + cl->cl_cmp = double_cmp_function; + + if (-1 == SLclass_register_class (cl, SLANG_DOUBLE_TYPE, sizeof (double), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + if (-1 == SLclass_add_unary_op (SLANG_DOUBLE_TYPE, double_unary_op, arith_unary_op_result)) + return -1; + _SLarith_Is_Arith_Type [SLANG_DOUBLE_TYPE] = 2; + + if (NULL == (cl = SLclass_allocate_class ("Float_Type"))) + return -1; + (void) SLclass_set_string_function (cl, arith_string); + (void) SLclass_set_push_function (cl, float_push); + (void) SLclass_set_pop_function (cl, float_pop); + cl->cl_cmp = float_cmp_function; + + if (-1 == SLclass_register_class (cl, SLANG_FLOAT_TYPE, sizeof (float), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + if (-1 == SLclass_add_unary_op (SLANG_FLOAT_TYPE, float_unary_op, arith_unary_op_result)) + return -1; + _SLarith_Is_Arith_Type [SLANG_FLOAT_TYPE] = 2; +#endif + + if (-1 == create_synonyms ()) + return -1; + + for (a_type = 0; a_type <= MAXIMUM_ARITH_TYPE_VALUE; a_type++) + { + if (-1 == (i = Type_Precedence_Table [a_type])) + continue; + + for (b_type = 0; b_type <= MAXIMUM_ARITH_TYPE_VALUE; b_type++) + { + int implicit_ok; + + if (-1 == (j = Type_Precedence_Table [b_type])) + continue; + + /* Allow implicit typecast, except from into to float */ + implicit_ok = ((j >= FLOAT_PRECEDENCE_VALUE) + || (i < FLOAT_PRECEDENCE_VALUE)); + + if (-1 == SLclass_add_binary_op (a_type, b_type, arith_bin_op, arith_bin_op_result)) + return -1; + + if (i != j) + if (-1 == SLclass_add_typecast (a_type, b_type, _SLarith_typecast, implicit_ok)) + return -1; + } + } + + return 0; +} + +#if _SLANG_OPTIMIZE_FOR_SPEED + +static void promote_objs (SLang_Object_Type *a, SLang_Object_Type *b, + SLang_Object_Type *c, SLang_Object_Type *d) +{ + unsigned char ia, ib, ic, id; + int i, j; + void (*copy)(VOID_STAR, VOID_STAR, unsigned int); + + ia = a->data_type; + ib = b->data_type; + + ic = _SLarith_promote_type (ia); + + if (ic == ib) id = ic; /* already promoted */ + else id = _SLarith_promote_type (ib); + + i = Type_Precedence_Table[ic]; + j = Type_Precedence_Table[id]; + if (i > j) + { + id = ic; + j = i; + } + + c->data_type = d->data_type = id; + + i = Type_Precedence_Table[ia]; + copy = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[i][j].copy_function; + (*copy) ((VOID_STAR) &c->v, (VOID_STAR)&a->v, 1); + + i = Type_Precedence_Table[ib]; + copy = (void (*)(VOID_STAR, VOID_STAR, unsigned int)) + Binary_Matrix[i][j].copy_function; + (*copy) ((VOID_STAR) &d->v, (VOID_STAR)&b->v, 1); +} + +int _SLarith_bin_op (SLang_Object_Type *oa, SLang_Object_Type *ob, int op) +{ + unsigned char a_type, b_type; + + a_type = oa->data_type; + b_type = ob->data_type; + + if (a_type != b_type) + { + SLang_Object_Type obj_a, obj_b; + + /* Handle common cases */ + if ((a_type == SLANG_INT_TYPE) + && (b_type == SLANG_DOUBLE_TYPE)) + return double_double_scalar_bin_op (oa->v.int_val, ob->v.double_val, op); + + if ((a_type == SLANG_DOUBLE_TYPE) + && (b_type == SLANG_INT_TYPE)) + return double_double_scalar_bin_op (oa->v.double_val, ob->v.int_val, op); + + /* Otherwise do it the hard way */ + promote_objs (oa, ob, &obj_a, &obj_b); + oa = &obj_a; + ob = &obj_b; + + a_type = oa->data_type; + b_type = ob->data_type; + } + + + switch (a_type) + { + case SLANG_CHAR_TYPE: + return int_int_scalar_bin_op (oa->v.char_val, ob->v.char_val, op); + + case SLANG_UCHAR_TYPE: + return int_int_scalar_bin_op (oa->v.uchar_val, ob->v.uchar_val, op); + + case SLANG_SHORT_TYPE: + return int_int_scalar_bin_op (oa->v.short_val, ob->v.short_val, op); + + case SLANG_USHORT_TYPE: +# if SIZEOF_INT == SIZEOF_SHORT + return uint_uint_scalar_bin_op (oa->v.ushort_val, ob->v.ushort_val, op); +# else + return int_int_scalar_bin_op ((int)oa->v.ushort_val, (int)ob->v.ushort_val, op); +# endif + +#if SIZEOF_LONG == SIZEOF_INT + case SLANG_LONG_TYPE: +#endif + case SLANG_INT_TYPE: + return int_int_scalar_bin_op (oa->v.int_val, ob->v.int_val, op); + +#if SIZEOF_LONG == SIZEOF_INT + case SLANG_ULONG_TYPE: +#endif + case SLANG_UINT_TYPE: + return uint_uint_scalar_bin_op (oa->v.uint_val, ob->v.uint_val, op); + +#if SIZEOF_LONG != SIZEOF_INT + case SLANG_LONG_TYPE: + return long_long_scalar_bin_op (oa->v.long_val, ob->v.long_val, op); + case SLANG_ULONG_TYPE: + return ulong_ulong_scalar_bin_op (oa->v.ulong_val, ob->v.ulong_val, op); +#endif + case SLANG_FLOAT_TYPE: + return float_float_scalar_bin_op (oa->v.float_val, ob->v.float_val, op); + case SLANG_DOUBLE_TYPE: + return double_double_scalar_bin_op (oa->v.double_val, ob->v.double_val, op); + } + + return 1; +} +#endif diff --git a/mdk-stage1/slang/slarith.inc b/mdk-stage1/slang/slarith.inc new file mode 100644 index 000000000..efa8a5e04 --- /dev/null +++ b/mdk-stage1/slang/slarith.inc @@ -0,0 +1,783 @@ +/* -*- c -*- */ + +/* This include file is a template for defining arithmetic binary operations + * on arithmetic types. I realize that doing it this way is not very + * elegant but it minimizes the number of lines of code and I believe it + * promotes clarity. + */ + +/* The following macros should be properly defined before including this file: + * + * GENERIC_BINARY_FUNCTION: The name of the binary function + * GENERIC_TYPE: The class data type + * MOD_FUNCTION: The function to use for mod + * ABS_FUNCTION: Name of the abs function + * SIGN_FUNCTION: Name of the sign function + * GENERIC_UNARY_FUNCTION Name of the unary function + * + * If GENERIC_BIT_OPERATIONS is defined, the bit-level binary operators + * will get included. If the data type has a power operation (SLANG_POW), + * then POW_FUNCTION should be defined to return POW_RESULT_TYPE. + */ +#ifdef GENERIC_BINARY_FUNCTION + +static int GENERIC_BINARY_FUNCTION +(int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + GENERIC_TYPE *c, *a, *b; +#ifdef POW_FUNCTION + POW_RESULT_TYPE *d; +#endif + unsigned int n; +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + unsigned int n_max, da, db; +#endif + char *cc; + + (void) a_type; /* Both SLANG_INT_TYPE */ + (void) b_type; + + a = (GENERIC_TYPE *) ap; + b = (GENERIC_TYPE *) bp; + c = (GENERIC_TYPE *) cp; + cc = (char *) cp; + +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + if (na == 1) da = 0; else da = 1; + if (nb == 1) db = 0; else db = 1; + + if (na > nb) n_max = na; else n_max = nb; +#endif + + switch (op) + { + default: + return 0; +#ifdef POW_FUNCTION + case SLANG_POW: + d = (POW_RESULT_TYPE *) cp; +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + d[n] = POW_FUNCTION(*a, *b); + a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + d[n] = POW_FUNCTION(a[n],b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + if (xb == 2) + for (n = 0; n < na; n++) + d[n] = a[n] * a[n]; + else + for (n = 0; n < na; n++) + d[n] = POW_FUNCTION(a[n], xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + d[n] = POW_FUNCTION(xa, b[n]); + } +#endif + break; +#endif + case SLANG_PLUS: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a + *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] + b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] + xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa + b[n]; + } +#endif + break; + + case SLANG_MINUS: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a - *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] - b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] - xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa - b[n]; + } +#endif + break; + + case SLANG_TIMES: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a * *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] * b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] * xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa * b[n]; + } +#endif + break; + + case SLANG_DIVIDE: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + if (*b == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = (*a / *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + { + if (b[n] == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = a[n] / b[n]; + } + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + + if (xb == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + for (n = 0; n < na; n++) + c[n] = a[n] / xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + { + if (b[n] == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = xa / b[n]; + } + } +#endif + break; + + case SLANG_MOD: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + if (*b == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = MOD_FUNCTION(*a, *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + { + if (b[n] == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = MOD_FUNCTION(a[n],b[n]); + } + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + if (xb == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + for (n = 0; n < na; n++) + c[n] = MOD_FUNCTION(a[n],xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + { + if (b[n] == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = MOD_FUNCTION(xa,b[n]); + } + } +#endif + break; + +#ifdef GENERIC_BIT_OPERATIONS + case SLANG_BAND: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a & *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] & b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] & xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa & b[n]; + } +#endif + break; + + case SLANG_BXOR: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a ^ *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] ^ b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] ^ xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa ^ b[n]; + } +#endif + break; + + case SLANG_BOR: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a | *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] | b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] | xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa | b[n]; + } +#endif + break; + + case SLANG_SHL: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a << *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] << b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] << xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa << b[n]; + } +#endif + break; + + case SLANG_SHR: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + c[n] = (*a >> *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + c[n] = a[n] >> b[n]; + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + c[n] = a[n] >> xb; + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + c[n] = xa >> b[n]; + } +#endif + break; +#endif /* GENERIC_BIT_OPERATIONS */ + case SLANG_EQ: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a == *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] == b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] == xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa == b[n]); + } +#endif + break; + + case SLANG_NE: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a != *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] != b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] != xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa != b[n]); + } +#endif + break; + + case SLANG_GT: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a > *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] > b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] > xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa > b[n]); + } +#endif + break; + + case SLANG_GE: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a >= *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] >= b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] >= xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa >= b[n]); + } +#endif + break; + + case SLANG_LT: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a < *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] < b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] < xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa < b[n]); + } +#endif + break; + + case SLANG_LE: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a <= *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] <= b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] <= xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa <= b[n]); + } +#endif + break; + + case SLANG_OR: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a || *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] || b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] || xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa || b[n]); + } +#endif + break; + + case SLANG_AND: +#if _SLANG_OPTIMIZE_FOR_SPEED < 2 + for (n = 0; n < n_max; n++) + { + cc[n] = (*a && *b); a += da; b += db; + } +#else + if (na == nb) + { + for (n = 0; n < na; n++) + cc[n] = (a[n] && b[n]); + } + else if (nb == 1) + { + GENERIC_TYPE xb = *b; + for (n = 0; n < na; n++) + cc[n] = (a[n] && xb); + } + else /* if (na == 1) */ + { + GENERIC_TYPE xa = *a; + for (n = 0; n < nb; n++) + cc[n] = (xa && b[n]); + } +#endif + break; + } + return 1; +} + +#endif /* GENERIC_BINARY_FUNCTION */ + + +#ifdef GENERIC_UNARY_FUNCTION + +static int GENERIC_UNARY_FUNCTION +(int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + VOID_STAR bp + ) +{ + GENERIC_TYPE *a, *b; + unsigned int n; + int *ib; + + (void) a_type; + + a = (GENERIC_TYPE *) ap; + b = (GENERIC_TYPE *) bp; + + switch (op) + { + default: + return 0; + + case SLANG_PLUSPLUS: + for (n = 0; n < na; n++) b[n] = (a[n] + 1); + break; + case SLANG_MINUSMINUS: + for (n = 0; n < na; n++) b[n] = (a[n] - 1); + break; + case SLANG_CHS: + for (n = 0; n < na; n++) b[n] = (GENERIC_TYPE) -(a[n]); + break; + case SLANG_SQR: + for (n = 0; n < na; n++) b[n] = (a[n] * a[n]); + break; + case SLANG_MUL2: + for (n = 0; n < na; n++) b[n] = (2 * a[n]); + break; + case SLANG_ABS: + for (n = 0; n < na; n++) b[n] = ABS_FUNCTION (a[n]); + break; + case SLANG_SIGN: + ib = (int *) bp; + for (n = 0; n < na; n++) + ib[n] = SIGN_FUNCTION(a[n]); + break; + +#ifdef GENERIC_BIT_OPERATIONS + case SLANG_NOT: + for (n = 0; n < na; n++) b[n] = !(a[n]); + break; + case SLANG_BNOT: + for (n = 0; n < na; n++) b[n] = ~(a[n]); + break; +#endif + } + + return 1; +} +#endif /* GENERIC_UNARY_FUNCTION */ + + +#ifdef SCALAR_BINARY_FUNCTION + +static int SCALAR_BINARY_FUNCTION (GENERIC_TYPE a, GENERIC_TYPE b, int op) +{ + switch (op) + { + default: + return 1; + +#ifdef POW_FUNCTION + case SLANG_POW: + return PUSH_POW_OBJ_FUN(POW_FUNCTION(a, b)); +#endif + case SLANG_PLUS: + return PUSH_SCALAR_OBJ_FUN (a + b); + case SLANG_MINUS: + return PUSH_SCALAR_OBJ_FUN (a - b); + case SLANG_TIMES: + return PUSH_SCALAR_OBJ_FUN (a * b); + case SLANG_DIVIDE: + if (b == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + return PUSH_SCALAR_OBJ_FUN (a / b); + case SLANG_MOD: + if (b == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + return PUSH_SCALAR_OBJ_FUN (MOD_FUNCTION(a,b)); +#ifdef GENERIC_BIT_OPERATIONS + case SLANG_BAND: + return PUSH_SCALAR_OBJ_FUN (a & b); + case SLANG_BXOR: + return PUSH_SCALAR_OBJ_FUN (a ^ b); + case SLANG_BOR: + return PUSH_SCALAR_OBJ_FUN (a | b); + case SLANG_SHL: + return PUSH_SCALAR_OBJ_FUN (a << b); + case SLANG_SHR: + return PUSH_SCALAR_OBJ_FUN (a >> b); +#endif + case SLANG_GT: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a > b)); + case SLANG_LT: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a < b)); + case SLANG_GE: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a >= b)); + case SLANG_LE: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a <= b)); + case SLANG_EQ: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a == b)); + case SLANG_NE: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a != b)); + case SLANG_OR: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a || b)); + case SLANG_AND: return SLclass_push_char_obj (SLANG_CHAR_TYPE, (char)(a && b)); + } +} + +#endif /* SCALAR_BINARY_FUNCTION */ + +#ifdef CMP_FUNCTION +static int CMP_FUNCTION (unsigned char unused, VOID_STAR a, VOID_STAR b, int *c) +{ + GENERIC_TYPE x, y; + + (void) unused; + x = *(GENERIC_TYPE *) a; + y = *(GENERIC_TYPE *) b; + + if (x > y) *c = 1; + else if (x == y) *c = 0; + else *c = -1; + + return 0; +} +#endif + +#undef CMP_FUNCTION +#undef SCALAR_BINARY_FUNCTION +#undef PUSH_POW_OBJ_FUN +#undef PUSH_SCALAR_OBJ_FUN +#undef GENERIC_BINARY_FUNCTION +#undef GENERIC_UNARY_FUNCTION +#undef GENERIC_BIT_OPERATIONS +#undef GENERIC_TYPE +#undef POW_FUNCTION +#undef POW_RESULT_TYPE +#undef MOD_FUNCTION +#undef ABS_FUNCTION +#undef SIGN_FUNCTION diff --git a/mdk-stage1/slang/slarray.c b/mdk-stage1/slang/slarray.c new file mode 100644 index 000000000..0b9a1406c --- /dev/null +++ b/mdk-stage1/slang/slarray.c @@ -0,0 +1,3139 @@ +/* Array manipulation routines for S-Lang */ +/* Copyright (c) 1997, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#define SL_APP_WANTS_FOREACH +#include "slang.h" +#include "_slang.h" + +typedef struct +{ + int first_index; + int last_index; + int delta; +} +SLarray_Range_Array_Type; + +/* Use SLang_pop_array when a linear array is required. */ +static int pop_array (SLang_Array_Type **at_ptr, int convert_scalar) +{ + SLang_Array_Type *at; + int one = 1; + int type; + + *at_ptr = NULL; + type = SLang_peek_at_stack (); + + switch (type) + { + case -1: + return -1; + + case SLANG_ARRAY_TYPE: + return SLclass_pop_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR *) at_ptr); + + case SLANG_NULL_TYPE: + convert_scalar = 0; + /* drop */ + default: + if (convert_scalar == 0) + { + SLdo_pop (); + SLang_verror (SL_TYPE_MISMATCH, "Context requires an array. Scalar not converted"); + return -1; + } + break; + } + + if (NULL == (at = SLang_create_array ((unsigned char) type, 0, NULL, &one, 1))) + return -1; + + if (-1 == at->cl->cl_apop ((unsigned char) type, at->data)) + { + SLang_free_array (at); + return -1; + } + + *at_ptr = at; + + return 0; +} + +static VOID_STAR linear_get_data_addr (SLang_Array_Type *at, int *dims) +{ + unsigned int num_dims; + unsigned int ofs; + unsigned int i; + int *max_dims; + + ofs = 0; + max_dims = at->dims; + num_dims = at->num_dims; + + for (i = 0; i < num_dims; i++) + { + int d = dims[i]; + + if (d < 0) + d = d + max_dims[i]; + + ofs = ofs * (unsigned int)max_dims [i] + (unsigned int) d; + } + + return (VOID_STAR) ((char *)at->data + (ofs * at->sizeof_type)); +} + +static VOID_STAR get_data_addr (SLang_Array_Type *at, int *dims) +{ + VOID_STAR data; + + data = at->data; + if (data == NULL) + { + SLang_verror (SL_UNKNOWN_ERROR, "Array has no data"); + return NULL; + } + + data = (*at->index_fun) (at, dims); + + if (data == NULL) + { + SLang_verror (SL_UNKNOWN_ERROR, "Unable to access array element"); + return NULL; + } + + return data; +} + +void _SLarray_free_array_elements (SLang_Class_Type *cl, VOID_STAR s, unsigned int num) +{ + unsigned int sizeof_type; + void (*f) (unsigned char, VOID_STAR); + char *p; + unsigned char type; + + if ((cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + || (cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR)) + return; + + f = cl->cl_destroy; + sizeof_type = cl->cl_sizeof_type; + type = cl->cl_data_type; + + p = (char *) s; + while (num != 0) + { + if (NULL != *(VOID_STAR *)p) + { + (*f) (type, (VOID_STAR)p); + *(VOID_STAR *) p = NULL; + } + p += sizeof_type; + num--; + } +} + +static int destroy_element (SLang_Array_Type *at, + int *dims, + VOID_STAR data) +{ + data = get_data_addr (at, dims); + if (data == NULL) + return -1; + + /* This function should only get called for arrays that have + * pointer elements. Do not call the destroy method if the element + * is NULL. + */ + if (NULL != *(VOID_STAR *)data) + { + (*at->cl->cl_destroy) (at->data_type, data); + *(VOID_STAR *) data = NULL; + } + return 0; +} + +/* This function only gets called when a new array is created. Thus there + * is no need to destroy the object first. + */ +static int new_object_element (SLang_Array_Type *at, + int *dims, + VOID_STAR data) +{ + data = get_data_addr (at, dims); + if (data == NULL) + return -1; + + return (*at->cl->cl_init_array_object) (at->data_type, data); +} + +static int next_index (int *dims, int *max_dims, unsigned int num_dims) +{ + while (num_dims) + { + int dims_i; + + num_dims--; + + dims_i = dims [num_dims] + 1; + if (dims_i != (int) max_dims [num_dims]) + { + dims [num_dims] = dims_i; + return 0; + } + dims [num_dims] = 0; + } + + return -1; +} + +static int do_method_for_all_elements (SLang_Array_Type *at, + int (*method)(SLang_Array_Type *, + int *, + VOID_STAR), + VOID_STAR client_data) +{ + int dims [SLARRAY_MAX_DIMS]; + int *max_dims; + unsigned int num_dims; + + if (at->num_elements == 0) + return 0; + + max_dims = at->dims; + num_dims = at->num_dims; + + SLMEMSET((char *)dims, 0, sizeof(dims)); + + do + { + if (-1 == (*method) (at, dims, client_data)) + return -1; + } + while (0 == next_index (dims, max_dims, num_dims)); + + return 0; +} + +void SLang_free_array (SLang_Array_Type *at) +{ + VOID_STAR data; + unsigned int flags; + + if (at == NULL) return; + + if (at->num_refs > 1) + { + at->num_refs -= 1; + return; + } + + data = at->data; + flags = at->flags; + + if (flags & SLARR_DATA_VALUE_IS_INTRINSIC) + return; /* not to be freed */ + + if (flags & SLARR_DATA_VALUE_IS_POINTER) + (void) do_method_for_all_elements (at, destroy_element, NULL); + + SLfree ((char *) data); + SLfree ((char *) at); +} + +SLang_Array_Type * +SLang_create_array1 (unsigned char type, int read_only, VOID_STAR data, + int *dims, unsigned int num_dims, int no_init) +{ + SLang_Class_Type *cl; + unsigned int i; + SLang_Array_Type *at; + unsigned int num_elements; + unsigned int sizeof_type; + unsigned int size; + + if (num_dims > SLARRAY_MAX_DIMS) + { + SLang_verror (SL_NOT_IMPLEMENTED, "%u dimensional arrays are not supported", num_dims); + return NULL; + } + + for (i = 0; i < num_dims; i++) + { + if (dims[i] < 0) + { + SLang_verror (SL_INVALID_PARM, "Size of array dim %u is less than 0", i); + return NULL; + } + } + + cl = _SLclass_get_class (type); + + at = (SLang_Array_Type *) SLmalloc (sizeof(SLang_Array_Type)); + if (at == NULL) + return NULL; + + SLMEMSET ((char*) at, 0, sizeof(SLang_Array_Type)); + + at->data_type = type; + at->cl = cl; + at->num_dims = num_dims; + at->num_refs = 1; + + if (read_only) at->flags = SLARR_DATA_VALUE_IS_READ_ONLY; + switch (cl->cl_class_type) + { + case SLANG_CLASS_TYPE_VECTOR: + case SLANG_CLASS_TYPE_SCALAR: + break; + + default: + at->flags |= SLARR_DATA_VALUE_IS_POINTER; + } + + num_elements = 1; + for (i = 0; i < num_dims; i++) + { + at->dims [i] = dims[i]; + num_elements = dims [i] * num_elements; + } + + /* Now set the rest of the unused dimensions to 1. This makes it easier + * when transposing arrays. + */ + while (i < SLARRAY_MAX_DIMS) + at->dims[i++] = 1; + + at->num_elements = num_elements; + at->index_fun = linear_get_data_addr; + at->sizeof_type = sizeof_type = cl->cl_sizeof_type; + + if (data != NULL) + { + at->data = data; + return at; + } + + size = num_elements * sizeof_type; + + if (size == 0) size = 1; + + if (NULL == (data = (VOID_STAR) SLmalloc (size))) + { + SLang_free_array (at); + return NULL; + } + + if (no_init == 0) + SLMEMSET ((char *) data, 0, size); + + at->data = data; + + if ((cl->cl_init_array_object != NULL) + && (-1 == do_method_for_all_elements (at, new_object_element, NULL))) + { + SLang_free_array (at); + return NULL; + } + return at; +} + +SLang_Array_Type * +SLang_create_array (unsigned char type, int read_only, VOID_STAR data, + int *dims, unsigned int num_dims) +{ + return SLang_create_array1 (type, read_only, data, dims, num_dims, 0); +} + +int SLang_add_intrinsic_array (char *name, + unsigned char type, + int read_only, + VOID_STAR data, + unsigned int num_dims, ...) +{ + va_list ap; + unsigned int i; + int dims[SLARRAY_MAX_DIMS]; + SLang_Array_Type *at; + + if ((num_dims > SLARRAY_MAX_DIMS) + || (name == NULL) + || (data == NULL)) + { + SLang_verror (SL_INVALID_PARM, "Unable to create intrinsic array"); + return -1; + } + + va_start (ap, num_dims); + for (i = 0; i < num_dims; i++) + dims [i] = va_arg (ap, int); + va_end (ap); + + at = SLang_create_array (type, read_only, data, dims, num_dims); + if (at == NULL) + return -1; + at->flags |= SLARR_DATA_VALUE_IS_INTRINSIC; + + /* Note: The variable that refers to the intrinsic array is regarded as + * read-only. That way, Array_Name = another_array; will fail. + */ + if (-1 == SLadd_intrinsic_variable (name, (VOID_STAR) at, SLANG_ARRAY_TYPE, 1)) + { + SLang_free_array (at); + return -1; + } + return 0; +} + +static int pop_array_indices (int *dims, unsigned int num_dims) +{ + unsigned int n; + int i; + + if (num_dims > SLARRAY_MAX_DIMS) + { + SLang_verror (SL_INVALID_PARM, "Array size not supported"); + return -1; + } + + n = num_dims; + while (n != 0) + { + n--; + if (-1 == SLang_pop_integer (&i)) + return -1; + + dims[n] = i; + } + + return 0; +} + +int SLang_push_array (SLang_Array_Type *at, int free_flag) +{ + if (at == NULL) + return SLang_push_null (); + + at->num_refs += 1; + + if (0 == SLclass_push_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR) at)) + { + if (free_flag) + SLang_free_array (at); + return 0; + } + + at->num_refs -= 1; + + if (free_flag) SLang_free_array (at); + return -1; +} + +/* This function gets called via expressions such as Double_Type[10, 20]; + */ +static int push_create_new_array (void) +{ + unsigned int num_dims; + SLang_Array_Type *at; + unsigned char type; + int dims [SLARRAY_MAX_DIMS]; + int (*anew) (unsigned char, unsigned int); + + num_dims = (SLang_Num_Function_Args - 1); + + if (-1 == _SLang_pop_datatype (&type)) + return -1; + + anew = (_SLclass_get_class (type))->cl_anew; + if (anew != NULL) + return (*anew) (type, num_dims); + + if (-1 == pop_array_indices (dims, num_dims)) + return -1; + + if (NULL == (at = SLang_create_array (type, 0, NULL, dims, num_dims))) + return -1; + + return SLang_push_array (at, 1); +} + +static int push_element_at_addr (SLang_Array_Type *at, + VOID_STAR data, int allow_null) +{ + SLang_Class_Type *cl; + + cl = at->cl; + if ((at->flags & SLARR_DATA_VALUE_IS_POINTER) + && (*(VOID_STAR *) data == NULL)) + { + if (allow_null) + return SLang_push_null (); + + SLang_verror (SL_VARIABLE_UNINITIALIZED, + "%s array has unitialized element", cl->cl_name); + return -1; + } + + return (*cl->cl_apush)(at->data_type, data); +} + +static int coerse_array_to_linear (SLang_Array_Type *at) +{ + SLarray_Range_Array_Type *range; + int *data; + int xmin, dx; + unsigned int i, imax; + + /* FIXME: Priority = low. This assumes that if an array is not linear, then + * it is a range. + */ + if (0 == (at->flags & SLARR_DATA_VALUE_IS_RANGE)) + return 0; + + range = (SLarray_Range_Array_Type *) at->data; + xmin = range->first_index; + dx = range->delta; + + imax = at->num_elements; + data = (int *) SLmalloc ((imax + 1) * sizeof (int)); + if (data == NULL) + return -1; + + for (i = 0; i < imax; i++) + { + data [i] = xmin; + xmin += dx; + } + + SLfree ((char *) range); + at->data = (VOID_STAR) data; + at->flags &= ~SLARR_DATA_VALUE_IS_RANGE; + at->index_fun = linear_get_data_addr; + return 0; +} + +static void +free_index_objects (SLang_Object_Type *index_objs, unsigned int num_indices) +{ + unsigned int i; + SLang_Object_Type *obj; + + for (i = 0; i < num_indices; i++) + { + obj = index_objs + i; + if (obj->data_type != 0) + SLang_free_object (obj); + } +} + +static int +pop_indices (SLang_Object_Type *index_objs, unsigned int num_indices, + int *is_index_array) +{ + unsigned int i; + + SLMEMSET((char *) index_objs, 0, num_indices * sizeof (SLang_Object_Type)); + + *is_index_array = 0; + + if (num_indices >= SLARRAY_MAX_DIMS) + { + SLang_verror (SL_INVALID_PARM, "too many indices for array"); + return -1; + } + + i = num_indices; + while (i != 0) + { + SLang_Object_Type *obj; + + i--; + obj = index_objs + i; + if (-1 == _SLang_pop_object_of_type (SLANG_INT_TYPE, obj, 1)) + goto return_error; + + if (obj->data_type == SLANG_ARRAY_TYPE) + { + SLang_Array_Type *at = obj->v.array_val; + + if (at->num_dims == 1) + { + if ((num_indices == 1) + && (0 == (at->flags & SLARR_DATA_VALUE_IS_RANGE))) + *is_index_array = 1; + } + else + { + SLang_verror (SL_INVALID_PARM, "expecting a 1-d index array"); + goto return_error; + } + } + } + + return 0; + + return_error: + free_index_objects (index_objs, num_indices); + return -1; +} + +/* Here ind_at is a linear 1-d array of indices */ +static int +check_index_array_ranges (SLang_Array_Type *at, SLang_Array_Type *ind_at) +{ + int *indices, *indices_max; + unsigned int num_elements; + + num_elements = at->num_elements; + indices = (int *) ind_at->data; + indices_max = indices + ind_at->num_elements; + + while (indices < indices_max) + { + unsigned int d; + + d = (unsigned int) *indices++; + if (d >= num_elements) + { + SLang_verror (SL_INVALID_PARM, + "index-array is out of range"); + return -1; + } + } + return 0; +} + +static int +transfer_n_elements (SLang_Array_Type *at, VOID_STAR dest_data, VOID_STAR src_data, + unsigned int sizeof_type, unsigned int n, int is_ptr) +{ + unsigned char data_type; + SLang_Class_Type *cl; + + if (is_ptr == 0) + { + SLMEMCPY ((char *) dest_data, (char *)src_data, n * sizeof_type); + return 0; + } + + data_type = at->data_type; + cl = at->cl; + + while (n != 0) + { + if (*(VOID_STAR *)dest_data != NULL) + { + (*cl->cl_destroy) (data_type, dest_data); + *(VOID_STAR *) dest_data = NULL; + } + + if (*(VOID_STAR *) src_data == NULL) + *(VOID_STAR *) dest_data = NULL; + else + { + if (-1 == (*cl->cl_acopy) (data_type, src_data, dest_data)) + /* No need to destroy anything */ + return -1; + } + + src_data = (VOID_STAR) ((char *)src_data + sizeof_type); + dest_data = (VOID_STAR) ((char *)dest_data + sizeof_type); + + n--; + } + + return 0; +} + +int +_SLarray_aget_transfer_elem (SLang_Array_Type *at, int *indices, + VOID_STAR new_data, unsigned int sizeof_type, int is_ptr) +{ + VOID_STAR at_data; + + /* Since 1 element is being transferred, there is not need to coerse + * the array to linear. + */ + if (NULL == (at_data = get_data_addr (at, indices))) + return -1; + + return transfer_n_elements (at, new_data, at_data, sizeof_type, 1, is_ptr); +} + +/* Here the ind_at index-array is a 1-d array of indices. This function + * creates a 1-d array of made up of values of 'at' at the locations + * specified by the indices. The result is pushed. + */ +static int +aget_from_index_array (SLang_Array_Type *at, + SLang_Array_Type *ind_at) +{ + SLang_Array_Type *new_at; + int *indices, *indices_max; + unsigned char *new_data, *src_data; + unsigned int sizeof_type; + int is_ptr; + + if (-1 == coerse_array_to_linear (at)) + return -1; + + if (-1 == coerse_array_to_linear (ind_at)) + return -1; + + if (-1 == check_index_array_ranges (at, ind_at)) + return -1; + + if (NULL == (new_at = SLang_create_array (at->data_type, 0, NULL, ind_at->dims, 1))) + return -1; + + /* Since the index array is linear, I can address it directly */ + indices = (int *) ind_at->data; + indices_max = indices + ind_at->num_elements; + + src_data = (unsigned char *) at->data; + new_data = (unsigned char *) new_at->data; + sizeof_type = new_at->sizeof_type; + is_ptr = (new_at->flags & SLARR_DATA_VALUE_IS_POINTER); + + while (indices < indices_max) + { + unsigned int offset; + + offset = sizeof_type * (unsigned int)*indices; + if (-1 == transfer_n_elements (at, (VOID_STAR) new_data, + (VOID_STAR) (src_data + offset), + sizeof_type, 1, is_ptr)) + { + SLang_free_array (new_at); + return -1; + } + + new_data += sizeof_type; + indices++; + } + + return SLang_push_array (new_at, 1); +} + +/* This is extremely ugly. It is due to the fact that the index_objects + * may contain ranges. This is a utility function for the aget/aput + * routines + */ +static int +convert_nasty_index_objs (SLang_Array_Type *at, + SLang_Object_Type *index_objs, + unsigned int num_indices, + int **index_data, + int *range_buf, int *range_delta_buf, + int *max_dims, + unsigned int *num_elements, + int *is_array, int is_dim_array[SLARRAY_MAX_DIMS]) +{ + unsigned int i, total_num_elements; + SLang_Array_Type *ind_at; + + if (num_indices != at->num_dims) + { + SLang_verror (SL_INVALID_PARM, "Array requires %u indices", at->num_dims); + return -1; + } + + *is_array = 0; + total_num_elements = 1; + for (i = 0; i < num_indices; i++) + { + int max_index, min_index; + SLang_Object_Type *obj; + int at_dims_i; + + at_dims_i = at->dims[i]; + obj = index_objs + i; + range_delta_buf [i] = 0; + + if (obj->data_type == SLANG_INT_TYPE) + { + range_buf [i] = min_index = max_index = obj->v.int_val; + max_dims [i] = 1; + index_data[i] = range_buf + i; + is_dim_array[i] = 0; + } + else + { + *is_array = 1; + is_dim_array[i] = 1; + ind_at = obj->v.array_val; + + if (ind_at->flags & SLARR_DATA_VALUE_IS_RANGE) + { + SLarray_Range_Array_Type *r; + int delta; + int first_index, last_index; + + r = (SLarray_Range_Array_Type *) ind_at->data; + + /* In an array indexing context, range arrays have different + * semantics. Consider a[[0:10]]. Clearly this means elements + * 0-10 of a. But what does a[[0:-1]] mean? By itself, + * [0:-1] is a null matrix []. But, it is useful in an + * indexing context to allow -1 to refer to the last element + * of the array. Similarly, [-3:-1] refers to the last 3 + * elements. + * + * However, [-1:-3] does not refer to any of the elements. + */ + if ((first_index = r->first_index) < 0) + { + if (at_dims_i != 0) + first_index = (at_dims_i + first_index) % at_dims_i; + } + + if ((last_index = r->last_index) < 0) + { + if (at_dims_i != 0) + last_index = (at_dims_i + last_index) % at_dims_i; + } + + delta = r->delta; + + range_delta_buf [i] = delta; + range_buf[i] = first_index; + + if (delta > 0) + { + if (first_index > last_index) + max_dims[i] = min_index = max_index = 0; + else + { + max_index = min_index = first_index; + while (max_index + delta <= last_index) + max_index += delta; + max_dims [i] = 1 + (max_index - min_index) / delta; + } + } + else + { + if (first_index < last_index) + max_dims[i] = min_index = max_index = 0; + else + { + min_index = max_index = first_index; + while (min_index + delta >= last_index) + min_index += delta; + max_dims [i] = 1 + (max_index - min_index) / (-delta); + } + } + } + else + { + int *tmp, *tmp_max; + + if (0 == (max_dims[i] = ind_at->num_elements)) + { + total_num_elements = 0; + break; + } + + tmp = (int *) ind_at->data; + tmp_max = tmp + ind_at->num_elements; + index_data [i] = tmp; + + min_index = max_index = *tmp; + while (tmp < tmp_max) + { + if (max_index > *tmp) + max_index = *tmp; + if (min_index < *tmp) + min_index = *tmp; + + tmp++; + } + } + } + + if ((at_dims_i == 0) && (max_dims[i] == 0)) + { + total_num_elements = 0; + continue; + } + + if (max_index < 0) + max_index += at_dims_i; + if (min_index < 0) + min_index += at_dims_i; + + if ((min_index < 0) || (min_index >= at_dims_i) + || (max_index < 0) || (max_index >= at_dims_i)) + { + SLang_verror (SL_INVALID_PARM, "Array index %u ([%d:%d]) out of allowed range [0->%d]", + i, min_index, max_index, at_dims_i); + return -1; + } + + total_num_elements = total_num_elements * max_dims[i]; + } + + *num_elements = total_num_elements; + return 0; +} + +/* This routine pushes a 1-d vector of values from 'at' indexed by + * the objects 'index_objs'. These objects can either be integers or + * 1-d integer arrays. The fact that the 1-d arrays can be ranges + * makes this look ugly. + */ +static int +aget_from_indices (SLang_Array_Type *at, + SLang_Object_Type *index_objs, unsigned int num_indices) +{ + int *index_data [SLARRAY_MAX_DIMS]; + int range_buf [SLARRAY_MAX_DIMS]; + int range_delta_buf [SLARRAY_MAX_DIMS]; + int max_dims [SLARRAY_MAX_DIMS]; + unsigned int i, num_elements; + SLang_Array_Type *new_at; + int map_indices[SLARRAY_MAX_DIMS]; + int indices [SLARRAY_MAX_DIMS]; + unsigned int sizeof_type; + int is_ptr, ret, is_array; + char *new_data; + SLang_Class_Type *cl; + int is_dim_array[SLARRAY_MAX_DIMS]; + + if (-1 == convert_nasty_index_objs (at, index_objs, num_indices, + index_data, range_buf, range_delta_buf, + max_dims, &num_elements, &is_array, + is_dim_array)) + return -1; + + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + sizeof_type = at->sizeof_type; + + cl = _SLclass_get_class (at->data_type); + + if ((is_array == 0) && (num_elements == 1)) + { + new_data = (char *)cl->cl_transfer_buf; + memset (new_data, 0, sizeof_type); + new_at = NULL; + } + else + { + int i_num_elements = (int)num_elements; + + new_at = SLang_create_array (at->data_type, 0, NULL, &i_num_elements, 1); + if (NULL == new_at) + return -1; + if (num_elements == 0) + return SLang_push_array (new_at, 1); + + new_data = (char *)new_at->data; + } + + SLMEMSET((char *) map_indices, 0, sizeof(map_indices)); + do + { + for (i = 0; i < num_indices; i++) + { + int j; + + j = map_indices[i]; + + if (0 != range_delta_buf[i]) + indices[i] = range_buf[i] + j * range_delta_buf[i]; + else + indices[i] = index_data [i][j]; + } + + if (-1 == _SLarray_aget_transfer_elem (at, indices, (VOID_STAR)new_data, sizeof_type, is_ptr)) + { + SLang_free_array (new_at); + return -1; + } + new_data += sizeof_type; + } + while (0 == next_index (map_indices, max_dims, num_indices)); + + if (new_at != NULL) + { + int num_dims = 0; + /* Fixup dimensions on array */ + for (i = 0; i < num_indices; i++) + { + if (is_dim_array[i]) /* was: (max_dims[i] > 1) */ + { + new_at->dims[num_dims] = max_dims[i]; + num_dims++; + } + } + + if (num_dims != 0) new_at->num_dims = num_dims; + return SLang_push_array (new_at, 1); + } + + /* Here new_data is a whole new copy, so free it after the push */ + new_data -= sizeof_type; + if (is_ptr && (*(VOID_STAR *)new_data == NULL)) + ret = SLang_push_null (); + else + { + ret = (*cl->cl_apush) (at->data_type, (VOID_STAR)new_data); + (*cl->cl_adestroy) (at->data_type, (VOID_STAR)new_data); + } + + return ret; +} + +static int push_string_as_array (unsigned char *s, unsigned int len) +{ + int ilen; + SLang_Array_Type *at; + + ilen = (int) len; + + at = SLang_create_array (SLANG_UCHAR_TYPE, 0, NULL, &ilen, 1); + if (at == NULL) + return -1; + + memcpy ((char *)at->data, (char *)s, len); + return SLang_push_array (at, 1); +} + +static int pop_array_as_string (char **sp) +{ + SLang_Array_Type *at; + int ret; + + *sp = NULL; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE)) + return -1; + + ret = 0; + + if (NULL == (*sp = SLang_create_nslstring ((char *) at->data, at->num_elements))) + ret = -1; + + SLang_free_array (at); + return ret; +} + +static int pop_array_as_bstring (SLang_BString_Type **bs) +{ + SLang_Array_Type *at; + int ret; + + *bs = NULL; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE)) + return -1; + + ret = 0; + + if (NULL == (*bs = SLbstring_create ((unsigned char *) at->data, at->num_elements))) + ret = -1; + + SLang_free_array (at); + return ret; +} + +static int aget_from_array (unsigned int num_indices) +{ + SLang_Array_Type *at; + SLang_Object_Type index_objs [SLARRAY_MAX_DIMS]; + int ret; + int is_index_array; + unsigned int i; + + if (num_indices > SLARRAY_MAX_DIMS) + { + SLang_verror (SL_INVALID_PARM, "Number of dims must be less than %d", SLARRAY_MAX_DIMS); + return -1; + } + + if (-1 == pop_array (&at, 1)) + return -1; + + if (-1 == pop_indices (index_objs, num_indices, &is_index_array)) + { + SLang_free_array (at); + return -1; + } + + if (is_index_array == 0) + ret = aget_from_indices (at, index_objs, num_indices); + else + ret = aget_from_index_array (at, index_objs[0].v.array_val); + + SLang_free_array (at); + for (i = 0; i < num_indices; i++) + SLang_free_object (index_objs + i); + + return ret; +} + +static int push_string_element (unsigned char type, unsigned char *s, unsigned int len) +{ + int i; + + if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE) + { + char *str; + + /* The indices are array values. So, do this: */ + if (-1 == push_string_as_array (s, len)) + return -1; + + if (-1 == aget_from_array (1)) + return -1; + + if (type == SLANG_BSTRING_TYPE) + { + SLang_BString_Type *bs; + int ret; + + if (-1 == pop_array_as_bstring (&bs)) + return -1; + + ret = SLang_push_bstring (bs); + SLbstring_free (bs); + return ret; + } + + if (-1 == pop_array_as_string (&str)) + return -1; + return _SLang_push_slstring (str); /* frees s upon error */ + } + + if (-1 == SLang_pop_integer (&i)) + return -1; + + if (i < 0) i = i + (int)len; + if ((unsigned int) i > len) + i = len; /* get \0 character --- bstrings include it as well */ + + i = s[(unsigned int) i]; + + return SLang_push_integer (i); +} + +/* ARRAY[i, j, k] generates code: __args i j ...k ARRAY __aput/__aget + * Here i, j, ... k may be a mixture of integers and 1-d arrays, or + * a single 2-d array of indices. The 2-d index array is generated by the + * 'where' function. + * + * If ARRAY is of type DataType, then this function will create an array of + * the appropriate type. In that case, the indices i, j, ..., k must be + * integers. + */ +int _SLarray_aget (void) +{ + unsigned int num_indices; + int type; + int (*aget_fun) (unsigned char, unsigned int); + + num_indices = (SLang_Num_Function_Args - 1); + + type = SLang_peek_at_stack (); + switch (type) + { + case -1: + return -1; /* stack underflow */ + + case SLANG_DATATYPE_TYPE: + return push_create_new_array (); + + case SLANG_BSTRING_TYPE: + if (1 == num_indices) + { + SLang_BString_Type *bs; + int ret; + unsigned int len; + unsigned char *s; + + if (-1 == SLang_pop_bstring (&bs)) + return -1; + + if (NULL == (s = SLbstring_get_pointer (bs, &len))) + ret = -1; + else + ret = push_string_element (type, s, len); + + SLbstring_free (bs); + return ret; + } + break; + + case SLANG_STRING_TYPE: + if (1 == num_indices) + { + char *s; + int ret; + + if (-1 == SLang_pop_slstring (&s)) + return -1; + + ret = push_string_element (type, (unsigned char *)s, strlen (s)); + SLang_free_slstring (s); + return ret; + } + break; + + case SLANG_ARRAY_TYPE: + break; + + default: + aget_fun = _SLclass_get_class (type)->cl_aget; + if (NULL != aget_fun) + return (*aget_fun) (type, num_indices); + } + + return aget_from_array (num_indices); +} + +int +_SLarray_aput_transfer_elem (SLang_Array_Type *at, int *indices, + VOID_STAR data_to_put, unsigned int sizeof_type, int is_ptr) +{ + VOID_STAR at_data; + + /* Since 1 element is being transferred, there is no need to coerse + * the array to linear. + */ + if (NULL == (at_data = get_data_addr (at, indices))) + return -1; + + return transfer_n_elements (at, at_data, data_to_put, sizeof_type, 1, is_ptr); +} + +static int +aput_get_array_to_put (SLang_Class_Type *cl, unsigned int num_elements, int allow_array, + SLang_Array_Type **at_ptr, char **data_to_put, unsigned int *data_increment) +{ + unsigned char data_type; + SLang_Array_Type *at; + + *at_ptr = NULL; + + data_type = cl->cl_data_type; + if (-1 == SLclass_typecast (data_type, 1, allow_array)) + return -1; + + if ((data_type != SLANG_ARRAY_TYPE) + && (data_type != SLANG_ANY_TYPE) + && (SLANG_ARRAY_TYPE == SLang_peek_at_stack ())) + { + if (-1 == SLang_pop_array (&at, 0)) + return -1; + + if ((at->num_elements != num_elements) +#if 0 + || (at->num_dims != 1) +#endif + ) + { + SLang_verror (SL_TYPE_MISMATCH, "Array size is inappropriate for use with index-array"); + SLang_free_array (at); + return -1; + } + + *data_to_put = (char *) at->data; + *data_increment = at->sizeof_type; + *at_ptr = at; + return 0; + } + + *data_increment = 0; + *data_to_put = (char *) cl->cl_transfer_buf; + + if (-1 == (*cl->cl_apop)(data_type, (VOID_STAR) *data_to_put)) + return -1; + + return 0; +} + +static int +aput_from_indices (SLang_Array_Type *at, + SLang_Object_Type *index_objs, unsigned int num_indices) +{ + int *index_data [SLARRAY_MAX_DIMS]; + int range_buf [SLARRAY_MAX_DIMS]; + int range_delta_buf [SLARRAY_MAX_DIMS]; + int max_dims [SLARRAY_MAX_DIMS]; + unsigned int i, num_elements; + SLang_Array_Type *bt; + int map_indices[SLARRAY_MAX_DIMS]; + int indices [SLARRAY_MAX_DIMS]; + unsigned int sizeof_type; + int is_ptr, is_array, ret; + char *data_to_put; + unsigned int data_increment; + SLang_Class_Type *cl; + int is_dim_array [SLARRAY_MAX_DIMS]; + + if (-1 == convert_nasty_index_objs (at, index_objs, num_indices, + index_data, range_buf, range_delta_buf, + max_dims, &num_elements, &is_array, + is_dim_array)) + return -1; + + cl = at->cl; + + if (-1 == aput_get_array_to_put (cl, num_elements, is_array, + &bt, &data_to_put, &data_increment)) + return -1; + + sizeof_type = at->sizeof_type; + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + + ret = -1; + + SLMEMSET((char *) map_indices, 0, sizeof(map_indices)); + if (num_elements) do + { + for (i = 0; i < num_indices; i++) + { + int j; + + j = map_indices[i]; + + if (0 != range_delta_buf[i]) + indices[i] = range_buf[i] + j * range_delta_buf[i]; + else + indices[i] = index_data [i][j]; + } + + if (-1 == _SLarray_aput_transfer_elem (at, indices, (VOID_STAR)data_to_put, sizeof_type, is_ptr)) + goto return_error; + + data_to_put += data_increment; + } + while (0 == next_index (map_indices, max_dims, num_indices)); + + ret = 0; + + /* drop */ + + return_error: + if (bt == NULL) + { + if (is_ptr) + (*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR) data_to_put); + } + else SLang_free_array (bt); + + return ret; +} + +static int +aput_from_index_array (SLang_Array_Type *at, SLang_Array_Type *ind_at) +{ + int *indices, *indices_max; + unsigned int sizeof_type; + char *data_to_put, *dest_data; + unsigned int data_increment; + int is_ptr; + SLang_Array_Type *bt; + SLang_Class_Type *cl; + int ret; + + if (-1 == coerse_array_to_linear (at)) + return -1; + + if (-1 == coerse_array_to_linear (ind_at)) + return -1; + + if (-1 == check_index_array_ranges (at, ind_at)) + return -1; + + sizeof_type = at->sizeof_type; + + cl = at->cl; + + /* Note that if bt is returned as non NULL, then the array is a linear + * one. + */ + if (-1 == aput_get_array_to_put (cl, ind_at->num_elements, 1, + &bt, &data_to_put, &data_increment)) + return -1; + + /* Since the index array is linear, I can address it directly */ + indices = (int *) ind_at->data; + indices_max = indices + ind_at->num_elements; + + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + dest_data = (char *) at->data; + + ret = -1; + while (indices < indices_max) + { + unsigned int offset; + + offset = sizeof_type * (unsigned int)*indices; + + if (-1 == transfer_n_elements (at, (VOID_STAR) (dest_data + offset), + (VOID_STAR) data_to_put, sizeof_type, 1, + is_ptr)) + goto return_error; + + indices++; + data_to_put += data_increment; + } + + ret = 0; + /* Drop */ + + return_error: + + if (bt == NULL) + { + if (is_ptr) + (*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR)data_to_put); + } + else SLang_free_array (bt); + + return ret; +} + +/* ARRAY[i, j, k] = generates code: __args i j k ARRAY __aput + */ +int _SLarray_aput (void) +{ + unsigned int num_indices; + SLang_Array_Type *at; + SLang_Object_Type index_objs [SLARRAY_MAX_DIMS]; + int ret; + int is_index_array; + int (*aput_fun) (unsigned char, unsigned int); + int type; + + ret = -1; + num_indices = (SLang_Num_Function_Args - 1); + + type = SLang_peek_at_stack (); + switch (type) + { + case -1: + return -1; + + case SLANG_ARRAY_TYPE: + break; + + default: + if (NULL != (aput_fun = _SLclass_get_class (type)->cl_aput)) + return (*aput_fun) (type, num_indices); + break; + } + + if (-1 == SLang_pop_array (&at, 0)) + return -1; + + if (at->flags & SLARR_DATA_VALUE_IS_READ_ONLY) + { + SLang_verror (SL_READONLY_ERROR, "%s Array is read-only", + SLclass_get_datatype_name (at->data_type)); + SLang_free_array (at); + return -1; + } + + if (-1 == pop_indices (index_objs, num_indices, &is_index_array)) + { + SLang_free_array (at); + return -1; + } + + if (is_index_array == 0) + ret = aput_from_indices (at, index_objs, num_indices); + else + ret = aput_from_index_array (at, index_objs[0].v.array_val); + + SLang_free_array (at); + free_index_objects (index_objs, num_indices); + return ret; +} + +/* This is for 1-d matrices only. It is used by the sort function */ +static int push_element_at_index (SLang_Array_Type *at, int indx) +{ + VOID_STAR data; + + if (NULL == (data = get_data_addr (at, &indx))) + return -1; + + return push_element_at_addr (at, (VOID_STAR) data, 1); +} + +static SLang_Name_Type *Sort_Function; +static SLang_Array_Type *Sort_Array; + +static int sort_cmp_fun (int *a, int *b) +{ + int cmp; + + if (SLang_Error + || (-1 == push_element_at_index (Sort_Array, *a)) + || (-1 == push_element_at_index (Sort_Array, *b)) + || (-1 == SLexecute_function (Sort_Function)) + || (-1 == SLang_pop_integer (&cmp))) + { + /* DO not allow qsort to loop forever. Return something meaningful */ + if (*a > *b) return 1; + if (*a < *b) return -1; + return 0; + } + + return cmp; +} + +static int builtin_sort_cmp_fun (int *a, int *b) +{ + VOID_STAR a_data; + VOID_STAR b_data; + SLang_Class_Type *cl; + + cl = Sort_Array->cl; + + if ((SLang_Error == 0) + && (NULL != (a_data = get_data_addr (Sort_Array, a))) + && (NULL != (b_data = get_data_addr (Sort_Array, b)))) + { + int cmp; + + if ((Sort_Array->flags & SLARR_DATA_VALUE_IS_POINTER) + && ((*(VOID_STAR *) a_data == NULL) || (*(VOID_STAR *) a_data == NULL))) + { + SLang_verror (SL_VARIABLE_UNINITIALIZED, + "%s array has unitialized element", cl->cl_name); + } + else if (0 == (*cl->cl_cmp)(Sort_Array->data_type, a_data, b_data, &cmp)) + return cmp; + } + + + if (*a > *b) return 1; + if (*a == *b) return 0; + return -1; +} + +static void sort_array_internal (SLang_Array_Type *at_str, + SLang_Name_Type *entry, + int (*sort_fun)(int *, int *)) +{ + SLang_Array_Type *ind_at; + /* This is a silly hack to make up for braindead compilers and the lack of + * uniformity in prototypes for qsort. + */ + void (*qsort_fun) (char *, unsigned int, int, int (*)(int *, int *)); + int *indx; + int i, n; + int dims[1]; + + if (Sort_Array != NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, "array_sort is not recursive"); + return; + } + + n = at_str->num_elements; + + if (at_str->num_dims != 1) + { + SLang_verror (SL_INVALID_PARM, "sort is restricted to 1 dim arrays"); + return; + } + + dims [0] = n; + + if (NULL == (ind_at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, dims, 1))) + return; + + indx = (int *) ind_at->data; + for (i = 0; i < n; i++) indx[i] = i; + + if (n > 1) + { + qsort_fun = (void (*)(char *, unsigned int, int, int (*)(int *, + int *))) + qsort; + + Sort_Array = at_str; + Sort_Function = entry; + (*qsort_fun) ((char *) indx, n, sizeof (int), sort_fun); + } + + Sort_Array = NULL; + (void) SLang_push_array (ind_at, 1); +} + +static void sort_array (void) +{ + SLang_Name_Type *entry; + SLang_Array_Type *at; + int (*sort_fun) (int *, int *); + + if (SLang_Num_Function_Args != 1) + { + sort_fun = sort_cmp_fun; + + if (NULL == (entry = SLang_pop_function ())) + return; + + if (-1 == SLang_pop_array (&at, 1)) + return; + } + else + { + sort_fun = builtin_sort_cmp_fun; + if (-1 == SLang_pop_array (&at, 1)) + return; + if (at->cl->cl_cmp == NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "%s does not have a predefined sorting method", + at->cl->cl_name); + SLang_free_array (at); + return; + } + entry = NULL; + } + + sort_array_internal (at, entry, sort_fun); + SLang_free_array (at); + SLang_free_function (entry); +} + +static void bstring_to_array (SLang_BString_Type *bs) +{ + unsigned char *s; + unsigned int len; + + if (NULL == (s = SLbstring_get_pointer (bs, &len))) + (void) SLang_push_null (); + else + (void) push_string_as_array (s, len); +} + +static void array_to_bstring (SLang_Array_Type *at) +{ + unsigned int nbytes; + SLang_BString_Type *bs; + + nbytes = at->num_elements * at->sizeof_type; + bs = SLbstring_create ((unsigned char *)at->data, nbytes); + (void) SLang_push_bstring (bs); + SLbstring_free (bs); +} + +static void init_char_array (void) +{ + SLang_Array_Type *at; + char *s; + unsigned int n, ndim; + + if (SLang_pop_slstring (&s)) return; + + if (-1 == SLang_pop_array (&at, 0)) + goto free_and_return; + + if (at->data_type != SLANG_CHAR_TYPE) + { + SLang_doerror("Operation requires character array"); + goto free_and_return; + } + + n = strlen (s); + ndim = at->num_elements; + if (n > ndim) + { + SLang_doerror("String too big to init array"); + goto free_and_return; + } + + strncpy((char *) at->data, s, ndim); + /* drop */ + + free_and_return: + SLang_free_array (at); + SLang_free_slstring (s); +} + +static void array_info (void) +{ + SLang_Array_Type *at, *bt; + int num_dims; + + if (-1 == pop_array (&at, 1)) + return; + + num_dims = (int)at->num_dims; + + if (NULL != (bt = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &num_dims, 1))) + { + int *bdata; + int i; + int *a_dims; + + a_dims = at->dims; + bdata = (int *) bt->data; + for (i = 0; i < num_dims; i++) bdata [i] = a_dims [i]; + + if (0 == SLang_push_array (bt, 1)) + { + (void) SLang_push_integer ((int) at->num_dims); + (void) _SLang_push_datatype (at->data_type); + } + } + + SLang_free_array (at); +} + +static VOID_STAR range_get_data_addr (SLang_Array_Type *at, int *dims) +{ + static int value; + SLarray_Range_Array_Type *r; + int d; + + d = *dims; + r = (SLarray_Range_Array_Type *)at->data; + + if (d < 0) + d += at->dims[0]; + + value = r->first_index + d * r->delta; + return (VOID_STAR) &value; +} + +static SLang_Array_Type *inline_implicit_int_array (int *xminptr, int *xmaxptr, int *dxptr) +{ + int delta; + SLang_Array_Type *at; + int dims, idims; + SLarray_Range_Array_Type *data; + + if (dxptr == NULL) delta = 1; + else delta = *dxptr; + + if (delta == 0) + { + SLang_verror (SL_INVALID_PARM, "range-array increment must be non-zero"); + return NULL; + } + + data = (SLarray_Range_Array_Type *) SLmalloc (sizeof (SLarray_Range_Array_Type)); + if (data == NULL) + return NULL; + + SLMEMSET((char *) data, 0, sizeof (SLarray_Range_Array_Type)); + data->delta = delta; + dims = 0; + + if (xminptr != NULL) + data->first_index = *xminptr; + else + data->first_index = 0; + + if (xmaxptr != NULL) + data->last_index = *xmaxptr; + else + data->last_index = -1; + +/* if ((xminptr != NULL) && (xmaxptr != NULL)) + { */ + idims = 1 + (data->last_index - data->first_index) / delta; + if (idims > 0) + dims = idims; + /* } */ + + if (NULL == (at = SLang_create_array (SLANG_INT_TYPE, 0, (VOID_STAR) data, &dims, 1))) + return NULL; + + at->index_fun = range_get_data_addr; + at->flags |= SLARR_DATA_VALUE_IS_RANGE; + + return at; +} + +#if SLANG_HAS_FLOAT +static SLang_Array_Type *inline_implicit_floating_array (unsigned char type, + double *xminptr, double *xmaxptr, double *dxptr) +{ + int n, i; + SLang_Array_Type *at; + int dims; + double xmin, xmax, dx; + + if ((xminptr == NULL) || (xmaxptr == NULL)) + { + SLang_verror (SL_INVALID_PARM, "range-array has unknown size"); + return NULL; + } + xmin = *xminptr; + xmax = *xmaxptr; + if (dxptr == NULL) dx = 1.0; + else dx = *dxptr; + + if (dx == 0.0) + { + SLang_doerror ("range-array increment must be non-zero"); + return NULL; + } + + /* I have convinced myself that it is better to use semi-open intervals + * because of less ambiguities. So, [a:b:c] will represent the set of + * values a, a + c, a + 2c ... a + nc + * such that a + nc < b. That is, b lies outside the interval. + */ + + /* Allow for roundoff by adding 0.5 before truncation */ + n = (int)(1.5 + ((xmax - xmin) / dx)); + if (n <= 0) + n = 0; + else + { + double last = xmin + (n-1) * dx; + + if (dx > 0.0) + { + if (last >= xmax) + n -= 1; + } + else if (last <= xmax) + n -= 1; + } + + dims = n; + if (NULL == (at = SLang_create_array1 (type, 0, NULL, &dims, 1, 1))) + return NULL; + + if (type == SLANG_DOUBLE_TYPE) + { + double *ptr; + + ptr = (double *) at->data; + + for (i = 0; i < n; i++) + ptr[i] = xmin + i * dx; + } + else + { + float *ptr; + + ptr = (float *) at->data; + + for (i = 0; i < n; i++) + ptr[i] = (float) (xmin + i * dx); + } + return at; +} +#endif + +/* FIXME: Priority=medium + * This needs to be updated to work with all integer types. + */ +int _SLarray_inline_implicit_array (void) +{ + int int_vals[3]; +#if SLANG_HAS_FLOAT + double double_vals[3]; +#endif + int has_vals[3]; + unsigned int i, count; + SLang_Array_Type *at; + int precedence; + unsigned char type; + int is_int; + + count = SLang_Num_Function_Args; + + if (count == 2) + has_vals [2] = 0; + else if (count != 3) + { + SLang_doerror ("wrong number of arguments to __implicit_inline_array"); + return -1; + } + +#if SLANG_HAS_FLOAT + is_int = 1; +#endif + + type = 0; + precedence = 0; + + i = count; + while (i--) + { + int this_type, this_precedence; + + if (-1 == (this_type = SLang_peek_at_stack ())) + return -1; + + this_precedence = _SLarith_get_precedence ((unsigned char) this_type); + if (precedence < this_precedence) + { + type = (unsigned char) this_type; + precedence = this_precedence; + } + + has_vals [i] = 1; + + switch (this_type) + { + case SLANG_NULL_TYPE: + has_vals[i] = 0; + (void) SLdo_pop (); + break; + +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + case SLANG_FLOAT_TYPE: + if (-1 == SLang_pop_double (double_vals + i, NULL, NULL)) + return -1; + is_int = 0; + break; +#endif + default: + if (-1 == SLang_pop_integer (int_vals + i)) + return -1; + double_vals[i] = (double) int_vals[i]; + } + } + +#if SLANG_HAS_FLOAT + if (is_int == 0) + at = inline_implicit_floating_array (type, + (has_vals[0] ? &double_vals[0] : NULL), + (has_vals[1] ? &double_vals[1] : NULL), + (has_vals[2] ? &double_vals[2] : NULL)); + else +#endif + at = inline_implicit_int_array ((has_vals[0] ? &int_vals[0] : NULL), + (has_vals[1] ? &int_vals[1] : NULL), + (has_vals[2] ? &int_vals[2] : NULL)); + + if (at == NULL) + return -1; + + return SLang_push_array (at, 1); +} + +int _SLarray_wildcard_array (void) +{ + SLang_Array_Type *at; + + if (NULL == (at = inline_implicit_int_array (NULL, NULL, NULL))) + return -1; + + return SLang_push_array (at, 1); +} + +static SLang_Array_Type *concat_arrays (unsigned int count) +{ + SLang_Array_Type **arrays; + SLang_Array_Type *at, *bt; + unsigned int i; + int num_elements; + unsigned char type; + char *src_data, *dest_data; + int is_ptr; + unsigned int sizeof_type; + int max_dims, min_dims, max_rows, min_rows; + + arrays = (SLang_Array_Type **)SLmalloc (count * sizeof (SLang_Array_Type *)); + if (arrays == NULL) + { + SLdo_pop_n (count); + return NULL; + } + SLMEMSET((char *) arrays, 0, count * sizeof(SLang_Array_Type *)); + + at = NULL; + + num_elements = 0; + i = count; + + while (i != 0) + { + i--; + + if (-1 == SLang_pop_array (&bt, 1)) + goto free_and_return; + + arrays[i] = bt; + num_elements += (int)bt->num_elements; + } + + type = arrays[0]->data_type; + max_dims = min_dims = arrays[0]->num_dims; + min_rows = max_rows = arrays[0]->dims[0]; + + for (i = 1; i < count; i++) + { + SLang_Array_Type *ct; + int num; + + bt = arrays[i]; + + num = bt->num_dims; + if (num > max_dims) max_dims = num; + if (num < min_dims) min_dims = num; + + num = bt->dims[0]; + if (num > max_rows) max_rows = num; + if (num < min_rows) min_rows = num; + + if (type == bt->data_type) + continue; + + if (1 != _SLarray_typecast (bt->data_type, (VOID_STAR) &bt, 1, + type, (VOID_STAR) &ct, 1)) + goto free_and_return; + + SLang_free_array (bt); + arrays [i] = ct; + } + + if (NULL == (at = SLang_create_array (type, 0, NULL, &num_elements, 1))) + goto free_and_return; + + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + sizeof_type = at->sizeof_type; + dest_data = (char *) at->data; + + for (i = 0; i < count; i++) + { + bt = arrays[i]; + + src_data = (char *) bt->data; + num_elements = bt->num_elements; + + if (-1 == transfer_n_elements (bt, (VOID_STAR)dest_data, (VOID_STAR)src_data, sizeof_type, + num_elements, is_ptr)) + { + SLang_free_array (at); + at = NULL; + goto free_and_return; + } + + dest_data += num_elements * sizeof_type; + } + + /* If the arrays are all 1-d, and all the same size, then reshape to a + * 2-d array. This will allow us to do, e.g. + * a = [[1,2], [3,4]] + * to specifiy a 2-d. + * Someday I will generalize this. + */ + if ((max_dims == min_dims) && (max_dims == 1) && (min_rows == max_rows)) + { + at->num_dims = 2; + at->dims[0] = count; + at->dims[1] = min_rows; + } + + free_and_return: + + for (i = 0; i < count; i++) + SLang_free_array (arrays[i]); + SLfree ((char *) arrays); + + return at; +} + +int _SLarray_inline_array (void) +{ + SLang_Object_Type *obj; + unsigned char type, this_type; + unsigned int count; + SLang_Array_Type *at; + + obj = _SLStack_Pointer; + + count = SLang_Num_Function_Args; + type = 0; + + while ((count > 0) && (--obj >= _SLRun_Stack)) + { + this_type = obj->data_type; + + if (type == 0) + type = this_type; + + if ((type == this_type) || (type == SLANG_ARRAY_TYPE)) + { + count--; + continue; + } + + switch (this_type) + { + case SLANG_ARRAY_TYPE: + type = SLANG_ARRAY_TYPE; + break; + + case SLANG_INT_TYPE: + switch (type) + { +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + break; +#endif +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + break; +#endif + default: + goto type_mismatch; + } + break; +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + switch (type) + { + case SLANG_INT_TYPE: + type = SLANG_DOUBLE_TYPE; + break; +# if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + break; +# endif + default: + goto type_mismatch; + } + break; +#endif +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + switch (type) + { + case SLANG_INT_TYPE: + case SLANG_DOUBLE_TYPE: + type = SLANG_COMPLEX_TYPE; + break; + + default: + goto type_mismatch; + } + break; +#endif + default: + type_mismatch: + _SLclass_type_mismatch_error (type, this_type); + return -1; + } + count--; + } + + if (count != 0) + { + SLang_Error = SL_STACK_UNDERFLOW; + return -1; + } + + count = SLang_Num_Function_Args; + + if (count == 0) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Empty inline-arrays not supported"); + return -1; + } + + if (type == SLANG_ARRAY_TYPE) + { + if (NULL == (at = concat_arrays (count))) + return -1; + } + else + { + SLang_Object_Type index_obj; + int icount = (int) count; + + if (NULL == (at = SLang_create_array (type, 0, NULL, &icount, 1))) + return -1; + + index_obj.data_type = SLANG_INT_TYPE; + while (count != 0) + { + count--; + index_obj.v.int_val = (int) count; + if (-1 == aput_from_indices (at, &index_obj, 1)) + { + SLang_free_array (at); + SLdo_pop_n (count); + return -1; + } + } + } + + return SLang_push_array (at, 1); +} + +static int array_binary_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) op; + (void) a; + (void) b; + *c = SLANG_ARRAY_TYPE; + return 1; +} + +static int array_binary_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + SLang_Array_Type *at, *bt, *ct; + unsigned int i, num_dims; + int (*binary_fun) (int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR); + SLang_Class_Type *a_cl, *b_cl, *c_cl; + int no_init; + + if (a_type == SLANG_ARRAY_TYPE) + { + if (na != 1) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Binary operation on multiple arrays not implemented"); + return -1; + } + + at = *(SLang_Array_Type **) ap; + if (-1 == coerse_array_to_linear (at)) + return -1; + ap = at->data; + a_type = at->data_type; + na = at->num_elements; + } + else + { + at = NULL; + } + + if (b_type == SLANG_ARRAY_TYPE) + { + if (nb != 1) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Binary operation on multiple arrays not implemented"); + return -1; + } + + bt = *(SLang_Array_Type **) bp; + if (-1 == coerse_array_to_linear (bt)) + return -1; + bp = bt->data; + b_type = bt->data_type; + nb = bt->num_elements; + } + else + { + bt = NULL; + } + + if ((at != NULL) && (bt != NULL)) + { + num_dims = at->num_dims; + + if (num_dims != bt->num_dims) + { + SLang_verror (SL_TYPE_MISMATCH, "Arrays must have same dim for binary operation"); + return -1; + } + + for (i = 0; i < num_dims; i++) + { + if (at->dims[i] != bt->dims[i]) + { + SLang_verror (SL_TYPE_MISMATCH, "Arrays must be the same for binary operation"); + return -1; + } + } + } + + a_cl = _SLclass_get_class (a_type); + b_cl = _SLclass_get_class (b_type); + + if (NULL == (binary_fun = _SLclass_get_binary_fun (op, a_cl, b_cl, &c_cl, 1))) + return -1; + + no_init = ((c_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + || (c_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR)); + + ct = NULL; +#if _SLANG_USE_TMP_OPTIMIZATION + /* If we are dealing with scalar (or vector) objects, and if the object + * appears to be owned by the stack, then use it instead of creating a + * new version. This can happen with code such as: + * @ x = [1,2,3,4]; + * @ x = __tmp(x) + 1; + */ + if (no_init) + { + if ((at != NULL) + && (at->num_refs == 1) + && (at->data_type == c_cl->cl_data_type)) + { + ct = at; + ct->num_refs = 2; + } + else if ((bt != NULL) + && (bt->num_refs == 1) + && (bt->data_type == c_cl->cl_data_type)) + { + ct = bt; + ct->num_refs = 2; + } + } +#endif /* _SLANG_USE_TMP_OPTIMIZATION */ + + if (ct == NULL) + { + if (at != NULL) ct = at; else ct = bt; + ct = SLang_create_array1 (c_cl->cl_data_type, 0, NULL, ct->dims, ct->num_dims, no_init); + if (ct == NULL) + return -1; + } + + + if ((na == 0) || (nb == 0) /* allow empty arrays */ + || (1 == (*binary_fun) (op, a_type, ap, na, b_type, bp, nb, ct->data))) + { + *(SLang_Array_Type **) cp = ct; + return 1; + } + + SLang_free_array (ct); + return -1; +} + +static void array_where (void) +{ + SLang_Array_Type *at, *bt; + char *a_data; + int *b_data; + unsigned int i, num_elements; + int b_num; + + if (-1 == SLang_pop_array (&at, 1)) + return; + + bt = NULL; + + if (at->data_type != SLANG_CHAR_TYPE) + { + int zero; + SLang_Array_Type *tmp_at; + + tmp_at = at; + zero = 0; + if (1 != array_binary_op (SLANG_NE, + SLANG_ARRAY_TYPE, (VOID_STAR) &at, 1, + SLANG_CHAR_TYPE, (VOID_STAR) &zero, 1, + (VOID_STAR) &tmp_at)) + goto return_error; + + SLang_free_array (at); + at = tmp_at; + if (at->data_type != SLANG_CHAR_TYPE) + { + SLang_Error = SL_TYPE_MISMATCH; + goto return_error; + } + } + + a_data = (char *) at->data; + num_elements = at->num_elements; + + b_num = 0; + for (i = 0; i < num_elements; i++) + if (a_data[i] != 0) b_num++; + + if (NULL == (bt = SLang_create_array1 (SLANG_INT_TYPE, 0, NULL, &b_num, 1, 1))) + goto return_error; + + b_data = (int *) bt->data; + + i = 0; + while (b_num) + { + if (a_data[i] != 0) + { + *b_data++ = i; + b_num--; + } + + i++; + } + + (void) SLang_push_array (bt, 0); + /* drop */ + + return_error: + SLang_free_array (at); + SLang_free_array (bt); +} + +static int do_array_reshape (SLang_Array_Type *at, SLang_Array_Type *ind_at) +{ + int *dims; + unsigned int i, num_dims; + unsigned int num_elements; + + if ((ind_at->data_type != SLANG_INT_TYPE) + || (ind_at->num_dims != 1)) + { + SLang_verror (SL_TYPE_MISMATCH, "Expecting 1-d integer array"); + return -1; + } + + num_dims = ind_at->num_elements; + dims = (int *) ind_at->data; + + num_elements = 1; + for (i = 0; i < num_dims; i++) + { + int d = dims[i]; + if (d < 0) + { + SLang_verror (SL_INVALID_PARM, "reshape: dimension is less then 0"); + return -1; + } + + num_elements = (unsigned int) d * num_elements; + } + + if ((num_elements != at->num_elements) + || (num_dims > SLARRAY_MAX_DIMS)) + { + SLang_verror (SL_INVALID_PARM, "Unable to reshape array to specified size"); + return -1; + } + + for (i = 0; i < num_dims; i++) + at->dims [i] = dims[i]; + + while (i < SLARRAY_MAX_DIMS) + { + at->dims [i] = 1; + i++; + } + + at->num_dims = num_dims; + return 0; +} + +static void array_reshape (SLang_Array_Type *at, SLang_Array_Type *ind_at) +{ + (void) do_array_reshape (at, ind_at); +} + +static void _array_reshape (SLang_Array_Type *ind_at) +{ + SLang_Array_Type *at; + SLang_Array_Type *new_at; + + if (-1 == SLang_pop_array (&at, 1)) + return; + + /* FIXME: Priority=low: duplicate_array could me modified to look at num_refs */ + + /* Now try to avoid the overhead of creating a new array if possible */ + if (at->num_refs == 1) + { + /* Great, we are the sole owner of this array. */ + if ((-1 == do_array_reshape (at, ind_at)) + || (-1 == SLclass_push_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR)at))) + SLang_free_array (at); + return; + } + + new_at = SLang_duplicate_array (at); + if (new_at != NULL) + { + if (0 == do_array_reshape (new_at, ind_at)) + (void) SLang_push_array (new_at, 0); + + SLang_free_array (new_at); + } + SLang_free_array (at); +} + +typedef struct +{ + SLang_Array_Type *at; + unsigned int increment; + char *addr; +} +Map_Arg_Type; +/* Usage: array_map (Return-Type, func, args,....); */ +static void array_map (void) +{ + Map_Arg_Type *args; + unsigned int num_args; + unsigned int i, i_control; + SLang_Name_Type *nt; + unsigned int num_elements; + SLang_Array_Type *at; + char *addr; + unsigned char type; + + at = NULL; + args = NULL; + nt = NULL; + + if (SLang_Num_Function_Args < 3) + { + SLang_verror (SL_INVALID_PARM, + "Usage: array_map (Return-Type, &func, args...)"); + SLdo_pop_n (SLang_Num_Function_Args); + return; + } + + num_args = (unsigned int)SLang_Num_Function_Args - 2; + args = (Map_Arg_Type *) SLmalloc (num_args * sizeof (Map_Arg_Type)); + if (args == NULL) + { + SLdo_pop_n (SLang_Num_Function_Args); + return; + } + memset ((char *) args, 0, num_args * sizeof (Map_Arg_Type)); + i = num_args; + i_control = 0; + while (i > 0) + { + i--; + if (-1 == SLang_pop_array (&args[i].at, 1)) + { + SLdo_pop_n (i + 2); + goto return_error; + } + if (args[i].at->num_elements > 1) + i_control = i; + } + + if (NULL == (nt = SLang_pop_function ())) + { + SLdo_pop_n (1); + goto return_error; + } + + num_elements = args[i_control].at->num_elements; + + if (-1 == _SLang_pop_datatype (&type)) + goto return_error; + + if (type == SLANG_UNDEFINED_TYPE) /* Void_Type */ + at = NULL; + else + { + at = args[i_control].at; + + if (NULL == (at = SLang_create_array (type, 0, NULL, at->dims, at->num_dims))) + goto return_error; + } + + + for (i = 0; i < num_args; i++) + { + SLang_Array_Type *ati = args[i].at; + /* FIXME: Priority = low: The actual dimensions should be compared. */ + if (ati->num_elements == num_elements) + args[i].increment = ati->sizeof_type; + /* memset already guarantees increment to be zero */ + + if (ati->num_elements == 0) + { + SLang_verror (0, "array_map: function argument %d of %d is an empty array", + i+1, num_args); + goto return_error; + } + + args[i].addr = (char *) ati->data; + } + + if (at == NULL) + addr = NULL; + else + addr = (char *)at->data; + + for (i = 0; i < num_elements; i++) + { + unsigned int j; + + if (-1 == SLang_start_arg_list ()) + goto return_error; + + for (j = 0; j < num_args; j++) + { + if (-1 == push_element_at_addr (args[j].at, + (VOID_STAR) args[j].addr, + 1)) + { + SLdo_pop_n (j); + goto return_error; + } + + args[j].addr += args[j].increment; + } + + if (-1 == SLang_end_arg_list ()) + { + SLdo_pop_n (num_args); + goto return_error; + } + + if (-1 == SLexecute_function (nt)) + goto return_error; + + if (at == NULL) + continue; + + if (-1 == at->cl->cl_apop (type, (VOID_STAR) addr)) + goto return_error; + + addr += at->sizeof_type; + } + + if (at != NULL) + (void) SLang_push_array (at, 0); + + /* drop */ + + return_error: + SLang_free_array (at); + SLang_free_function (nt); + if (args != NULL) + { + for (i = 0; i < num_args; i++) + SLang_free_array (args[i].at); + + SLfree ((char *) args); + } +} + +static SLang_Intrin_Fun_Type Array_Table [] = +{ + MAKE_INTRINSIC_0("array_map", array_map, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("array_sort", sort_array, SLANG_VOID_TYPE), + MAKE_INTRINSIC_1("array_to_bstring", array_to_bstring, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), + MAKE_INTRINSIC_1("bstring_to_array", bstring_to_array, SLANG_VOID_TYPE, SLANG_BSTRING_TYPE), + MAKE_INTRINSIC("init_char_array", init_char_array, SLANG_VOID_TYPE, 0), + MAKE_INTRINSIC("array_info", array_info, SLANG_VOID_TYPE, 0), + MAKE_INTRINSIC("where", array_where, SLANG_VOID_TYPE, 0), + MAKE_INTRINSIC_2("reshape", array_reshape, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE, SLANG_ARRAY_TYPE), + MAKE_INTRINSIC_1("_reshape", _array_reshape, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +static char *array_string (unsigned char type, VOID_STAR v) +{ + SLang_Array_Type *at; + char buf[512]; + unsigned int i, num_dims; + int *dims; + + at = *(SLang_Array_Type **) v; + type = at->data_type; + num_dims = at->num_dims; + dims = at->dims; + + sprintf (buf, "%s[%d", SLclass_get_datatype_name (type), at->dims[0]); + + for (i = 1; i < num_dims; i++) + sprintf (buf + strlen(buf), ",%d", dims[i]); + strcat (buf, "]"); + + return SLmake_string (buf); +} + +static void array_destroy (unsigned char type, VOID_STAR v) +{ + (void) type; + SLang_free_array (*(SLang_Array_Type **) v); +} + +static int array_push (unsigned char type, VOID_STAR v) +{ + SLang_Array_Type *at; + + (void) type; + at = *(SLang_Array_Type **) v; + return SLang_push_array (at, 0); +} + +/* Intrinsic arrays are not stored in a variable. So, the address that + * would contain the variable holds the array address. + */ +static int array_push_intrinsic (unsigned char type, VOID_STAR v) +{ + (void) type; + return SLang_push_array ((SLang_Array_Type *) v, 0); +} + +int _SLarray_add_bin_op (unsigned char type) +{ + SL_OOBinary_Type *ab; + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + ab = cl->cl_binary_ops; + + while (ab != NULL) + { + if (ab->data_type == SLANG_ARRAY_TYPE) + return 0; + ab = ab->next; + } + + if ((-1 == SLclass_add_binary_op (SLANG_ARRAY_TYPE, type, array_binary_op, array_binary_op_result)) + || (-1 == SLclass_add_binary_op (type, SLANG_ARRAY_TYPE, array_binary_op, array_binary_op_result))) + return -1; + + return 0; +} + +static SLang_Array_Type * +do_array_math_op (int op, int unary_type, + SLang_Array_Type *at, unsigned int na) +{ + unsigned char a_type, b_type; + int (*f) (int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); + SLang_Array_Type *bt; + SLang_Class_Type *b_cl; + int no_init; + + if (na != 1) + { + SLang_verror (SL_NOT_IMPLEMENTED, "Operation restricted to 1 array"); + return NULL; + } + + a_type = at->data_type; + if (NULL == (f = _SLclass_get_unary_fun (op, at->cl, &b_cl, unary_type))) + return NULL; + b_type = b_cl->cl_data_type; + + if (-1 == coerse_array_to_linear (at)) + return NULL; + + no_init = ((b_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + || (b_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR)); + +#if _SLANG_USE_TMP_OPTIMIZATION + /* If we are dealing with scalar (or vector) objects, and if the object + * appears to be owned by the stack, then use it instead of creating a + * new version. This can happen with code such as: + * @ x = [1,2,3,4]; + * @ x = UNARY_OP(__tmp(x)); + */ + if (no_init + && (at->num_refs == 1) + && (at->data_type == b_cl->cl_data_type)) + { + bt = at; + bt->num_refs = 2; + } + else +#endif /* _SLANG_USE_TMP_OPTIMIZATION */ + if (NULL == (bt = SLang_create_array1 (b_type, 0, NULL, at->dims, at->num_dims, no_init))) + return NULL; + + if (1 != (*f)(op, a_type, at->data, at->num_elements, bt->data)) + { + SLang_free_array (bt); + return NULL; + } + return bt; +} + +static int +array_unary_op_result (int op, unsigned char a, unsigned char *b) +{ + (void) op; + (void) a; + *b = SLANG_ARRAY_TYPE; + return 1; +} + +static int +array_unary_op (int op, + unsigned char a, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + SLang_Array_Type *at; + + (void) a; + at = *(SLang_Array_Type **) ap; + if (NULL == (at = do_array_math_op (op, _SLANG_BC_UNARY, at, na))) + { + if (SLang_Error) return -1; + return 0; + } + *(SLang_Array_Type **) bp = at; + return 1; +} + +static int +array_math_op (int op, + unsigned char a, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + SLang_Array_Type *at; + + (void) a; + at = *(SLang_Array_Type **) ap; + if (NULL == (at = do_array_math_op (op, _SLANG_BC_MATH_UNARY, at, na))) + { + if (SLang_Error) return -1; + return 0; + } + *(SLang_Array_Type **) bp = at; + return 1; +} + +static int +array_app_op (int op, + unsigned char a, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + SLang_Array_Type *at; + + (void) a; + at = *(SLang_Array_Type **) ap; + if (NULL == (at = do_array_math_op (op, _SLANG_BC_APP_UNARY, at, na))) + { + if (SLang_Error) return -1; + return 0; + } + *(SLang_Array_Type **) bp = at; + return 1; +} + +int +_SLarray_typecast (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, + int is_implicit) +{ + SLang_Array_Type *at, *bt; + SLang_Class_Type *b_cl; + int no_init; + int (*t) (unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR); + + if (na != 1) + { + SLang_verror (SL_NOT_IMPLEMENTED, "typecast of multiple arrays not implemented"); + return -1; + } + + at = *(SLang_Array_Type **) ap; + a_type = at->data_type; + + if (a_type == b_type) + { + at->num_refs += 1; + *(SLang_Array_Type **) bp = at; + return 1; + } + + if (NULL == (t = _SLclass_get_typecast (a_type, b_type, is_implicit))) + return -1; + + if (-1 == coerse_array_to_linear (at)) + return -1; + + b_cl = _SLclass_get_class (b_type); + + no_init = ((b_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + || (b_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR)); + + if (NULL == (bt = SLang_create_array1 (b_type, 0, NULL, at->dims, at->num_dims, no_init))) + return -1; + + if (1 == (*t) (a_type, at->data, at->num_elements, b_type, bt->data)) + { + *(SLang_Array_Type **) bp = bt; + return 1; + } + + SLang_free_array (bt); + return 0; +} + +SLang_Array_Type *SLang_duplicate_array (SLang_Array_Type *at) +{ + SLang_Array_Type *bt; + char *data, *a_data; + unsigned int i, num_elements, sizeof_type; + unsigned int size; + int (*cl_acopy) (unsigned char, VOID_STAR, VOID_STAR); + unsigned char type; + + if (-1 == coerse_array_to_linear (at)) + return NULL; + + type = at->data_type; + num_elements = at->num_elements; + sizeof_type = at->sizeof_type; + size = num_elements * sizeof_type; + + if (NULL == (data = SLmalloc (size))) + return NULL; + + if (NULL == (bt = SLang_create_array (type, 0, (VOID_STAR)data, at->dims, at->num_dims))) + { + SLfree (data); + return NULL; + } + + a_data = (char *) at->data; + if (0 == (at->flags & SLARR_DATA_VALUE_IS_POINTER)) + { + SLMEMCPY (data, a_data, size); + return bt; + } + + SLMEMSET (data, 0, size); + + cl_acopy = at->cl->cl_acopy; + for (i = 0; i < num_elements; i++) + { + if (NULL != *(VOID_STAR *) a_data) + { + if (-1 == (*cl_acopy) (type, (VOID_STAR) a_data, (VOID_STAR) data)) + { + SLang_free_array (bt); + return NULL; + } + } + + data += sizeof_type; + a_data += sizeof_type; + } + + return bt; +} + +static int array_dereference (unsigned char type, VOID_STAR addr) +{ + SLang_Array_Type *at; + + (void) type; + at = SLang_duplicate_array (*(SLang_Array_Type **) addr); + if (at == NULL) return -1; + return SLang_push_array (at, 1); +} + +/* This function gets called via, e.g., @Array_Type (Double_Type, [10,20]); + */ +static int +array_datatype_deref (unsigned char type) +{ + SLang_Array_Type *ind_at; + SLang_Array_Type *at; + +#if 0 + /* The parser generated code for this as if a function call were to be + * made. However, the interpreter simply called the deref object routine + * instead of the function call. So, I must simulate the function call. + * This needs to be formalized to hide this detail from applications + * who wish to do the same. So... + * FIXME: Priority=medium + */ + if (0 == _SL_increment_frame_pointer ()) + (void) _SL_decrement_frame_pointer (); +#endif + + if (-1 == SLang_pop_array (&ind_at, 1)) + return -1; + + if ((ind_at->data_type != SLANG_INT_TYPE) + || (ind_at->num_dims != 1)) + { + SLang_verror (SL_TYPE_MISMATCH, "Expecting 1-d integer array"); + goto return_error; + } + + if (-1 == _SLang_pop_datatype (&type)) + goto return_error; + + if (NULL == (at = SLang_create_array (type, 0, NULL, + (int *) ind_at->data, + ind_at->num_elements))) + goto return_error; + + SLang_free_array (ind_at); + return SLang_push_array (at, 1); + + return_error: + SLang_free_array (ind_at); + return -1; +} + +static int array_length (unsigned char type, VOID_STAR v, unsigned int *len) +{ + SLang_Array_Type *at; + + (void) type; + at = *(SLang_Array_Type **) v; + *len = at->num_elements; + return 0; +} + +int +_SLarray_init_slarray (void) +{ + SLang_Class_Type *cl; + + if (-1 == SLadd_intrin_fun_table (Array_Table, NULL)) + return -1; + + if (NULL == (cl = SLclass_allocate_class ("Array_Type"))) + return -1; + + (void) SLclass_set_string_function (cl, array_string); + (void) SLclass_set_destroy_function (cl, array_destroy); + (void) SLclass_set_push_function (cl, array_push); + cl->cl_push_intrinsic = array_push_intrinsic; + cl->cl_dereference = array_dereference; + cl->cl_datatype_deref = array_datatype_deref; + cl->cl_length = array_length; + + if (-1 == SLclass_register_class (cl, SLANG_ARRAY_TYPE, sizeof (VOID_STAR), + SLANG_CLASS_TYPE_PTR)) + return -1; + + if ((-1 == SLclass_add_binary_op (SLANG_ARRAY_TYPE, SLANG_ARRAY_TYPE, array_binary_op, array_binary_op_result)) + || (-1 == SLclass_add_unary_op (SLANG_ARRAY_TYPE, array_unary_op, array_unary_op_result)) + || (-1 == SLclass_add_app_unary_op (SLANG_ARRAY_TYPE, array_app_op, array_unary_op_result)) + || (-1 == SLclass_add_math_op (SLANG_ARRAY_TYPE, array_math_op, array_unary_op_result)) + || (-1 == SLclass_add_math_op (SLANG_ARRAY_TYPE, array_math_op, array_unary_op_result))) + return -1; + + return 0; +} + +int SLang_pop_array (SLang_Array_Type **at_ptr, int convert_scalar) +{ + if (-1 == pop_array (at_ptr, convert_scalar)) + return -1; + + if (-1 == coerse_array_to_linear (*at_ptr)) + { + SLang_free_array (*at_ptr); + return -1; + } + return 0; +} + +int SLang_pop_array_of_type (SLang_Array_Type **at, unsigned char type) +{ + if (-1 == SLclass_typecast (type, 1, 1)) + return -1; + + return SLang_pop_array (at, 1); +} + +void (*_SLang_Matrix_Multiply)(void); + +int _SLarray_matrix_multiply (void) +{ + if (_SLang_Matrix_Multiply != NULL) + { + (*_SLang_Matrix_Multiply)(); + return 0; + } + SLang_verror (SL_NOT_IMPLEMENTED, "Matrix multiplication not available"); + return -1; +} + +struct _SLang_Foreach_Context_Type +{ + SLang_Array_Type *at; + unsigned int next_element_index; +}; + +SLang_Foreach_Context_Type * +_SLarray_cl_foreach_open (unsigned char type, unsigned int num) +{ + SLang_Foreach_Context_Type *c; + + if (num != 0) + { + SLdo_pop_n (num + 1); + SLang_verror (SL_NOT_IMPLEMENTED, + "%s does not support 'foreach using' form", + SLclass_get_datatype_name (type)); + return NULL; + } + + if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type)))) + return NULL; + + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + + if (-1 == pop_array (&c->at, 1)) + { + SLfree ((char *) c); + return NULL; + } + + return c; +} + +void _SLarray_cl_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + SLang_free_array (c->at); + SLfree ((char *) c); +} + +int _SLarray_cl_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + SLang_Array_Type *at; + VOID_STAR data; + + (void) type; + + if (c == NULL) + return -1; + + at = c->at; + if (at->num_elements == c->next_element_index) + return 0; + + /* FIXME: Priority = low. The following assumes linear arrays + * or Integer range arrays. Fixing it right requires a method to get the + * nth element of a multidimensional array. + */ + + if (at->flags & SLARR_DATA_VALUE_IS_RANGE) + { + int d = (int) c->next_element_index; + data = range_get_data_addr (at, &d); + } + else + data = (VOID_STAR) ((char *)at->data + (c->next_element_index * at->sizeof_type)); + + c->next_element_index += 1; + + if ((at->flags & SLARR_DATA_VALUE_IS_POINTER) + && (*(VOID_STAR *) data == NULL)) + { + if (-1 == SLang_push_null ()) + return -1; + } + else if (-1 == (*at->cl->cl_apush)(at->data_type, data)) + return -1; + + /* keep going */ + return 1; +} + diff --git a/mdk-stage1/slang/slarrfun.c b/mdk-stage1/slang/slarrfun.c new file mode 100644 index 000000000..bfa6ec5e5 --- /dev/null +++ b/mdk-stage1/slang/slarrfun.c @@ -0,0 +1,464 @@ +/* Advanced array manipulation routines for S-Lang */ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static int next_transposed_index (int *dims, int *max_dims, unsigned int num_dims) +{ + int i; + + for (i = 0; i < (int) num_dims; i++) + { + int dims_i; + + dims_i = dims [i] + 1; + if (dims_i != (int) max_dims [i]) + { + dims [i] = dims_i; + return 0; + } + dims [i] = 0; + } + + return -1; +} + +static SLang_Array_Type *allocate_transposed_array (SLang_Array_Type *at) +{ + unsigned int num_elements; + SLang_Array_Type *bt; + VOID_STAR b_data; + + num_elements = at->num_elements; + b_data = (VOID_STAR) SLmalloc (at->sizeof_type * num_elements); + if (b_data == NULL) + return NULL; + + bt = SLang_create_array (at->data_type, 0, b_data, at->dims, 2); + if (bt == NULL) + { + SLfree ((char *)b_data); + return NULL; + } + + bt->dims[1] = at->dims[0]; + bt->dims[0] = at->dims[1]; + + return bt; +} + +#define GENERIC_TYPE float +#define TRANSPOSE_2D_ARRAY transpose_floats +#define GENERIC_TYPE_A float +#define GENERIC_TYPE_B float +#define GENERIC_TYPE_C float +#define INNERPROD_FUNCTION innerprod_float_float +#if SLANG_HAS_COMPLEX +# define INNERPROD_COMPLEX_A innerprod_complex_float +# define INNERPROD_A_COMPLEX innerprod_float_complex +#endif +#include "slarrfun.inc" + +#define GENERIC_TYPE double +#define TRANSPOSE_2D_ARRAY transpose_doubles +#define GENERIC_TYPE_A double +#define GENERIC_TYPE_B double +#define GENERIC_TYPE_C double +#define INNERPROD_FUNCTION innerprod_double_double +#if SLANG_HAS_COMPLEX +# define INNERPROD_COMPLEX_A innerprod_complex_double +# define INNERPROD_A_COMPLEX innerprod_double_complex +#endif +#include "slarrfun.inc" + +#define GENERIC_TYPE_A double +#define GENERIC_TYPE_B float +#define GENERIC_TYPE_C double +#define INNERPROD_FUNCTION innerprod_double_float +#include "slarrfun.inc" + +#define GENERIC_TYPE_A float +#define GENERIC_TYPE_B double +#define GENERIC_TYPE_C double +#define INNERPROD_FUNCTION innerprod_float_double +#include "slarrfun.inc" + +/* Finally pick up the complex_complex multiplication + * and do the integers + */ +#if SLANG_HAS_COMPLEX +# define INNERPROD_COMPLEX_COMPLEX innerprod_complex_complex +#endif +#define GENERIC_TYPE int +#define TRANSPOSE_2D_ARRAY transpose_ints +#include "slarrfun.inc" + +#if SIZEOF_LONG != SIZEOF_INT +# define GENERIC_TYPE long +# define TRANSPOSE_2D_ARRAY transpose_longs +# include "slarrfun.inc" +#else +# define transpose_longs transpose_ints +#endif + +#if SIZEOF_SHORT != SIZEOF_INT +# define GENERIC_TYPE short +# define TRANSPOSE_2D_ARRAY transpose_shorts +# include "slarrfun.inc" +#else +# define transpose_shorts transpose_ints +#endif + +#define GENERIC_TYPE char +#define TRANSPOSE_2D_ARRAY transpose_chars +#include "slarrfun.inc" + +/* This routine works only with linear arrays */ +static SLang_Array_Type *transpose (SLang_Array_Type *at) +{ + int dims [SLARRAY_MAX_DIMS]; + int *max_dims; + unsigned int num_dims; + SLang_Array_Type *bt; + int i; + unsigned int sizeof_type; + int is_ptr; + char *b_data; + + max_dims = at->dims; + num_dims = at->num_dims; + + if ((at->num_elements == 0) + || (num_dims == 1)) + { + bt = SLang_duplicate_array (at); + if (num_dims == 1) bt->num_dims = 2; + goto transpose_dims; + } + + /* For numeric arrays skip the overhead below */ + if (num_dims == 2) + { + bt = allocate_transposed_array (at); + if (bt == NULL) return NULL; + + switch (at->data_type) + { + case SLANG_INT_TYPE: + case SLANG_UINT_TYPE: + return transpose_ints (at, bt); + case SLANG_DOUBLE_TYPE: + return transpose_doubles (at, bt); + case SLANG_FLOAT_TYPE: + return transpose_floats (at, bt); + case SLANG_CHAR_TYPE: + case SLANG_UCHAR_TYPE: + return transpose_chars (at, bt); + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: + return transpose_longs (at, bt); + case SLANG_SHORT_TYPE: + case SLANG_USHORT_TYPE: + return transpose_shorts (at, bt); + } + } + else + { + bt = SLang_create_array (at->data_type, 0, NULL, max_dims, num_dims); + if (bt == NULL) return NULL; + } + + sizeof_type = at->sizeof_type; + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + + memset ((char *)dims, 0, sizeof(dims)); + + b_data = (char *) bt->data; + + do + { + if (-1 == _SLarray_aget_transfer_elem (at, dims, (VOID_STAR) b_data, + sizeof_type, is_ptr)) + { + SLang_free_array (bt); + return NULL; + } + b_data += sizeof_type; + } + while (0 == next_transposed_index (dims, max_dims, num_dims)); + + transpose_dims: + + num_dims = bt->num_dims; + for (i = 0; i < (int) num_dims; i++) + bt->dims[i] = max_dims [num_dims - i - 1]; + + return bt; +} + +static void array_transpose (SLang_Array_Type *at) +{ + if (NULL != (at = transpose (at))) + (void) SLang_push_array (at, 1); +} + +static int get_inner_product_parms (SLang_Array_Type *a, int *dp, + unsigned int *loops, unsigned int *other) +{ + int num_dims; + int d; + + d = *dp; + + num_dims = (int)a->num_dims; + if (num_dims == 0) + { + SLang_verror (SL_INVALID_PARM, "Inner-product operation requires an array of at least 1 dimension."); + return -1; + } + + /* An index of -1 refers to last dimension */ + if (d == -1) + d += num_dims; + *dp = d; + + if (a->num_elements == 0) + { /* [] # [] ==> [] */ + *loops = *other = 0; + return 0; + } + + *loops = a->num_elements / a->dims[d]; + + if (d == 0) + { + *other = *loops; /* a->num_elements / a->dims[0]; */ + return 0; + } + + *other = a->dims[d]; + return 0; +} + +/* This routines takes two arrays A_i..j and B_j..k and produces a third + * via C_i..k = A_i..j B_j..k. + * + * If A is a vector, and B is a 2-d matrix, then regard A as a 2-d matrix + * with 1-column. + */ +static void do_inner_product (void) +{ + SLang_Array_Type *a, *b, *c; + void (*fun)(SLang_Array_Type *, SLang_Array_Type *, SLang_Array_Type *, + unsigned int, unsigned int, unsigned int, unsigned int, + unsigned int); + unsigned char c_type; + int dims[SLARRAY_MAX_DIMS]; + int status; + unsigned int a_loops, b_loops, b_inc, a_stride; + int ai_dims, i, j; + unsigned int num_dims, a_num_dims, b_num_dims; + int ai, bi; + + /* The result of a inner_product will be either a float, double, or + * a complex number. + * + * If an integer array is used, it will be promoted to a float. + */ + + switch (SLang_peek_at_stack1 ()) + { + case SLANG_DOUBLE_TYPE: + if (-1 == SLang_pop_array_of_type (&b, SLANG_DOUBLE_TYPE)) + return; + break; + +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + if (-1 == SLang_pop_array_of_type (&b, SLANG_COMPLEX_TYPE)) + return; + break; +#endif + case SLANG_FLOAT_TYPE: + default: + if (-1 == SLang_pop_array_of_type (&b, SLANG_FLOAT_TYPE)) + return; + break; + } + + switch (SLang_peek_at_stack1 ()) + { + case SLANG_DOUBLE_TYPE: + status = SLang_pop_array_of_type (&a, SLANG_DOUBLE_TYPE); + break; + +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + status = SLang_pop_array_of_type (&a, SLANG_COMPLEX_TYPE); + break; +#endif + case SLANG_FLOAT_TYPE: + default: + status = SLang_pop_array_of_type (&a, SLANG_FLOAT_TYPE); + break; + } + + if (status == -1) + { + SLang_free_array (b); + return; + } + + ai = -1; /* last index of a */ + bi = 0; /* first index of b */ + if ((-1 == get_inner_product_parms (a, &ai, &a_loops, &a_stride)) + || (-1 == get_inner_product_parms (b, &bi, &b_loops, &b_inc))) + { + SLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product"); + goto free_and_return; + } + + a_num_dims = a->num_dims; + b_num_dims = b->num_dims; + + /* Coerse a 1-d vector to 2-d */ + if ((a_num_dims == 1) + && (b_num_dims == 2) + && (a->num_elements)) + { + a_num_dims = 2; + ai = 1; + a_loops = a->num_elements; + a_stride = 1; + } + + if ((ai_dims = a->dims[ai]) != b->dims[bi]) + { + SLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product"); + goto free_and_return; + } + + num_dims = a_num_dims + b_num_dims - 2; + if (num_dims > SLARRAY_MAX_DIMS) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Inner-product result exceed max allowed dimensions"); + goto free_and_return; + } + + if (num_dims) + { + j = 0; + for (i = 0; i < (int)a_num_dims; i++) + if (i != ai) dims [j++] = a->dims[i]; + for (i = 0; i < (int)b_num_dims; i++) + if (i != bi) dims [j++] = b->dims[i]; + } + else + { + /* a scalar */ + num_dims = 1; + dims[0] = 1; + } + + c_type = 0; fun = NULL; + switch (a->data_type) + { + case SLANG_FLOAT_TYPE: + switch (b->data_type) + { + case SLANG_FLOAT_TYPE: + c_type = SLANG_FLOAT_TYPE; + fun = innerprod_float_float; + break; + case SLANG_DOUBLE_TYPE: + c_type = SLANG_DOUBLE_TYPE; + fun = innerprod_float_double; + break; +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + c_type = SLANG_COMPLEX_TYPE; + fun = innerprod_float_complex; + break; +#endif + } + break; + case SLANG_DOUBLE_TYPE: + switch (b->data_type) + { + case SLANG_FLOAT_TYPE: + c_type = SLANG_DOUBLE_TYPE; + fun = innerprod_double_float; + break; + case SLANG_DOUBLE_TYPE: + c_type = SLANG_DOUBLE_TYPE; + fun = innerprod_double_double; + break; +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + c_type = SLANG_COMPLEX_TYPE; + fun = innerprod_double_complex; + break; +#endif + } + break; +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + c_type = SLANG_COMPLEX_TYPE; + switch (b->data_type) + { + case SLANG_FLOAT_TYPE: + fun = innerprod_complex_float; + break; + case SLANG_DOUBLE_TYPE: + fun = innerprod_complex_double; + break; + case SLANG_COMPLEX_TYPE: + fun = innerprod_complex_complex; + break; + } + break; +#endif + default: + break; + } + + if (NULL == (c = SLang_create_array (c_type, 0, NULL, dims, num_dims))) + goto free_and_return; + + (*fun)(a, b, c, a_loops, a_stride, b_loops, b_inc, ai_dims); + + (void) SLang_push_array (c, 1); + /* drop */ + + free_and_return: + SLang_free_array (a); + SLang_free_array (b); +} + + + +static SLang_Intrin_Fun_Type Array_Fun_Table [] = +{ + MAKE_INTRINSIC_1("transpose", array_transpose, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +int SLang_init_array (void) +{ + if (-1 == SLadd_intrin_fun_table (Array_Fun_Table, "__SLARRAY__")) + return -1; +#if SLANG_HAS_FLOAT + _SLang_Matrix_Multiply = do_inner_product; +#endif + return 0; +} + diff --git a/mdk-stage1/slang/slarrfun.inc b/mdk-stage1/slang/slarrfun.inc new file mode 100644 index 000000000..348473a6f --- /dev/null +++ b/mdk-stage1/slang/slarrfun.inc @@ -0,0 +1,257 @@ +/* -*- mode: C -*- */ + +/* Some "inline" functions for generic scalar types */ + +#ifdef TRANSPOSE_2D_ARRAY +static SLang_Array_Type *TRANSPOSE_2D_ARRAY (SLang_Array_Type *at, SLang_Array_Type *bt) +{ + GENERIC_TYPE *a_data, *b_data; + int nr, nc, i; + + nr = at->dims[0]; + nc = at->dims[1]; + + a_data = (GENERIC_TYPE *) at->data; + b_data = (GENERIC_TYPE *) bt->data; + + for (i = 0; i < nr; i++) + { + GENERIC_TYPE *offset = b_data + i; + int j; + for (j = 0; j < nc; j++) + { + *offset = *a_data++; + offset += nr; + } + } + return bt; +} +#undef TRANSPOSE_2D_ARRAY +#endif + + +#ifdef INNERPROD_FUNCTION + +static void INNERPROD_FUNCTION + (SLang_Array_Type *at, SLang_Array_Type *bt, SLang_Array_Type *ct, + unsigned int a_loops, unsigned int a_stride, + unsigned int b_loops, unsigned int b_inc, + unsigned int inner_loops) +{ + GENERIC_TYPE_A *a; + GENERIC_TYPE_B *b; + GENERIC_TYPE_C *c; + + c = (GENERIC_TYPE_C *) ct->data; + b = (GENERIC_TYPE_B *) bt->data; + a = (GENERIC_TYPE_A *) at->data; + + while (a_loops--) + { + GENERIC_TYPE_B *bb; + unsigned int j; + + bb = b; + + for (j = 0; j < inner_loops; j++) + { + double x = (double) a[j]; + + if (x != 0.0) + { + unsigned int k; + + for (k = 0; k < b_loops; k++) + c[k] += x * bb[k]; + } + bb += b_inc; + } + c += b_loops; + a += a_stride; + } +} +#undef INNERPROD_FUNCTION + +#undef GENERIC_TYPE_A +#undef GENERIC_TYPE_B +#undef GENERIC_TYPE_C +#endif + +#ifdef INNERPROD_COMPLEX_A +static void INNERPROD_COMPLEX_A + (SLang_Array_Type *at, SLang_Array_Type *bt, SLang_Array_Type *ct, + unsigned int a_loops, unsigned int a_stride, + unsigned int b_loops, unsigned int b_inc, + unsigned int inner_loops) +{ + double *a; + GENERIC_TYPE *b; + double *c; + + c = (double *) ct->data; + b = (GENERIC_TYPE *) bt->data; + a = (double *) at->data; + + a_stride *= 2; + + while (a_loops--) + { + GENERIC_TYPE *bb; + unsigned int bb_loops; + + bb = b; + bb_loops = b_loops; + + while (bb_loops--) + { + double real_sum; + double imag_sum; + unsigned int iloops; + double *aa; + GENERIC_TYPE *bbb; + + aa = a; + bbb = bb; + iloops = inner_loops; + + real_sum = 0.0; + imag_sum = 0.0; + while (iloops--) + { + real_sum += aa[0] * (double)bbb[0]; + imag_sum += aa[1] * (double)bbb[0]; + aa += 2; + bbb += b_inc; + } + + *c++ = real_sum; + *c++ = imag_sum; + bb++; + } + + a += a_stride; + } +} + +static void INNERPROD_A_COMPLEX + (SLang_Array_Type *at, SLang_Array_Type *bt, SLang_Array_Type *ct, + unsigned int a_loops, unsigned int a_stride, + unsigned int b_loops, unsigned int b_inc, + unsigned int inner_loops) +{ + GENERIC_TYPE *a; + double *b; + double *c; + + c = (double *) ct->data; + b = (double *) bt->data; + a = (GENERIC_TYPE *) at->data; + + b_inc *= 2; + + while (a_loops--) + { + double *bb; + unsigned int bb_loops; + + bb = b; + bb_loops = b_loops; + + while (bb_loops--) + { + double real_sum; + double imag_sum; + unsigned int iloops; + GENERIC_TYPE *aa; + double *bbb; + + aa = a; + bbb = bb; + iloops = inner_loops; + + real_sum = 0.0; + imag_sum = 0.0; + while (iloops--) + { + real_sum += (double)aa[0] * bbb[0]; + imag_sum += (double)aa[0] * bbb[1]; + aa += 1; + bbb += b_inc; + } + + *c++ = real_sum; + *c++ = imag_sum; + bb += 2; + } + + a += a_stride; + } +} + +#undef INNERPROD_A_COMPLEX +#undef INNERPROD_COMPLEX_A +#endif /* INNERPROD_COMPLEX_A */ + + +#ifdef INNERPROD_COMPLEX_COMPLEX +static void INNERPROD_COMPLEX_COMPLEX + (SLang_Array_Type *at, SLang_Array_Type *bt, SLang_Array_Type *ct, + unsigned int a_loops, unsigned int a_stride, + unsigned int b_loops, unsigned int b_inc, + unsigned int inner_loops) +{ + double *a; + double *b; + double *c; + + c = (double *) ct->data; + b = (double *) bt->data; + a = (double *) at->data; + + a_stride *= 2; + b_inc *= 2; + + while (a_loops--) + { + double *bb; + unsigned int bb_loops; + + bb = b; + bb_loops = b_loops; + + while (bb_loops--) + { + double real_sum; + double imag_sum; + unsigned int iloops; + double *aa; + double *bbb; + + aa = a; + bbb = bb; + iloops = inner_loops; + + real_sum = 0.0; + imag_sum = 0.0; + while (iloops--) + { + real_sum += aa[0]*bbb[0] - aa[1]*bbb[1]; + imag_sum += aa[0]*bbb[1] + aa[1]*bbb[0]; + aa += 2; + bbb += b_inc; + } + + *c++ = real_sum; + *c++ = imag_sum; + bb += 2; + } + + a += a_stride; + } +} +#undef INNERPROD_COMPLEX_COMPLEX +#endif + +#ifdef GENERIC_TYPE +# undef GENERIC_TYPE +#endif diff --git a/mdk-stage1/slang/slarrmis.c b/mdk-stage1/slang/slarrmis.c new file mode 100644 index 000000000..330dcb53f --- /dev/null +++ b/mdk-stage1/slang/slarrmis.c @@ -0,0 +1,38 @@ +/* Misc Array Functions */ +/* Copyright (c) 1997, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +int SLang_get_array_element (SLang_Array_Type *at, int *indices, VOID_STAR data) +{ + int is_ptr; + + if ((at == NULL) + || (indices == NULL) + || (data == NULL)) + return -1; + + is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); + if (is_ptr) *(VOID_STAR *) data = NULL; + return _SLarray_aget_transfer_elem (at, indices, data, at->sizeof_type, is_ptr); +} + +int SLang_set_array_element (SLang_Array_Type *at, int *indices, VOID_STAR data) +{ + if ((at == NULL) + || (indices == NULL) + || (data == NULL)) + return -1; + + return _SLarray_aput_transfer_elem (at, indices, data, at->sizeof_type, + at->flags & SLARR_DATA_VALUE_IS_POINTER); +} + diff --git a/mdk-stage1/slang/slassoc.c b/mdk-stage1/slang/slassoc.c new file mode 100644 index 000000000..5997458d2 --- /dev/null +++ b/mdk-stage1/slang/slassoc.c @@ -0,0 +1,713 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#define SL_APP_WANTS_FOREACH +#include "slang.h" +#include "_slang.h" + +#define USE_NEW_ANYTYPE_CODE 1 + +typedef struct _SLAssoc_Array_Element_Type +{ + char *key; /* slstring */ + struct _SLAssoc_Array_Element_Type *next; + SLang_Object_Type value; +} +_SLAssoc_Array_Element_Type; + +typedef struct +{ + _SLAssoc_Array_Element_Type *elements[SLASSOC_HASH_TABLE_SIZE]; + SLang_Object_Type default_value; + unsigned int num_elements; +#define HAS_DEFAULT_VALUE 1 + unsigned int flags; + unsigned char type; +} +SLang_Assoc_Array_Type; + +#define USE_CACHED_STRING 1 + +#if USE_CACHED_STRING +static char *Cached_String; +static SLang_Object_Type *Cached_Obj; +static SLang_Assoc_Array_Type *Cached_Array; +#endif + +static SLang_Assoc_Array_Type *alloc_assoc_array (unsigned char type, int has_default_value) +{ + SLang_Assoc_Array_Type *a; + + a = (SLang_Assoc_Array_Type *)SLmalloc (sizeof (SLang_Assoc_Array_Type)); + if (a == NULL) + { + if (has_default_value) + SLdo_pop_n (1); + return NULL; + } + + memset ((char *) a, 0, sizeof (SLang_Assoc_Array_Type)); + a->type = type; + + if (has_default_value) + { + if ( +#if USE_NEW_ANYTYPE_CODE + ((type != SLANG_ANY_TYPE) && (-1 == SLclass_typecast (type, 1, 1))) +#else + (-1 == SLclass_typecast (type, 1, 1)) +#endif + || (-1 == SLang_pop (&a->default_value))) + { + SLfree ((char *) a); + return NULL; + } + + a->flags |= HAS_DEFAULT_VALUE; + } + return a; +} + +static void free_element (_SLAssoc_Array_Element_Type *e) +{ + if (e == NULL) + return; + + SLang_free_object (&e->value); + SLang_free_slstring (e->key); +#if USE_CACHED_STRING + if (e->key == Cached_String) + Cached_String = NULL; +#endif + SLfree ((char *)e); +} + +static void delete_assoc_array (SLang_Assoc_Array_Type *a) +{ + unsigned int i; + + if (a == NULL) return; + + for (i = 0; i < SLASSOC_HASH_TABLE_SIZE; i++) + { + _SLAssoc_Array_Element_Type *e; + + e = a->elements[i]; + while (e != NULL) + { + _SLAssoc_Array_Element_Type *next_e; + + next_e = e->next; + free_element (e); + e = next_e; + } + } + if (a->flags & HAS_DEFAULT_VALUE) + SLang_free_object (&a->default_value); + + SLfree ((char *) a); +} + +_INLINE_ +static SLang_Object_Type * +find_element (SLang_Assoc_Array_Type *a, char *str, unsigned long hash) +{ + unsigned int h; + _SLAssoc_Array_Element_Type *e; + + h = (unsigned int) (hash % SLASSOC_HASH_TABLE_SIZE); + e = a->elements[h]; + + while (e != NULL) + { + if (str == e->key) /* slstrings can be compared this way */ + { +#if USE_CACHED_STRING + Cached_String = str; + Cached_Obj = &e->value; + Cached_Array = a; +#endif + return &e->value; + } + + e = e->next; + } + + return NULL; +} + +static _SLAssoc_Array_Element_Type * +create_element (SLang_Assoc_Array_Type *a, char *str, unsigned long hash) +{ + unsigned int h; + _SLAssoc_Array_Element_Type *e; + + e = (_SLAssoc_Array_Element_Type *) SLmalloc (sizeof (_SLAssoc_Array_Element_Type)); + if (e == NULL) + return NULL; + + memset ((char *) e, 0, sizeof (_SLAssoc_Array_Element_Type)); + h = (unsigned int) (hash % SLASSOC_HASH_TABLE_SIZE); + + if (NULL == (str = _SLstring_dup_hashed_string (str, hash))) + { + SLfree ((char *) e); + return NULL; + } + + e->key = str; + e->next = a->elements[h]; + a->elements[h] = e; + + a->num_elements += 1; +#if USE_CACHED_STRING + Cached_String = str; + Cached_Obj = &e->value; + Cached_Array = a; +#endif + return e; +} + +static int store_object (SLang_Assoc_Array_Type *a, char *s, SLang_Object_Type *obj) +{ + unsigned long hash; + SLang_Object_Type *v; + +#if USE_CACHED_STRING + if ((s == Cached_String) && (a == Cached_Array)) + { + v = Cached_Obj; + SLang_free_object (v); + } + else + { +#endif + hash = _SLcompute_string_hash (s); + if (NULL != (v = find_element (a, s, hash))) + SLang_free_object (v); + else + { + _SLAssoc_Array_Element_Type *e; + + e = create_element (a, s, hash); + if (e == NULL) + return -1; + + v = &e->value; + } +#if USE_CACHED_STRING + } +#endif + + *v = *obj; + + return 0; +} + +static void assoc_destroy (unsigned char type, VOID_STAR ptr) +{ + (void) type; + delete_assoc_array ((SLang_Assoc_Array_Type *) ptr); +} + +static int pop_index (unsigned int num_indices, + SLang_MMT_Type **mmt, + SLang_Assoc_Array_Type **a, + char **str) +{ + if (NULL == (*mmt = SLang_pop_mmt (SLANG_ASSOC_TYPE))) + { + *a = NULL; + *str = NULL; + return -1; + } + + if ((num_indices != 1) + || (-1 == SLang_pop_slstring (str))) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Assoc_Type arrays require a single string index"); + SLang_free_mmt (*mmt); + *mmt = NULL; + *a = NULL; + *str = NULL; + return -1; + } + + *a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (*mmt); + return 0; +} + +static int assoc_aget (unsigned char type, unsigned int num_indices) +{ + SLang_MMT_Type *mmt; + char *str; + SLang_Assoc_Array_Type *a; + SLang_Object_Type *obj; + int ret; + + (void) type; + + if (-1 == pop_index (num_indices, &mmt, &a, &str)) + return -1; + +#if USE_CACHED_STRING + if ((str == Cached_String) && (a == Cached_Array)) + obj = Cached_Obj; + else +#endif + obj = find_element (a, str, _SLcompute_string_hash (str)); + + if ((obj == NULL) + && (a->flags & HAS_DEFAULT_VALUE)) + obj = &a->default_value; + + if (obj == NULL) + { + SLang_verror (SL_INTRINSIC_ERROR, + "No such element in Assoc Array: %s", str); + ret = -1; + } + else + { +#if _SLANG_OPTIMIZE_FOR_SPEED + if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type[obj->data_type]) + ret = SLang_push (obj); +#endif + else + ret = _SLpush_slang_obj (obj); + } + + SLang_free_slstring (str); + SLang_free_mmt (mmt); + return ret; +} + +static int assoc_aput (unsigned char type, unsigned int num_indices) +{ + SLang_MMT_Type *mmt; + char *str; + SLang_Assoc_Array_Type *a; + SLang_Object_Type obj; + int ret; + + (void) type; + + if (-1 == pop_index (num_indices, &mmt, &a, &str)) + return -1; + + ret = -1; + + if (0 == SLang_pop (&obj)) + { + if ((obj.data_type != a->type) +#if USE_NEW_ANYTYPE_CODE + && (a->type != SLANG_ANY_TYPE) +#endif + ) + { + (void) SLang_push (&obj); + if ((-1 == SLclass_typecast (a->type, 1, 1)) + || (-1 == SLang_pop (&obj))) + goto the_return; + } + + if (-1 == store_object (a, str, &obj)) + SLang_free_object (&obj); + else + ret = 0; + } + + the_return: + SLang_free_slstring (str); + SLang_free_mmt (mmt); + return ret; +} + +static int assoc_anew (unsigned char type, unsigned int num_dims) +{ + SLang_MMT_Type *mmt; + SLang_Assoc_Array_Type *a; + int has_default_value; + + has_default_value = 0; + switch (num_dims) + { + case 0: + type = SLANG_ANY_TYPE; + break; + case 2: + (void) SLreverse_stack (2); + has_default_value = 1; + /* drop */ + case 1: + if (0 == _SLang_pop_datatype (&type)) + break; + num_dims--; + /* drop */ + default: + SLdo_pop_n (num_dims); + SLang_verror (SL_SYNTAX_ERROR, "Usage: Assoc_Type [DataType_Type]"); + return -1; + } + + a = alloc_assoc_array (type, has_default_value); + if (a == NULL) + return -1; + + if (NULL == (mmt = SLang_create_mmt (SLANG_ASSOC_TYPE, (VOID_STAR) a))) + { + delete_assoc_array (a); + return -1; + } + + if (-1 == SLang_push_mmt (mmt)) + { + SLang_free_mmt (mmt); + return -1; + } + + return 0; +} + +static void assoc_get_keys (SLang_Assoc_Array_Type *a) +{ + SLang_Array_Type *at; + int num; + unsigned int i, j; + char **data; + + /* Note: If support for threads is added, then we need to modify this + * algorithm to prevent another thread from modifying the array. + * However, that should be handled in inner_interp. + */ + num = a->num_elements; + + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num, 1))) + return; + + data = (char **)at->data; + + i = 0; + for (j = 0; j < SLASSOC_HASH_TABLE_SIZE; j++) + { + _SLAssoc_Array_Element_Type *e; + + e = a->elements[j]; + while (e != NULL) + { + /* Next cannot fail because it is an slstring */ + data [i] = SLang_create_slstring (e->key); + e = e->next; + i++; + } + } + (void) SLang_push_array (at, 1); +} + +static int +transfer_element (SLang_Class_Type *cl, VOID_STAR dest_data, + SLang_Object_Type *obj) +{ + unsigned int sizeof_type; + VOID_STAR src_data; + +#if USE_NEW_ANYTYPE_CODE + if (cl->cl_data_type == SLANG_ANY_TYPE) + { + SLang_Any_Type *any; + + if ((-1 == _SLpush_slang_obj (obj)) + || (-1 == SLang_pop_anytype (&any))) + return -1; + + *(SLang_Any_Type **)dest_data = any; + return 0; + } +#endif + /* Optimize for scalar */ + if (cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR) + { + sizeof_type = cl->cl_sizeof_type; + memcpy ((char *) dest_data, (char *)&obj->v, sizeof_type); + return 0; + } + + src_data = _SLclass_get_ptr_to_value (cl, obj); + + if (-1 == (*cl->cl_acopy) (cl->cl_data_type, src_data, dest_data)) + return -1; + + return 0; +} + +static void assoc_get_values (SLang_Assoc_Array_Type *a) +{ + SLang_Array_Type *at; + int num; + unsigned int i, j; + char *dest_data; + unsigned char type; + SLang_Class_Type *cl; + unsigned int sizeof_type; + + /* Note: If support for threads is added, then we need to modify this + * algorithm to prevent another thread from modifying the array. + * However, that should be handled in inner_interp. + */ + num = a->num_elements; + type = a->type; + + cl = _SLclass_get_class (type); + sizeof_type = cl->cl_sizeof_type; + + if (NULL == (at = SLang_create_array (type, 0, NULL, &num, 1))) + return; + + dest_data = (char *)at->data; + + i = 0; + for (j = 0; j < SLASSOC_HASH_TABLE_SIZE; j++) + { + _SLAssoc_Array_Element_Type *e; + + e = a->elements[j]; + while (e != NULL) + { + if (-1 == transfer_element (cl, (VOID_STAR) dest_data, &e->value)) + { + SLang_free_array (at); + return; + } + + dest_data += sizeof_type; + e = e->next; + i++; + } + } + (void) SLang_push_array (at, 1); +} + +static int assoc_key_exists (SLang_Assoc_Array_Type *a, char *key) +{ + return (NULL != find_element (a, key, _SLcompute_string_hash (key))); +} + +static void assoc_delete_key (SLang_Assoc_Array_Type *a, char *key) +{ + unsigned int h; + _SLAssoc_Array_Element_Type *v, *v0; + + h = (unsigned int) (_SLcompute_string_hash (key) % SLASSOC_HASH_TABLE_SIZE); + + v0 = NULL; + v = a->elements[h]; + while (v != NULL) + { + if (v->key == key) + { + if (v0 != NULL) + v0->next = v->next; + else + a->elements[h] = v->next; + + free_element (v); + a->num_elements -= 1; + return; + } + v0 = v; + v = v->next; + } + + /* No such element. Let it pass with no error. */ +} + +#define A SLANG_ASSOC_TYPE +#define S SLANG_STRING_TYPE +static SLang_Intrin_Fun_Type Assoc_Table [] = +{ + MAKE_INTRINSIC_1("assoc_get_keys", assoc_get_keys, SLANG_VOID_TYPE, A), + MAKE_INTRINSIC_1("assoc_get_values", assoc_get_values, SLANG_VOID_TYPE, A), + MAKE_INTRINSIC_2("assoc_key_exists", assoc_key_exists, SLANG_INT_TYPE, A, S), + MAKE_INTRINSIC_2("assoc_delete_key", assoc_delete_key, SLANG_VOID_TYPE, A, S), + + SLANG_END_INTRIN_FUN_TABLE +}; +#undef A +#undef S + +static int assoc_length (unsigned char type, VOID_STAR v, unsigned int *len) +{ + SLang_Assoc_Array_Type *a; + + (void) type; + a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (*(SLang_MMT_Type **)v); + *len = a->num_elements; + return 0; +} + +struct _SLang_Foreach_Context_Type +{ + SLang_MMT_Type *mmt; + SLang_Assoc_Array_Type *a; + unsigned int this_hash_index; + unsigned int next_same_hash_index; +#define CTX_WRITE_KEYS 1 +#define CTX_WRITE_VALUES 2 + unsigned char flags; +}; + +static SLang_Foreach_Context_Type * +cl_foreach_open (unsigned char type, unsigned int num) +{ + SLang_Foreach_Context_Type *c; + unsigned char flags; + SLang_MMT_Type *mmt; + + (void) type; + + if (NULL == (mmt = SLang_pop_mmt (SLANG_ASSOC_TYPE))) + return NULL; + + flags = 0; + + while (num--) + { + char *s; + + if (-1 == SLang_pop_slstring (&s)) + { + SLang_free_mmt (mmt); + return NULL; + } + + if (0 == strcmp (s, "keys")) + flags |= CTX_WRITE_KEYS; + else if (0 == strcmp (s, "values")) + flags |= CTX_WRITE_VALUES; + else + { + SLang_verror (SL_NOT_IMPLEMENTED, + "using '%s' not supported by SLassoc_Type", + s); + SLang_free_slstring (s); + SLang_free_mmt (mmt); + return NULL; + } + + SLang_free_slstring (s); + } + + if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type)))) + { + SLang_free_mmt (mmt); + return NULL; + } + + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + + if (flags == 0) flags = CTX_WRITE_VALUES|CTX_WRITE_KEYS; + + c->flags = flags; + c->mmt = mmt; + c->a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (mmt); + + return c; +} + +static void cl_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + SLang_free_mmt (c->mmt); + SLfree ((char *) c); +} + +static int cl_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + SLang_Assoc_Array_Type *a; + _SLAssoc_Array_Element_Type *e; + unsigned int i, j; + + (void) type; + + if (c == NULL) + return -1; + + a = c->a; + + i = c->this_hash_index; + if (i >= SLASSOC_HASH_TABLE_SIZE) + return 0; + + e = a->elements[i]; + + j = c->next_same_hash_index; + c->next_same_hash_index = j + 1; + + while ((j > 0) && (e != NULL)) + { + j--; + e = e->next; + } + + if (e == NULL) + { + do + { + i++; + if (i >= SLASSOC_HASH_TABLE_SIZE) + return 0; /* no more */ + } + while (a->elements [i] == NULL); + + e = a->elements[i]; + c->this_hash_index = i; + c->next_same_hash_index = 1; + } + + if ((c->flags & CTX_WRITE_KEYS) + && (-1 == SLang_push_string (e->key))) + return -1; + + if ((c->flags & CTX_WRITE_VALUES) + && (-1 == _SLpush_slang_obj (&e->value))) + return -1; + + /* keep going */ + return 1; +} + +int SLang_init_slassoc (void) +{ + SLang_Class_Type *cl; + + if (SLclass_is_class_defined (SLANG_ASSOC_TYPE)) + return 0; + + if (NULL == (cl = SLclass_allocate_class ("Assoc_Type"))) + return -1; + + (void) SLclass_set_destroy_function (cl, assoc_destroy); + (void) SLclass_set_aput_function (cl, assoc_aput); + (void) SLclass_set_aget_function (cl, assoc_aget); + (void) SLclass_set_anew_function (cl, assoc_anew); + cl->cl_length = assoc_length; + cl->cl_foreach_open = cl_foreach_open; + cl->cl_foreach_close = cl_foreach_close; + cl->cl_foreach = cl_foreach; + + if (-1 == SLclass_register_class (cl, SLANG_ASSOC_TYPE, sizeof (SLang_Assoc_Array_Type), SLANG_CLASS_TYPE_MMT)) + return -1; + + if (-1 == SLadd_intrin_fun_table (Assoc_Table, "__SLASSOC__")) + return -1; + + return 0; +} + diff --git a/mdk-stage1/slang/slbstr.c b/mdk-stage1/slang/slbstr.c new file mode 100644 index 000000000..b4b8c4c51 --- /dev/null +++ b/mdk-stage1/slang/slbstr.c @@ -0,0 +1,615 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +struct _SLang_BString_Type +{ + unsigned int num_refs; + unsigned int len; + int ptr_type; +#define IS_SLSTRING 1 +#define IS_MALLOCED 2 +#define IS_NOT_TO_BE_FREED 3 + union + { + unsigned char bytes[1]; + unsigned char *ptr; + } + v; +}; + +#define BS_GET_POINTER(b) ((b)->ptr_type ? (b)->v.ptr : (b)->v.bytes) + +static SLang_BString_Type *create_bstring_of_type (char *bytes, unsigned int len, int type) +{ + SLang_BString_Type *b; + unsigned int size; + + size = sizeof(SLang_BString_Type); + if (type == 0) + size += len; + + if (NULL == (b = (SLang_BString_Type *)SLmalloc (size))) + return NULL; + + b->len = len; + b->num_refs = 1; + b->ptr_type = type; + + switch (type) + { + case 0: + if (bytes != NULL) memcpy ((char *) b->v.bytes, bytes, len); + /* Now \0 terminate it because we want to also use it as a C string + * whenever possible. Note that sizeof(SLang_BString_Type) includes + * space for 1 character and we allocated len extra bytes. Thus, it is + * ok to add a \0 to the end. + */ + b->v.bytes[len] = 0; + break; + + case IS_SLSTRING: + if (NULL == (b->v.ptr = (unsigned char *)SLang_create_nslstring (bytes, len))) + { + SLfree ((char *) b); + return NULL; + } + break; + + case IS_MALLOCED: + case IS_NOT_TO_BE_FREED: + b->v.ptr = (unsigned char *)bytes; + bytes [len] = 0; /* NULL terminate */ + break; + } + + return b; +} + +SLang_BString_Type * +SLbstring_create (unsigned char *bytes, unsigned int len) +{ + return create_bstring_of_type ((char *)bytes, len, 0); +} + +/* Note that ptr must be len + 1 bytes long for \0 termination */ +SLang_BString_Type * +SLbstring_create_malloced (unsigned char *ptr, unsigned int len, int free_on_error) +{ + SLang_BString_Type *b; + + if (ptr == NULL) + return NULL; + + if (NULL == (b = create_bstring_of_type ((char *)ptr, len, IS_MALLOCED))) + { + if (free_on_error) + SLfree ((char *) ptr); + } + return b; +} + +SLang_BString_Type *SLbstring_create_slstring (char *s) +{ + if (s == NULL) + return NULL; + + return create_bstring_of_type (s, strlen (s), IS_SLSTRING); +} + +SLang_BString_Type *SLbstring_dup (SLang_BString_Type *b) +{ + if (b != NULL) + b->num_refs += 1; + + return b; +} + +unsigned char *SLbstring_get_pointer (SLang_BString_Type *b, unsigned int *len) +{ + if (b == NULL) + { + *len = 0; + return NULL; + } + *len = b->len; + return BS_GET_POINTER(b); +} + +void SLbstring_free (SLang_BString_Type *b) +{ + if (b == NULL) + return; + + if (b->num_refs > 1) + { + b->num_refs -= 1; + return; + } + + switch (b->ptr_type) + { + case 0: + case IS_NOT_TO_BE_FREED: + default: + break; + + case IS_SLSTRING: + SLang_free_slstring ((char *)b->v.ptr); + break; + + case IS_MALLOCED: + SLfree ((char *)b->v.ptr); + break; + } + + SLfree ((char *) b); +} + +int SLang_pop_bstring (SLang_BString_Type **b) +{ + return SLclass_pop_ptr_obj (SLANG_BSTRING_TYPE, (VOID_STAR *)b); +} + +int SLang_push_bstring (SLang_BString_Type *b) +{ + if (b == NULL) + return SLang_push_null (); + + b->num_refs += 1; + + if (0 == SLclass_push_ptr_obj (SLANG_BSTRING_TYPE, (VOID_STAR)b)) + return 0; + + b->num_refs -= 1; + return -1; +} + +static int +bstring_bstring_bin_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) a; + (void) b; + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + *c = SLANG_BSTRING_TYPE; + break; + + case SLANG_GT: + case SLANG_GE: + case SLANG_LT: + case SLANG_LE: + case SLANG_EQ: + case SLANG_NE: + *c = SLANG_CHAR_TYPE; + break; + } + return 1; +} + +static int compare_bstrings (SLang_BString_Type *a, SLang_BString_Type *b) +{ + unsigned int len; + int ret; + + len = a->len; + if (b->len < len) len = b->len; + + ret = memcmp ((char *)BS_GET_POINTER(b), (char *)BS_GET_POINTER(a), len); + if (ret != 0) + return ret; + + if (a->len > b->len) + return 1; + if (a->len == b->len) + return 0; + + return -1; +} + +static SLang_BString_Type * +concat_bstrings (SLang_BString_Type *a, SLang_BString_Type *b) +{ + unsigned int len; + SLang_BString_Type *c; + char *bytes; + + len = a->len + b->len; + + if (NULL == (c = SLbstring_create (NULL, len))) + return NULL; + + bytes = (char *)BS_GET_POINTER(c); + + memcpy (bytes, (char *)BS_GET_POINTER(a), a->len); + memcpy (bytes + a->len, (char *)BS_GET_POINTER(b), b->len); + + return c; +} + +static void free_n_bstrings (SLang_BString_Type **a, unsigned int n) +{ + unsigned int i; + + if (a == NULL) return; + + for (i = 0; i < n; i++) + { + SLbstring_free (a[i]); + a[i] = NULL; + } +} + +static int +bstring_bstring_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + SLang_BString_Type **a, **b, **c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + if (na == 1) da = 0; else da = 1; + if (nb == 1) db = 0; else db = 1; + + if (na > nb) n_max = na; else n_max = nb; + + a = (SLang_BString_Type **) ap; + b = (SLang_BString_Type **) bp; + for (n = 0; n < n_max; n++) + { + if ((*a == NULL) || (*b == NULL)) + { + SLang_verror (SL_VARIABLE_UNINITIALIZED, + "Binary string element[%u] not initialized for binary operation", n); + return -1; + } + a += da; b += db; + } + + a = (SLang_BString_Type **) ap; + b = (SLang_BString_Type **) bp; + ic = (char *) cp; + c = NULL; + + switch (op) + { + case SLANG_PLUS: + /* Concat */ + c = (SLang_BString_Type **) cp; + for (n = 0; n < n_max; n++) + { + if (NULL == (c[n] = concat_bstrings (*a, *b))) + goto return_error; + + a += da; b += db; + } + break; + + case SLANG_NE: + for (n = 0; n < n_max; n++) + { + ic [n] = (0 != compare_bstrings (*a, *b)); + a += da; + b += db; + } + break; + case SLANG_GT: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) > 0); + a += da; + b += db; + } + break; + case SLANG_GE: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) >= 0); + a += da; + b += db; + } + break; + case SLANG_LT: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) < 0); + a += da; + b += db; + } + break; + case SLANG_LE: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) <= 0); + a += da; + b += db; + } + break; + case SLANG_EQ: + for (n = 0; n < n_max; n++) + { + ic [n] = (compare_bstrings (*a, *b) == 0); + a += da; + b += db; + } + break; + } + return 1; + + return_error: + if (c != NULL) + { + free_n_bstrings (c, n); + while (n < n_max) + { + c[n] = NULL; + n++; + } + } + return -1; +} + +/* If preserve_ptr, then use a[i] as the bstring data. See how this function + * is called by the binary op routines for why. + */ +static SLang_BString_Type ** +make_n_bstrings (SLang_BString_Type **b, char **a, unsigned int n, int ptr_type) +{ + unsigned int i; + int malloc_flag; + + malloc_flag = 0; + if (b == NULL) + { + b = (SLang_BString_Type **) SLmalloc ((n + 1) * sizeof (SLang_BString_Type *)); + if (b == NULL) + return NULL; + malloc_flag = 1; + } + + for (i = 0; i < n; i++) + { + char *s = a[i]; + + if (s == NULL) + { + b[i] = NULL; + continue; + } + + if (NULL == (b[i] = create_bstring_of_type (s, strlen(s), ptr_type))) + { + free_n_bstrings (b, i); + if (malloc_flag) SLfree ((char *) b); + return NULL; + } + } + + return b; +} + +static int +bstring_string_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + SLang_BString_Type **b; + int ret; + + if (NULL == (b = make_n_bstrings (NULL, (char **)bp, nb, IS_NOT_TO_BE_FREED))) + return -1; + + b_type = SLANG_BSTRING_TYPE; + ret = bstring_bstring_bin_op (op, + a_type, ap, na, + b_type, (VOID_STAR) b, nb, + cp); + free_n_bstrings (b, nb); + SLfree ((char *) b); + return ret; +} + +static int +string_bstring_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + SLang_BString_Type **a; + int ret; + + if (NULL == (a = make_n_bstrings (NULL, (char **)ap, na, IS_NOT_TO_BE_FREED))) + return -1; + + a_type = SLANG_BSTRING_TYPE; + ret = bstring_bstring_bin_op (op, + a_type, (VOID_STAR) a, na, + b_type, bp, nb, + cp); + free_n_bstrings (a, na); + SLfree ((char *) a); + + return ret; +} + +static void bstring_destroy (unsigned char unused, VOID_STAR s) +{ + (void) unused; + SLbstring_free (*(SLang_BString_Type **) s); +} + +static int bstring_push (unsigned char unused, VOID_STAR sptr) +{ + (void) unused; + + return SLang_push_bstring (*(SLang_BString_Type **) sptr); +} + +static int string_to_bstring (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + char **s; + SLang_BString_Type **b; + + (void) a_type; + (void) b_type; + + s = (char **) ap; + b = (SLang_BString_Type **) bp; + + if (NULL == make_n_bstrings (b, s, na, IS_SLSTRING)) + return -1; + + return 1; +} + +static int bstring_to_string (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + char **s; + unsigned int i; + SLang_BString_Type **a; + + (void) a_type; + (void) b_type; + + s = (char **) bp; + a = (SLang_BString_Type **) ap; + + for (i = 0; i < na; i++) + { + SLang_BString_Type *ai = a[i]; + + if (ai == NULL) + { + s[i] = NULL; + continue; + } + + if (NULL == (s[i] = SLang_create_slstring ((char *)BS_GET_POINTER(ai)))) + { + while (i != 0) + { + i--; + SLang_free_slstring (s[i]); + s[i] = NULL; + } + return -1; + } + } + + return 1; +} + +static char *bstring_string (unsigned char type, VOID_STAR v) +{ + SLang_BString_Type *s; + unsigned char buf[128]; + unsigned char *bytes, *bytes_max; + unsigned char *b, *bmax; + + (void) type; + + s = *(SLang_BString_Type **) v; + bytes = BS_GET_POINTER(s); + bytes_max = bytes + s->len; + + b = buf; + bmax = buf + (sizeof (buf) - 4); + + while (bytes < bytes_max) + { + unsigned char ch = *bytes; + + if ((ch < 32) || (ch >= 127) || (ch == '\\')) + { + if (b + 4 > bmax) + break; + + sprintf ((char *) b, "\\%03o", ch); + b += 4; + } + else + { + if (b == bmax) + break; + + *b++ = ch; + } + + bytes++; + } + + if (bytes < bytes_max) + { + *b++ = '.'; + *b++ = '.'; + *b++ = '.'; + } + *b = 0; + + return SLmake_string ((char *)buf); +} + +static unsigned int bstrlen_cmd (SLang_BString_Type *b) +{ + return b->len; +} + +static SLang_Intrin_Fun_Type BString_Table [] = /*{{{*/ +{ + MAKE_INTRINSIC_1("bstrlen", bstrlen_cmd, SLANG_UINT_TYPE, SLANG_BSTRING_TYPE), + MAKE_INTRINSIC_0("pack", _SLpack, SLANG_VOID_TYPE), + MAKE_INTRINSIC_2("unpack", _SLunpack, SLANG_VOID_TYPE, SLANG_STRING_TYPE, SLANG_BSTRING_TYPE), + MAKE_INTRINSIC_1("pad_pack_format", _SLpack_pad_format, SLANG_VOID_TYPE, SLANG_STRING_TYPE), + MAKE_INTRINSIC_1("sizeof_pack", _SLpack_compute_size, SLANG_UINT_TYPE, SLANG_STRING_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +int _SLang_init_bstring (void) +{ + SLang_Class_Type *cl; + + if (NULL == (cl = SLclass_allocate_class ("BString_Type"))) + return -1; + (void) SLclass_set_destroy_function (cl, bstring_destroy); + (void) SLclass_set_push_function (cl, bstring_push); + (void) SLclass_set_string_function (cl, bstring_string); + + if (-1 == SLclass_register_class (cl, SLANG_BSTRING_TYPE, sizeof (char *), + SLANG_CLASS_TYPE_PTR)) + return -1; + + if ((-1 == SLclass_add_typecast (SLANG_BSTRING_TYPE, SLANG_STRING_TYPE, bstring_to_string, 1)) + || (-1 == SLclass_add_typecast (SLANG_STRING_TYPE, SLANG_BSTRING_TYPE, string_to_bstring, 1)) + || (-1 == SLclass_add_binary_op (SLANG_BSTRING_TYPE, SLANG_BSTRING_TYPE, bstring_bstring_bin_op, bstring_bstring_bin_op_result)) + || (-1 == SLclass_add_binary_op (SLANG_STRING_TYPE, SLANG_BSTRING_TYPE, string_bstring_bin_op, bstring_bstring_bin_op_result)) + || (-1 == SLclass_add_binary_op (SLANG_BSTRING_TYPE, SLANG_STRING_TYPE, bstring_string_bin_op, bstring_bstring_bin_op_result))) + + return -1; + + if (-1 == SLadd_intrin_fun_table (BString_Table, NULL)) + return -1; + + return 0; +} + diff --git a/mdk-stage1/slang/slclass.c b/mdk-stage1/slang/slclass.c new file mode 100644 index 000000000..733888cb8 --- /dev/null +++ b/mdk-stage1/slang/slclass.c @@ -0,0 +1,1391 @@ +/* User defined objects */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#if _SLANG_OPTIMIZE_FOR_SPEED +unsigned char _SLclass_Class_Type [256]; +#endif + +static SLang_Class_Type *Registered_Types[256]; +SLang_Class_Type *_SLclass_get_class (unsigned char type) +{ + SLang_Class_Type *cl; + + cl = Registered_Types [type]; + if (cl == NULL) + SLang_exit_error ("Application error: Type %d not registered", (int) type); + + return cl; +} + +int SLclass_is_class_defined (unsigned char type) +{ + return (NULL != Registered_Types[type]); +} + +VOID_STAR _SLclass_get_ptr_to_value (SLang_Class_Type *cl, + SLang_Object_Type *obj) +{ + VOID_STAR p; + + switch (cl->cl_class_type) + { + case SLANG_CLASS_TYPE_MMT: + case SLANG_CLASS_TYPE_PTR: + case SLANG_CLASS_TYPE_SCALAR: + p = (VOID_STAR) &obj->v; + break; + + case SLANG_CLASS_TYPE_VECTOR: + p = obj->v.ptr_val; + break; + + default: + p = NULL; + } + return p; +} + +char *SLclass_get_datatype_name (unsigned char stype) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (stype); + return cl->cl_name; +} + +static int method_undefined_error (unsigned char type, char *method, char *name) +{ + if (name == NULL) name = SLclass_get_datatype_name (type); + + SLang_verror (SL_TYPE_MISMATCH, "%s method not defined for %s", + method, name); + return -1; +} + +static int +scalar_vector_bin_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) a; (void) b; + switch (op) + { + case SLANG_NE: + case SLANG_EQ: + *c = SLANG_INT_TYPE; + return 1; + } + return 0; +} + +static int +scalar_vector_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + int *c; + char *a, *b; + unsigned int da, db; + unsigned int n, n_max; + unsigned int data_type_len; + SLang_Class_Type *cl; + + (void) b_type; + cl = _SLclass_get_class (a_type); + + data_type_len = cl->cl_sizeof_type; + + a = (char *) ap; + b = (char *) bp; + c = (int *) cp; + + if (na == 1) da = 0; else da = data_type_len; + if (nb == 1) db = 0; else db = data_type_len; + if (na > nb) n_max = na; else n_max = nb; + + switch (op) + { + default: + return 0; + + case SLANG_NE: + for (n = 0; n < n_max; n++) + { + c[n] = (0 != SLMEMCMP(a, b, data_type_len)); + a += da; b += db; + } + break; + + case SLANG_EQ: + for (n = 0; n < n_max; n++) + { + c[n] = (0 == SLMEMCMP(a, b, data_type_len)); + a += da; b += db; + } + break; + } + return 1; +} + +static int scalar_fread (unsigned char type, FILE *fp, VOID_STAR ptr, + unsigned int desired, unsigned int *actual) +{ + unsigned int n; + + n = fread ((char *) ptr, _SLclass_get_class (type)->cl_sizeof_type, + desired, fp); + *actual = n; + return 0; +} + +static int scalar_fwrite (unsigned char type, FILE *fp, VOID_STAR ptr, + unsigned int desired, unsigned int *actual) +{ + unsigned int n; + + n = fwrite ((char *) ptr, _SLclass_get_class (type)->cl_sizeof_type, + desired, fp); + *actual = n; + return 0; +} + +static int vector_apush (unsigned char type, VOID_STAR ptr) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + return (*cl->cl_push)(type, (VOID_STAR) &ptr); +} + +static int vector_apop (unsigned char type, VOID_STAR ptr) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + return (*cl->cl_pop)(type, (VOID_STAR) &ptr); +} + +static int default_push_mmt (unsigned char type_unused, VOID_STAR ptr) +{ + SLang_MMT_Type *ref; + + (void) type_unused; + ref = *(SLang_MMT_Type **) ptr; + return SLang_push_mmt (ref); +} + +static void default_destroy_simple (unsigned char type_unused, VOID_STAR ptr_unused) +{ + (void) type_unused; + (void) ptr_unused; +} + +static void default_destroy_user (unsigned char type, VOID_STAR ptr) +{ + (void) type; + SLang_free_mmt (*(SLang_MMT_Type **) ptr); +} + +static int default_pop (unsigned char type, VOID_STAR ptr) +{ + return SLclass_pop_ptr_obj (type, (VOID_STAR *) ptr); +} + +static int default_datatype_deref (unsigned char type) +{ + return method_undefined_error (type, "datatype_deref", NULL); +} + +static int default_acopy (unsigned char type, VOID_STAR from, VOID_STAR to) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + if (-1 == (*cl->cl_apush) (type, from)) + return -1; + return (*cl->cl_apop) (type, to); +} + +static int default_dereference_object (unsigned char type, VOID_STAR ptr) +{ + (void) ptr; + return method_undefined_error (type, "dereference", NULL); +} + +static char *default_string (unsigned char stype, VOID_STAR v) +{ + char buf [256]; + char *s; +#if SLANG_HAS_COMPLEX + double *cplx; +#endif + s = buf; + + switch (stype) + { + case SLANG_STRING_TYPE: + s = *(char **) v; + break; + + case SLANG_NULL_TYPE: + s = "NULL"; + break; + + case SLANG_DATATYPE_TYPE: + s = SLclass_get_datatype_name ((unsigned char) *(int *)v); + break; + +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + cplx = *(double **) v; + if (cplx[1] < 0) + sprintf (s, "(%g - %gi)", cplx [0], -cplx [1]); + else + sprintf (s, "(%g + %gi)", cplx [0], cplx [1]); + break; +#endif + default: + s = SLclass_get_datatype_name (stype); + } + + return SLmake_string (s); +} + +static int +use_cmp_bin_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + if (a != b) + return 0; + switch (op) + { + case SLANG_NE: + case SLANG_EQ: + case SLANG_LT: + case SLANG_LE: + case SLANG_GT: + case SLANG_GE: + *c = SLANG_INT_TYPE; + return 1; + } + return 0; +} + +static int +use_cmp_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + int *c; + char *a, *b; + unsigned int da, db; + unsigned int n, n_max; + unsigned int data_type_len; + SLang_Class_Type *cl; + int (*cmp)(unsigned char, VOID_STAR, VOID_STAR, int *); + + (void) b_type; + cl = _SLclass_get_class (a_type); + cmp = cl->cl_cmp; + data_type_len = cl->cl_sizeof_type; + + a = (char *) ap; + b = (char *) bp; + c = (int *) cp; + + if (na == 1) da = 0; else da = data_type_len; + if (nb == 1) db = 0; else db = data_type_len; + if (na > nb) n_max = na; else n_max = nb; + + switch (op) + { + int result; + + default: + return 0; + + case SLANG_NE: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result != 0); + a += da; b += db; + } + break; + + case SLANG_EQ: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result == 0); + a += da; b += db; + } + break; + + case SLANG_GT: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result > 0); + a += da; b += db; + } + break; + case SLANG_GE: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result >= 0); + a += da; b += db; + } + break; + case SLANG_LT: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result < 0); + a += da; b += db; + } + break; + case SLANG_LE: + for (n = 0; n < n_max; n++) + { + if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) + return -1; + c[n] = (result <= 0); + a += da; b += db; + } + break; + } + return 1; +} + + +int SLclass_get_class_id (SLang_Class_Type *cl) +{ + if (cl == NULL) + return -1; + return (int) cl->cl_data_type; +} + +SLang_Class_Type *SLclass_allocate_class (char *name) +{ + SLang_Class_Type *cl; + unsigned int i; + + for (i = 0; i < 256; i++) + { + cl = Registered_Types [i]; + if ((cl != NULL) + && (0 == strcmp (cl->cl_name, name))) + { + SLang_verror (SL_DUPLICATE_DEFINITION, "Type name %s already exists", name); + return NULL; + } + } + + cl = (SLang_Class_Type *) SLmalloc (sizeof (SLang_Class_Type)); + if (cl == NULL) return NULL; + + SLMEMSET ((char *) cl, 0, sizeof (SLang_Class_Type)); + + if (NULL == (cl->cl_name = SLang_create_slstring (name))) + { + SLfree ((char *) cl); + return NULL; + } + + return cl; +} + +static int DataType_Ids [256]; + +int _SLang_push_datatype (unsigned char data_type) +{ + /* This data type could be a copy of another type, e.g., short and + * int if they are the same size (Int16 == Short). So, make sure + * we push the original and not the copy. + */ + data_type = _SLclass_get_class (data_type)->cl_data_type; + return SLclass_push_int_obj (SLANG_DATATYPE_TYPE, (int) data_type); +} + +static int datatype_deref (unsigned char type, VOID_STAR ptr) +{ + SLang_Class_Type *cl; + int status; + + /* The parser generated code for this as if a function call were to be + * made. However, we are calling the deref object routine + * instead of the function call. So, I must simulate the function call. + */ + if (-1 == _SL_increment_frame_pointer ()) + return -1; + + type = (unsigned char) *(int *) ptr; + cl = _SLclass_get_class (type); + status = (*cl->cl_datatype_deref) (type); + + (void) _SL_decrement_frame_pointer (); + return status; +} + +static int datatype_push (unsigned char type_unused, VOID_STAR ptr) +{ + (void) type_unused; + return _SLang_push_datatype (*(int *) ptr); +} + +int _SLang_pop_datatype (unsigned char *type) +{ + int i; + + if (-1 == SLclass_pop_int_obj (SLANG_DATATYPE_TYPE, &i)) + return -1; + + *type = (unsigned char) i; + return 0; +} + +static int datatype_pop (unsigned char type, VOID_STAR ptr) +{ + if (-1 == _SLang_pop_datatype (&type)) + return -1; + + *(int *) ptr = type; + return 0; +} + +int _SLclass_init (void) +{ + SLang_Class_Type *cl; + + /* First initialize the container classes. This is so binary operations + * added later will work with them. + */ + if (-1 == _SLarray_init_slarray ()) + return -1; + + /* DataType_Type */ + if (NULL == (cl = SLclass_allocate_class ("DataType_Type"))) + return -1; + cl->cl_pop = datatype_pop; + cl->cl_push = datatype_push; + cl->cl_dereference = datatype_deref; + if (-1 == SLclass_register_class (cl, SLANG_DATATYPE_TYPE, sizeof(int), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + + return 0; +} + +static int register_new_datatype (char *name, unsigned char type) +{ + DataType_Ids [type] = type; + return SLadd_intrinsic_variable (name, (VOID_STAR) (DataType_Ids + type), + SLANG_DATATYPE_TYPE, 1); +} + +int SLclass_create_synonym (char *name, unsigned char type) +{ + if (NULL == _SLclass_get_class (type)) + return -1; + + return register_new_datatype (name, type); +} + +int _SLclass_copy_class (unsigned char to, unsigned char from) +{ + SLang_Class_Type *cl = _SLclass_get_class (from); + + if (Registered_Types[to] != NULL) + SLang_exit_error ("Application error: Class already exists"); + + Registered_Types[to] = cl; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (to != SLANG_UNDEFINED_TYPE) + _SLclass_Class_Type [to] = cl->cl_class_type; +#endif + return 0; +} + +int SLclass_register_class (SLang_Class_Type *cl, unsigned char type, unsigned int type_size, unsigned char class_type) +{ + char *name; + unsigned int i; + int can_binop = 1; /* scalar_vector_bin_op should work + * for all data types. + */ + + if (type == SLANG_VOID_TYPE) for (i = 0; i < 256; i++) + { + if ((Registered_Types[i] == NULL) + && (i != SLANG_VOID_TYPE)) + { + type = (unsigned char) i; + break; + } + } + + if ((NULL != Registered_Types [type]) + || (type == SLANG_VOID_TYPE)) + { + SLang_verror (SL_APPLICATION_ERROR, "Class type %d already in use", (int) type); + return -1; + } + + cl->cl_data_type = type; + cl->cl_class_type = class_type; + name = cl->cl_name; + + switch (class_type) + { + case SLANG_CLASS_TYPE_MMT: + if (cl->cl_push == NULL) cl->cl_push = default_push_mmt; + if (cl->cl_destroy == NULL) + return method_undefined_error (type, "destroy", name); + cl->cl_user_destroy_fun = cl->cl_destroy; + cl->cl_destroy = default_destroy_user; + type_size = sizeof (VOID_STAR); + break; + + case SLANG_CLASS_TYPE_SCALAR: + if (cl->cl_destroy == NULL) cl->cl_destroy = default_destroy_simple; + if ((type_size == 0) + || (type_size > sizeof (_SL_Object_Union_Type))) + { + SLang_verror (SL_INVALID_PARM, + "Type size for %s not appropriate for SCALAR type", + name); + return -1; + } + if (cl->cl_pop == NULL) + return method_undefined_error (type, "pop", name); + if (cl->cl_fread == NULL) cl->cl_fread = scalar_fread; + if (cl->cl_fwrite == NULL) cl->cl_fwrite = scalar_fwrite; + + can_binop = 1; + break; + + case SLANG_CLASS_TYPE_PTR: + if (cl->cl_destroy == NULL) + return method_undefined_error (type, "destroy", name); + type_size = sizeof (VOID_STAR); + break; + + case SLANG_CLASS_TYPE_VECTOR: + if (cl->cl_destroy == NULL) + return method_undefined_error (type, "destroy", name); + if (cl->cl_pop == NULL) + return method_undefined_error (type, "pop", name); + cl->cl_apop = vector_apop; + cl->cl_apush = vector_apush; + cl->cl_adestroy = default_destroy_simple; + if (cl->cl_fread == NULL) cl->cl_fread = scalar_fread; + if (cl->cl_fwrite == NULL) cl->cl_fwrite = scalar_fwrite; + can_binop = 1; + break; + + default: + SLang_verror (SL_INVALID_PARM, "%s: unknown class type (%d)", name, class_type); + return -1; + } + +#if _SLANG_OPTIMIZE_FOR_SPEED + if (type != SLANG_UNDEFINED_TYPE) + _SLclass_Class_Type [type] = class_type; +#endif + + if (type_size == 0) + { + SLang_verror (SL_INVALID_PARM, "type size must be non-zero for %s", name); + return -1; + } + + if (cl->cl_string == NULL) cl->cl_string = default_string; + if (cl->cl_acopy == NULL) cl->cl_acopy = default_acopy; + if (cl->cl_datatype_deref == NULL) cl->cl_datatype_deref = default_datatype_deref; + + if (cl->cl_pop == NULL) cl->cl_pop = default_pop; + + if (cl->cl_push == NULL) + return method_undefined_error (type, "push", name); + + if (cl->cl_byte_code_destroy == NULL) + cl->cl_byte_code_destroy = cl->cl_destroy; + if (cl->cl_push_literal == NULL) + cl->cl_push_literal = cl->cl_push; + + if (cl->cl_dereference == NULL) + cl->cl_dereference = default_dereference_object; + + if (cl->cl_apop == NULL) cl->cl_apop = cl->cl_pop; + if (cl->cl_apush == NULL) cl->cl_apush = cl->cl_push; + if (cl->cl_adestroy == NULL) cl->cl_adestroy = cl->cl_destroy; + if (cl->cl_push_intrinsic == NULL) cl->cl_push_intrinsic = cl->cl_push; + + if ((cl->cl_foreach == NULL) + || (cl->cl_foreach_open == NULL) + || (cl->cl_foreach_close == NULL)) + { + cl->cl_foreach = _SLarray_cl_foreach; + cl->cl_foreach_open = _SLarray_cl_foreach_open; + cl->cl_foreach_close = _SLarray_cl_foreach_close; + } + + cl->cl_sizeof_type = type_size; + + if (NULL == (cl->cl_transfer_buf = (VOID_STAR) SLmalloc (type_size))) + return -1; + + Registered_Types[type] = cl; + + if (-1 == register_new_datatype (name, type)) + return -1; + + if (cl->cl_cmp != NULL) + { + if (-1 == SLclass_add_binary_op (type, type, use_cmp_bin_op, use_cmp_bin_op_result)) + return -1; + } + else if (can_binop + && (-1 == SLclass_add_binary_op (type, type, scalar_vector_bin_op, scalar_vector_bin_op_result))) + return -1; + + cl->cl_anytype_typecast = _SLanytype_typecast; + + return 0; +} + +int SLclass_add_math_op (unsigned char type, + int (*handler)(int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*result) (int, unsigned char, unsigned char *)) +{ + SLang_Class_Type *cl = _SLclass_get_class (type); + + cl->cl_math_op = handler; + cl->cl_math_op_result_type = result; + return 0; +} + +int SLclass_add_binary_op (unsigned char a, unsigned char b, + int (*f) (int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*r) (int, unsigned char, unsigned char, unsigned char *)) +{ + SLang_Class_Type *cl; + SL_OOBinary_Type *ab; + + if ((f == NULL) || (r == NULL)) + { + SLang_verror (SL_INVALID_PARM, "SLclass_add_binary_op"); + return -1; + } + + cl = _SLclass_get_class (a); + (void) _SLclass_get_class (b); + + if (NULL == (ab = (SL_OOBinary_Type *) SLmalloc (sizeof(SL_OOBinary_Type)))) + return -1; + + ab->data_type = b; + ab->binary_function = f; + ab->binary_result = r; + ab->next = cl->cl_binary_ops; + cl->cl_binary_ops = ab; + + if ((a != SLANG_ARRAY_TYPE) + && (b != SLANG_ARRAY_TYPE)) + { + if ((-1 == _SLarray_add_bin_op (a)) + || (-1 == _SLarray_add_bin_op (b))) + return -1; + } + + return 0; +} + +int SLclass_add_unary_op (unsigned char type, + int (*f)(int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*r)(int, unsigned char, unsigned char *)) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + if ((f == NULL) || (r == NULL)) + { + SLang_verror (SL_INVALID_PARM, "SLclass_add_unary_op"); + return -1; + } + + cl->cl_unary_op = f; + cl->cl_unary_op_result_type = r; + + return 0; +} + +int SLclass_add_app_unary_op (unsigned char type, + int (*f)(int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR), + int (*r)(int, unsigned char, unsigned char *)) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + if ((f == NULL) || (r == NULL)) + { + SLang_verror (SL_INVALID_PARM, "SLclass_add_app_unary_op"); + return -1; + } + + cl->cl_app_unary_op = f; + cl->cl_app_unary_op_result_type = r; + + return 0; +} + +int SLclass_set_pop_function (SLang_Class_Type *cl, int (*f)(unsigned char, VOID_STAR)) +{ + if (cl == NULL) return -1; + cl->cl_pop = f; + + return 0; +} + +int SLclass_set_push_function (SLang_Class_Type *cl, int (*f)(unsigned char, VOID_STAR)) +{ + if (cl == NULL) return -1; + cl->cl_push = f; + + return 0; +} + +int SLclass_set_string_function (SLang_Class_Type *cl, char *(*f)(unsigned char, VOID_STAR)) +{ + if (cl == NULL) return -1; + + cl->cl_string = f; + return 0; +} + +int SLclass_set_destroy_function (SLang_Class_Type *cl, void (*f)(unsigned char, VOID_STAR)) +{ + if (cl == NULL) return -1; + + cl->cl_destroy = f; + return 0; +} + +int SLclass_set_sget_function (SLang_Class_Type *cl, int (*f)(unsigned char, char *)) +{ + if (cl == NULL) return -1; + cl->cl_sget = f; + return 0; +} + +int SLclass_set_sput_function (SLang_Class_Type *cl, int (*f)(unsigned char, char *)) +{ + if (cl == NULL) return -1; + cl->cl_sput = f; + return 0; +} + +int SLclass_set_aget_function (SLang_Class_Type *cl, int (*f)(unsigned char, unsigned int)) +{ + if (cl == NULL) return -1; + cl->cl_aget = f; + return 0; +} + +int SLclass_set_aput_function (SLang_Class_Type *cl, int (*f)(unsigned char, unsigned int)) +{ + if (cl == NULL) return -1; + cl->cl_aput = f; + return 0; +} + +int SLclass_set_anew_function (SLang_Class_Type *cl, int (*f)(unsigned char, unsigned int)) +{ + if (cl == NULL) return -1; + cl->cl_anew = f; + return 0; +} + +/* Misc */ +void _SLclass_type_mismatch_error (unsigned char a, unsigned char b) +{ + SLang_verror (SL_TYPE_MISMATCH, "Expecting %s, found %s", + SLclass_get_datatype_name (a), + SLclass_get_datatype_name (b)); +} + +/* */ + +static int null_binary_fun (int op, + unsigned char a, VOID_STAR ap, unsigned int na, + unsigned char b, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + int *ic; + unsigned int i; + int c; + + (void) ap; (void) bp; + + switch (op) + { + case SLANG_EQ: + c = (a == b); + break; + + case SLANG_NE: + c = (a != b); + break; + + default: + return 0; + } + + if (na > nb) nb = na; + ic = (int *) cp; + for (i = 0; i < nb; i++) + ic[i] = c; + + return 1; +} + +static char *get_binary_op_string (int op) +{ + static char *ops[SLANG_MOD] = + { + "+", "=", "*", "/", "==", "!=", ">", ">=", "<", "<=", "^", + "or", "and", "&", "|", "xor", "shl", "shr", "mod" + }; + + if ((op > SLANG_MOD) || (op <= 0)) + return "??"; + return ops[op - 1]; +} + +int (*_SLclass_get_binary_fun (int op, + SLang_Class_Type *a_cl, SLang_Class_Type *b_cl, + SLang_Class_Type **c_cl, int do_error)) +(int, + unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR, unsigned int, + VOID_STAR) +{ + SL_OOBinary_Type *bt; + unsigned char a, b, c; + + a = a_cl->cl_data_type; + b = b_cl->cl_data_type; + + if ((a == SLANG_NULL_TYPE) || (b == SLANG_NULL_TYPE)) + { + *c_cl = _SLclass_get_class (SLANG_INT_TYPE); + return null_binary_fun; + } + + bt = a_cl->cl_binary_ops; + + while (bt != NULL) + { + if (bt->data_type == b) + { + if (1 != (*bt->binary_result)(op, a, b, &c)) + break; + + if (c == a) *c_cl = a_cl; + else if (c == b) *c_cl = b_cl; + else *c_cl = _SLclass_get_class (c); + + return bt->binary_function; + } + + bt = bt->next; + } + + if (do_error) + SLang_verror (SL_TYPE_MISMATCH, "%s %s %s is not possible", + a_cl->cl_name, get_binary_op_string (op), b_cl->cl_name); + + *c_cl = NULL; + return NULL; +} + +int (*_SLclass_get_unary_fun (int op, + SLang_Class_Type *a_cl, + SLang_Class_Type **b_cl, + int utype)) +(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR) +{ + int (*f)(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); + int (*r)(int, unsigned char, unsigned char *); + unsigned char a; + unsigned char b; + + switch (utype) + { + case _SLANG_BC_UNARY: + f = a_cl->cl_unary_op; + r = a_cl->cl_unary_op_result_type; + break; + + case _SLANG_BC_MATH_UNARY: + f = a_cl->cl_math_op; + r = a_cl->cl_math_op_result_type; + break; + + case _SLANG_BC_APP_UNARY: + f = a_cl->cl_app_unary_op; + r = a_cl->cl_app_unary_op_result_type; + break; + + default: + f = NULL; + r = NULL; + } + + a = a_cl->cl_data_type; + if ((f != NULL) && (r != NULL) && (1 == (*r) (op, a, &b))) + { + if (a == b) + *b_cl = a_cl; + else + *b_cl = _SLclass_get_class (b); + return f; + } + + SLang_verror (SL_TYPE_MISMATCH, "undefined unary operation/function on %s", + a_cl->cl_name); + + *b_cl = NULL; + + return NULL; +} + +int +SLclass_typecast (unsigned char to_type, int is_implicit, int allow_array) +{ + unsigned char from_type; + SLang_Class_Type *cl_to, *cl_from; + SLang_Object_Type obj; + VOID_STAR ap; + VOID_STAR bp; + int status; + + if (-1 == SLang_pop (&obj)) + return -1; + + from_type = obj.data_type; + if (from_type == to_type) + { + SLang_push (&obj); + return 0; + } + + cl_from = _SLclass_get_class (from_type); + + /* Since the typecast functions are designed to work on arrays, + * get the pointer to the value instead of just &obj.v. + */ + ap = _SLclass_get_ptr_to_value (cl_from, &obj); + + if ((from_type == SLANG_ARRAY_TYPE) + && (allow_array || (to_type != SLANG_ANY_TYPE))) + { + if (allow_array == 0) + goto return_error; + + cl_to = _SLclass_get_class (SLANG_ARRAY_TYPE); + bp = cl_to->cl_transfer_buf; + status = _SLarray_typecast (from_type, ap, 1, to_type, bp, is_implicit); + } + else + { + int (*t) (unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR); + + if (NULL == (t = _SLclass_get_typecast (from_type, to_type, is_implicit))) + { + SLang_free_object (&obj); + return -1; + } + + cl_to = _SLclass_get_class (to_type); + bp = cl_to->cl_transfer_buf; + status = (*t) (from_type, ap, 1, to_type, bp); + } + + if (1 == status) + { + if (-1 == (*cl_to->cl_apush)(to_type, bp)) + { + (*cl_to->cl_adestroy) (to_type, bp); + SLang_free_object (&obj); + return -1; + } + + /* cl_apush will push a copy, so destry this one */ + (*cl_to->cl_adestroy) (to_type, bp); + SLang_free_object (&obj); + return 0; + } + + return_error: + + SLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s", + cl_from->cl_name, + SLclass_get_datatype_name (to_type)); + SLang_free_object (&obj); + return -1; +} + +int (*_SLclass_get_typecast (unsigned char from, unsigned char to, int is_implicit)) +(unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR) +{ + SL_Typecast_Type *t; + SLang_Class_Type *cl_from; + + cl_from = _SLclass_get_class (from); + + t = cl_from->cl_typecast_funs; + while (t != NULL) + { + if (t->data_type != to) + { + t = t->next; + continue; + } + + if (is_implicit && (t->allow_implicit == 0)) + break; + + return t->typecast; + } + + if (to == SLANG_ANY_TYPE) + return _SLanytype_typecast; + + if ((is_implicit == 0) + && (cl_from->cl_void_typecast != NULL)) + return cl_from->cl_void_typecast; + + SLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s", + cl_from->cl_name, + SLclass_get_datatype_name (to)); + + return NULL; +} + +int +SLclass_add_typecast (unsigned char from, unsigned char to, + int (*f)_PROTO((unsigned char, VOID_STAR, unsigned int, + unsigned char, VOID_STAR)), + int allow_implicit) +{ + SL_Typecast_Type *t; + SLang_Class_Type *cl; + + cl = _SLclass_get_class (from); + if (to == SLANG_VOID_TYPE) + { + cl->cl_void_typecast = f; + return 0; + } + + (void) _SLclass_get_class (to); + + if (NULL == (t = (SL_Typecast_Type *) SLmalloc (sizeof (SL_Typecast_Type)))) + return -1; + + SLMEMSET((char *) t, 0, sizeof(SL_Typecast_Type)); + t->data_type = to; + t->next = cl->cl_typecast_funs; + t->typecast = f; + t->allow_implicit = allow_implicit; + + cl->cl_typecast_funs = t; + + return 0; +} + +SLang_MMT_Type *SLang_pop_mmt (unsigned char type) /*{{{*/ +{ + SLang_MMT_Type *mmt; + + if (-1 == SLclass_pop_ptr_obj (type, (VOID_STAR *) &mmt)) + mmt = NULL; + return mmt; + +#if 0 + SLang_Object_Type obj; + SLang_Class_Type *cl; + + if (_SLang_pop_object_of_type (type, &obj)) + return NULL; + + cl = _SLclass_get_class (type); + if ((cl->cl_class_type == SLANG_CLASS_TYPE_MMT) + && (obj.data_type == type)) + { + return obj.v.ref; + } + + _SLclass_type_mismatch_error (type, obj.data_type); + SLang_free_object (&obj); + return NULL; +#endif +} + +/*}}}*/ + +int SLang_push_mmt (SLang_MMT_Type *ref) /*{{{*/ +{ + if (ref == NULL) + return SLang_push_null (); + + ref->count += 1; + + if (0 == SLclass_push_ptr_obj (ref->data_type, (VOID_STAR) ref)) + return 0; + + ref->count -= 1; + return -1; +} + +/*}}}*/ + +void SLang_inc_mmt (SLang_MMT_Type *ref) +{ + if (ref != NULL) + ref->count += 1; +} + +VOID_STAR SLang_object_from_mmt (SLang_MMT_Type *ref) +{ + if (ref == NULL) + return NULL; + + return ref->user_data; +} + +SLang_MMT_Type *SLang_create_mmt (unsigned char t, VOID_STAR p) +{ + SLang_MMT_Type *ref; + + (void) _SLclass_get_class (t); /* check to see if it is registered */ + + if (NULL == (ref = (SLang_MMT_Type *) SLmalloc (sizeof (SLang_MMT_Type)))) + return NULL; + + SLMEMSET ((char *) ref, 0, sizeof (SLang_MMT_Type)); + + ref->data_type = t; + ref->user_data = p; + /* FIXME!! To be consistent with other types, the reference count should + * be set to 1 here. However, doing so will require other code changes + * involving the use of MMTs. For instance, SLang_free_mmt would have + * to be called after every push of the MMT. + */ + return ref; +} + +void SLang_free_mmt (SLang_MMT_Type *ref) +{ + unsigned char type; + SLang_Class_Type *cl; + + if (ref == NULL) + return; + + /* This can be zero if SLang_create_mmt is called followed + * by this routine before anything gets a chance to attach itself + * to it. + */ + if (ref->count > 1) + { + ref->count -= 1; + return; + } + + type = ref->data_type; + cl = _SLclass_get_class (type); + (*cl->cl_user_destroy_fun) (type, ref->user_data); + SLfree ((char *)ref); +} + +int SLang_push_value (unsigned char type, VOID_STAR v) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + return (*cl->cl_apush)(type, v); +} + +int SLang_pop_value (unsigned char type, VOID_STAR v) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + return (*cl->cl_apop)(type, v); +} + +void SLang_free_value (unsigned char type, VOID_STAR v) +{ + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + (*cl->cl_adestroy) (type, v); +} + +/* These routines are very low-level and are designed for application data + * types to access the stack from their push/pop methods. The int and + * pointer versions are in slang.c + */ +#if SLANG_HAS_FLOAT +int SLclass_push_double_obj (unsigned char type, double x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.double_val = x; + return SLang_push (&obj); +} +int SLclass_push_float_obj (unsigned char type, float x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.float_val = x; + return SLang_push (&obj); +} + +#endif + +int SLclass_push_long_obj (unsigned char type, long x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.long_val = x; + return SLang_push (&obj); +} + +int SLclass_push_short_obj (unsigned char type, short x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.short_val = x; + return SLang_push (&obj); +} + +int SLclass_push_char_obj (unsigned char type, char x) +{ + SLang_Object_Type obj; + obj.data_type = type; + obj.v.char_val = x; + return SLang_push (&obj); +} + +#if SLANG_HAS_FLOAT +int SLclass_pop_double_obj (unsigned char type, double *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.double_val; + return 0; +} + +int SLclass_pop_float_obj (unsigned char type, float *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.float_val; + return 0; +} +#endif + +int SLclass_pop_long_obj (unsigned char type, long *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.long_val; + return 0; +} + +int SLclass_pop_int_obj (unsigned char type, int *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.int_val; + return 0; +} + +int SLclass_pop_short_obj (unsigned char type, short *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.short_val; + return 0; +} + +int SLclass_pop_char_obj (unsigned char type, char *x) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + return -1; + + *x = obj.v.char_val; + return 0; +} + +int SLclass_pop_ptr_obj (unsigned char type, VOID_STAR *s) +{ + SLang_Object_Type obj; + + if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) + { + *s = (VOID_STAR) NULL; + return -1; + } + *s = obj.v.ptr_val; + return 0; +} + diff --git a/mdk-stage1/slang/slcmd.c b/mdk-stage1/slang/slcmd.c new file mode 100644 index 000000000..4a00a90fc --- /dev/null +++ b/mdk-stage1/slang/slcmd.c @@ -0,0 +1,351 @@ +/* cmd line facility for slang */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#if SLANG_HAS_FLOAT +# include <math.h> +#endif + +#include "slang.h" +#include "_slang.h" + +#ifndef HAVE_STDLIB_H +/* Oh dear. Where is the prototype for atof? If not in stdlib, then + * I do not know where. Not in math.h onsome systems either. + */ +extern double atof (); +#endif + +static SLcmd_Cmd_Type *SLcmd_find_command (char *s, SLcmd_Cmd_Type *cmd) +{ + char *cmdstr; + char chs = *s++, ch; + + while ((cmd->cmdfun != NULL) + && (NULL != (cmdstr = cmd->cmd)) + && (0 != (ch = *cmdstr++))) + { + if ((ch == chs) && !strcmp (s, cmdstr)) return cmd; + cmd++; + } + return NULL; +} + +static int extract_token (char **strptr, char *buf) +{ + char *s, *b; + char ch, quote; + + *buf = 0; + + s = *strptr; + while (((ch = *s) != 0) + && ((ch == ' ') || (ch == '\t') || (ch == '\n'))) + s++; + + *strptr = s; + + if (ch == 0) return 0; + if (ch == '%') return 0; + + b = buf; + + *b++ = ch; + s++; + + if ((ch == '\'') || (ch == '"')) + { + quote = ch; + while ((ch = *s) != 0) + { + s++; + *b++ = ch; + if (ch == quote) + break; + + if (ch == '\\') + { + if (0 == (ch = *s)) + break; + *b++ = ch; + s++; + } + } + *strptr = s; + *b = 0; + return 1; + } + + while (((ch = *s) != 0) + && (ch != ' ') + && (ch != '\t') + && (ch != '\n') + && (ch != '%')) + *b++ = *s++; + + *strptr = s; + *b = 0; + return 1; +} + +static int allocate_arg_space (SLcmd_Cmd_Table_Type *table, int argc, unsigned int *space_ptr) +{ + unsigned int space = *space_ptr; + char *p; + + if (argc + 1 < (int) space) + return 0; + + if (space > 128) + { + if (space > 1024) space += 1024; + else space += 128; + } + else space += 32; + + if (NULL == (p = SLrealloc ((char *)table->string_args, space * sizeof (char *)))) + return -1; + table->string_args = (char **)p; + table->string_args [argc] = NULL; + + if (NULL == (p = SLrealloc ((char *)table->int_args, space * sizeof (int)))) + return -1; + table->int_args = (int *)p; + + if (NULL == (p = SLrealloc ((char *)table->double_args, space * sizeof (double)))) + return -1; + table->double_args = (double *)p; + + if (NULL == (p = SLrealloc ((char *)table->arg_type, space * sizeof (unsigned char)))) + return -1; + table->arg_type = (unsigned char *)p; + + *space_ptr = space; + return 0; +} + +int SLcmd_execute_string (char *str, SLcmd_Cmd_Table_Type *table) +{ + char *s, *b = NULL, *arg_type, *last_str, *cmd_name; + SLcmd_Cmd_Type *cmd; + char *buf; + int token_present; + int i; + int status; + unsigned int len; + int argc; + unsigned int space; + + table->argc = 0; + table->string_args = NULL; + table->int_args = NULL; + table->double_args = NULL; + table->arg_type = NULL; + + buf = SLmake_string (str); + if (buf == NULL) + return -1; + + status = extract_token (&str, buf); + if (status <= 0) + { + SLfree (buf); + return status; + } + + if (((len = strlen (buf)) >= 32) + || (NULL == (cmd = SLcmd_find_command (buf, table->table)))) + { + SLang_verror (SL_UNDEFINED_NAME,"%s: invalid command", buf); + SLfree (buf); + return -1; + } + + if (NULL == (cmd_name = SLmake_string (buf))) + { + SLfree (buf); + return -1; + } + + space = 0; + argc = 0; + if (-1 == allocate_arg_space (table, argc, &space)) + { + SLfree (buf); + return -1; + } + table->arg_type[argc] = SLANG_STRING_TYPE; + table->string_args[argc++] = cmd_name; + + arg_type = cmd->arg_type; + status = -1; + while (*arg_type) + { + int guess_type = 0; + + last_str = str; + + if (-1 == allocate_arg_space (table, argc, &space)) + goto error; + + if (-1 == (token_present = extract_token (&str, buf))) + goto error; + + table->string_args[argc] = NULL; + + if (token_present) + { + b = buf; + len = strlen (b); + + if ((*b == '"') && (len > 1)) + { + b++; + len -= 2; + b[len] = 0; + guess_type = SLANG_STRING_TYPE; + SLexpand_escaped_string (buf, b, b + len); + len = strlen (buf); + } + else if ((*b == '\'') && (len > 1)) + { + char ch; + b++; + len -= 2; + b[len] = 0; + guess_type = SLANG_INT_TYPE; + ch = *b; + if (ch == '\\') + (void) _SLexpand_escaped_char (b, &ch); + sprintf (buf, "%d", (unsigned char) ch); + len = strlen (buf); + } + else guess_type = SLang_guess_type (buf); + } + + switch (*arg_type++) + { + /* variable argument number */ + case 'v': + if (token_present == 0) break; + case 'V': + if (token_present == 0) + { + SLang_verror (SL_INVALID_PARM, "%s: Expecting argument", cmd_name); + goto error; + } + + while (*last_str == ' ') last_str++; + len = strlen (last_str); + str = last_str + len; + + s = SLmake_nstring (last_str, len); + if (s == NULL) goto error; + + table->arg_type[argc] = SLANG_STRING_TYPE; + table->string_args[argc++] = s; + break; + + case 's': + if (token_present == 0) break; + case 'S': + if (token_present == 0) + { + SLang_verror (SL_TYPE_MISMATCH, "%s: Expecting string argument", cmd_name); + goto error; + } + + s = SLmake_nstring (buf, len); + if (s == NULL) goto error; + table->arg_type[argc] = SLANG_STRING_TYPE; + table->string_args[argc++] = s; + break; + + /* integer argument */ + case 'i': + if (token_present == 0) break; + case 'I': + if ((token_present == 0) || (SLANG_INT_TYPE != guess_type)) + { + SLang_verror (SL_TYPE_MISMATCH, "%s: Expecting integer argument", cmd_name); + goto error; + } + + table->arg_type[argc] = SLANG_INT_TYPE; + table->int_args[argc++] = SLatoi((unsigned char *) buf); + break; + + /* floating point arg */ +#if SLANG_HAS_FLOAT + case 'f': + if (token_present == 0) break; + case 'F': + if ((token_present == 0) || (SLANG_STRING_TYPE == guess_type)) + { + SLang_verror (SL_TYPE_MISMATCH, "%s: Expecting double argument", cmd_name); + goto error; + } + table->arg_type[argc] = SLANG_DOUBLE_TYPE; + table->double_args[argc++] = atof(buf); + break; +#endif + /* Generic type */ + case 'g': + if (token_present == 0) break; + case 'G': + if (token_present == 0) + { + SLang_verror (SL_TYPE_MISMATCH, "%s: Expecting argument", cmd_name); + goto error; + } + + switch (guess_type) + { + case SLANG_INT_TYPE: + table->arg_type[argc] = SLANG_INT_TYPE; + table->int_args[argc++] = SLatoi((unsigned char *) buf); + break; + + case SLANG_STRING_TYPE: + s = SLmake_nstring (buf, len); + if (s == NULL) goto error; + + table->arg_type[argc] = SLANG_STRING_TYPE; + table->string_args[argc++] = s; + break; +#if SLANG_HAS_FLOAT + case SLANG_DOUBLE_TYPE: + table->arg_type[argc] = SLANG_DOUBLE_TYPE; + table->double_args[argc++] = atof(buf); +#endif + } + break; + } + } + + /* call function */ + status = (*cmd->cmdfun)(argc, table); + + error: + if (table->string_args != NULL) for (i = 0; i < argc; i++) + { + if (NULL != table->string_args[i]) + { + SLfree (table->string_args[i]); + table->string_args[i] = NULL; + } + } + SLfree ((char *)table->string_args); table->string_args = NULL; + SLfree ((char *)table->double_args); table->double_args = NULL; + SLfree ((char *)table->int_args); table->int_args = NULL; + SLfree ((char *)table->arg_type); table->arg_type = NULL; + + SLfree (buf); + return status; +} + diff --git a/mdk-stage1/slang/slcmplex.c b/mdk-stage1/slang/slcmplex.c new file mode 100644 index 000000000..b210dfc04 --- /dev/null +++ b/mdk-stage1/slang/slcmplex.c @@ -0,0 +1,1142 @@ +/* Complex Data Type definition for S-Lang */ +/* Copyright (c) 1997, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* The rest of the file is enclosed in this #if */ +#if SLANG_HAS_COMPLEX + +#if SLANG_HAS_FLOAT +# include <math.h> +#endif + +#ifdef PI +# undef PI +#endif +#define PI 3.14159265358979323846 + +int SLang_pop_complex (double *r, double *i) +{ + double *c; + + switch (SLang_peek_at_stack ()) + { + case SLANG_COMPLEX_TYPE: + if (-1 == SLclass_pop_ptr_obj (SLANG_COMPLEX_TYPE, (VOID_STAR *)&c)) + return -1; + *r = c[0]; + *i = c[1]; + SLfree ((char *) c); + break; + + default: + *i = 0.0; + if (-1 == SLang_pop_double (r, NULL, NULL)) + return -1; + break; + + case -1: + return -1; + } + return 0; +} + +int SLang_push_complex (double r, double i) +{ + double *c; + + c = (double *) SLmalloc (2 * sizeof (double)); + if (c == NULL) + return -1; + + c[0] = r; + c[1] = i; + + if (-1 == SLclass_push_ptr_obj (SLANG_COMPLEX_TYPE, (VOID_STAR) c)) + { + SLfree ((char *) c); + return -1; + } + return 0; +} + +double *SLcomplex_times (double *c, double *a, double *b) +{ + double a_real, b_real, a_imag, b_imag; + + a_real = a[0]; + b_real = b[0]; + a_imag = a[1]; + b_imag = b[1]; + + c[0] = a_real * b_real - a_imag * b_imag; + c[1] = a_imag * b_real + a_real * b_imag; + + return c; +} + +double *SLcomplex_divide (double *c, double *a, double *b) +{ + double a_real, b_real, a_imag, b_imag; + double ratio, invden; + + a_real = a[0]; + b_real = b[0]; + a_imag = a[1]; + b_imag = b[1]; + + /* Do it this way to avoid overflow in the denom */ + if (fabs(b_real) > fabs(b_imag)) + { + ratio = b_imag / b_real; + invden = 1.0 / (b_real + b_imag * ratio); + c[0] = (a_real + ratio * a_imag) * invden; + c[1] = (a_imag - a_real * ratio) * invden; + } + else + { + ratio = b_real / b_imag; + invden = 1.0 / (b_real * ratio + b_imag); + c[0] = (a_real * ratio + a_imag) * invden; + c[1] = (a_imag * ratio - a_real) * invden; + } + return c; +} + +/* a^b = exp (b log a); */ +double *SLcomplex_pow (double *c, double *a, double *b) +{ + return SLcomplex_exp (c, SLcomplex_times (c, b, SLcomplex_log (c, a))); +} + +static double *complex_dpow (double *c, double *a, double b) +{ + SLcomplex_log (c, a); + c[0] *= b; + c[1] *= b; + return SLcomplex_exp (c, c); +} + +static double *dcomplex_pow (double *c, double a, double *b) +{ + a = log (a); + c[0] = a * b[0]; + c[1] = a * b[1]; + return SLcomplex_exp (c, c); +} + +double SLcomplex_abs (double *z) +{ + return SLmath_hypot (z[0], z[1]); +} + +/* It appears that FORTRAN assumes that the branch cut for the log function + * is along the -x axis. So, use this for atan2: + */ +static double my_atan2 (double y, double x) +{ + double val; + + val = atan (y/x); + + if (x >= 0) + return val; /* I, IV */ + + if (y <= 0) /* III */ + return val - PI; + + return PI + val; /* II */ +} + +static void polar_form (double *r, double *theta, double *z) +{ + double x, y; + + *r = SLcomplex_abs (z); + + x = z[0]; + y = z[1]; + + if (x == 0.0) + { + if (y >= 0) + *theta = 0.5 * PI; + else + *theta = 1.5 * PI; + } + else *theta = my_atan2 (y, x); +} + +double *SLcomplex_sin (double *sinz, double *z) +{ + double x, y; + + x = z[0]; y = z[1]; + sinz[0] = sin (x) * cosh (y); + sinz[1] = cos (x) * sinh (y); + return sinz; +} + +double *SLcomplex_cos (double *cosz, double *z) +{ + double x, y; + + x = z[0]; y = z[1]; + cosz[0] = cos (x) * cosh (y); + cosz[1] = -sin (x) * sinh (y); + return cosz; +} + +double *SLcomplex_exp (double *expz, double *z) +{ + double r, i; + + r = exp (z[0]); + i = z[1]; + expz[0] = r * cos (i); + expz[1] = r * sin (i); + return expz; +} + +double *SLcomplex_log (double *logz, double *z) +{ + double r, theta; + + polar_form (&r, &theta, z); /* log R.e^(ix) = log R + ix */ + logz[0] = log(r); + logz[1] = theta; + return logz; +} + +double *SLcomplex_log10 (double *log10z, double *z) +{ + double l10 = log (10.0); + (void) SLcomplex_log (log10z, z); + log10z[0] = log10z[0] / l10; + log10z[1] = log10z[1] / l10; + return log10z; +} + +double *SLcomplex_sqrt (double *sqrtz, double *z) +{ + double r, x, y; + + x = z[0]; + y = z[1]; + + r = SLmath_hypot (x, y); + + if (r == 0.0) + { + sqrtz [0] = sqrtz [1] = 0.0; + return sqrtz; + } + + if (x >= 0.0) + { + x = sqrt (0.5 * (r + x)); + y = 0.5 * y / x; + } + else + { + r = sqrt (0.5 * (r - x)); + x = 0.5 * y / r; + y = r; + + if (x < 0.0) + { + x = -x; + y = -y; + } + } + + sqrtz[0] = x; + sqrtz[1] = y; + + return sqrtz; +} + +double *SLcomplex_tan (double *tanz, double *z) +{ + double x, y, invden; + + x = 2 * z[0]; + y = 2 * z[1]; + invden = 1.0 / (cos (x) + cosh (y)); + tanz[0] = invden * sin (x); + tanz[1] = invden * sinh (y); + return tanz; +} + +/* Utility Function */ +static void compute_alpha_beta (double *z, double *alpha, double *beta) +{ + double x, y, a, b; + + x = z[0]; + y = z[1]; + a = 0.5 * SLmath_hypot (x + 1, y); + b = 0.5 * SLmath_hypot (x - 1, y); + + *alpha = a + b; + *beta = a - b; +} + +double *SLcomplex_asin (double *asinz, double *z) +{ + double alpha, beta; + + compute_alpha_beta (z, &alpha, &beta); + asinz[0] = asin (beta); + asinz[1] = log (alpha + sqrt (alpha * alpha - 1)); + return asinz; +} + +double *SLcomplex_acos (double *acosz, double *z) +{ + double alpha, beta; + + compute_alpha_beta (z, &alpha, &beta); + acosz[0] = acos (beta); + acosz[1] = -log (alpha + sqrt (alpha * alpha - 1)); + return acosz; +} + +double *SLcomplex_atan (double *atanz, double *z) +{ + double x, y; + double z1[2], z2[2]; + + x = z[0]; y = z[1]; + z1[0] = x; + z1[1] = 1 + y; + z2[0] = -x; + z2[1] = 1 - y; + + SLcomplex_log (z1, SLcomplex_divide (z2, z1, z2)); + atanz[0] = -0.5 * z1[1]; + atanz[1] = 0.5 * z1[0]; + + return atanz; +} + +double *SLcomplex_sinh (double *sinhz, double *z) +{ + double x, y; + x = z[0]; y = z[1]; + sinhz[0] = sinh (x) * cos (y); + sinhz[1] = cosh (x) * sin (y); + return sinhz; +} + +double *SLcomplex_cosh (double *coshz, double *z) +{ + double x, y; + x = z[0]; y = z[1]; + coshz[0] = cosh (x) * cos (y); + coshz[1] = sinh (x) * sin (y); + return coshz; +} + +double *SLcomplex_tanh (double *tanhz, double *z) +{ + double x, y, invden; + x = 2 * z[0]; + y = 2 * z[1]; + invden = 1.0 / (cosh (x) + cos (y)); + tanhz[0] = invden * sinh (x); + tanhz[1] = invden * sin (y); + return tanhz; +} +#if 0 +static double *not_implemented (char *fun, double *p) +{ + SLang_verror (SL_NOT_IMPLEMENTED, "%s for complex numbers has not been implemented", + fun); + *p = -1.0; + return p; +} +#endif +/* Use: asinh(z) = -i asin(iz) */ +double *SLcomplex_asinh (double *asinhz, double *z) +{ + double iz[2]; + + iz[0] = -z[1]; + iz[1] = z[0]; + + (void) SLcomplex_asin (iz, iz); + asinhz[0] = iz[1]; + asinhz[1] = -iz[0]; + + return asinhz; +} + +/* Use: acosh (z) = i acos(z) */ +double *SLcomplex_acosh (double *acoshz, double *z) +{ + double iz[2]; + + (void) SLcomplex_acos (iz, z); + acoshz[0] = -iz[1]; + acoshz[1] = iz[0]; + + return acoshz; +} + +/* Use: atanh(z) = -i atan(iz) */ +double *SLcomplex_atanh (double *atanhz, double *z) +{ + double iz[2]; + + iz[0] = -z[1]; + iz[1] = z[0]; + + (void) SLcomplex_atan (iz, iz); + atanhz[0] = iz[1]; + atanhz[1] = -iz[0]; + + return atanhz; +} + +static int complex_binary_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) a; (void) b; + + switch (op) + { + default: + case SLANG_POW: + case SLANG_PLUS: + case SLANG_MINUS: + case SLANG_TIMES: + case SLANG_DIVIDE: + *c = SLANG_COMPLEX_TYPE; + break; + + case SLANG_EQ: + case SLANG_NE: + *c = SLANG_CHAR_TYPE; + break; + } + return 1; +} + +static int complex_complex_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + double *a, *b, *c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + a = (double *) ap; + b = (double *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = 2; + if (nb == 1) db = 0; else db = 2; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] + b[0]; + c[n + 1] = a[1] + b[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] - b[0]; + c[n + 1] = a[1] - b[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + SLcomplex_times (c + n, a, b); + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + if ((b[0] == 0.0) && (b[1] == 0.0)) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + SLcomplex_divide (c + n, a, b); + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] == b[0]) && (a[1] == b[1])); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] != b[0]) || (a[1] != b[1])); + a += da; b += db; + } + break; + + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + SLcomplex_pow (c + n, a, b); + a += da; b += db; + } + break; + + } + + return 1; +} + +static int complex_double_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + double *a, *b, *c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + a = (double *) ap; + b = (double *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = 2; + if (nb == 1) db = 0; else db = 1; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] + b[0]; + c[n + 1] = a[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] - b[0]; + c[n + 1] = a[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + double b0 = b[0]; + c[n] = a[0] * b0; + c[n + 1] = a[1] * b0; + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + double b0 = b[0]; + if (b0 == 0.0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = a[0] / b0; + c[n + 1] = a[1] / b0; + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] == b[0]) && (a[1] == 0.0)); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] != b[0]) || (a[1] != 0.0)); + a += da; b += db; + } + break; + + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + complex_dpow (c + n, a, b[0]); + a += da; b += db; + } + break; + } + + return 1; +} + +static int double_complex_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + double *a, *b, *c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + a = (double *) ap; + b = (double *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = 1; + if (nb == 1) db = 0; else db = 2; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] + b[0]; + c[n + 1] = b[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] - b[0]; + c[n + 1] = -b[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + double a0 = a[0]; + c[n] = a0 * b[0]; + c[n + 1] = a0 * b[1]; + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + double z[2]; + if ((b[0] == 0.0) && (b[1] == 0.0)) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + z[0] = a[0]; + z[1] = 0.0; + SLcomplex_divide (c + n, z, b); + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] == b[0]) && (0.0 == b[1])); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] != b[0]) || (0.0 != b[1])); + a += da; b += db; + } + break; + + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + dcomplex_pow (c + n, a[0], b); + a += da; b += db; + } + break; + } + + return 1; +} + +static int complex_generic_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + char *b; + double *a, *c; + unsigned int n, n_max; + unsigned int da, db; + unsigned int sizeof_b; + SLang_To_Double_Fun_Type to_double; + + if (NULL == (to_double = SLarith_get_to_double_fun (b_type, &sizeof_b))) + return 0; + + (void) a_type; + + a = (double *) ap; + b = (char *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = 2; + if (nb == 1) db = 0; else db = sizeof_b; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + complex_dpow (c + n, a, to_double((VOID_STAR)b)); + a += da; b += db; + } + break; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] + to_double((VOID_STAR)b); + c[n + 1] = a[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = a[0] - to_double((VOID_STAR)b); + c[n + 1] = a[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + double b0 = to_double((VOID_STAR)b); + c[n] = a[0] * b0; + c[n + 1] = a[1] * b0; + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + double b0 = to_double((VOID_STAR)b); + if (b0 == 0) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + c[n] = a[0] / b0; + c[n + 1] = a[1] / b0; + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] == to_double((VOID_STAR)b)) && (a[1] == 0.0)); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((a[0] != to_double((VOID_STAR)b)) || (a[1] != 0.0)); + a += da; b += db; + } + break; + } + + return 1; +} + +static int generic_complex_binary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + double *b, *c; + char *a, *ic; + unsigned int n, n_max; + unsigned int da, db; + unsigned int sizeof_a; + SLang_To_Double_Fun_Type to_double; + + if (NULL == (to_double = SLarith_get_to_double_fun (a_type, &sizeof_a))) + return 0; + + (void) b_type; + + a = (char *) ap; + b = (double *) bp; + c = (double *) cp; + ic = (char *) cp; + + if (na == 1) da = 0; else da = sizeof_a; + if (nb == 1) db = 0; else db = 2; + + if (na > nb) n_max = na; else n_max = nb; + n_max = 2 * n_max; + + switch (op) + { + default: + return 0; + case SLANG_POW: + for (n = 0; n < n_max; n += 2) + { + dcomplex_pow (c + n, to_double((VOID_STAR)a), b); + a += da; b += db; + } + break; + + case SLANG_PLUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = to_double((VOID_STAR)a) + b[0]; + c[n + 1] = b[1]; + a += da; b += db; + } + break; + + case SLANG_MINUS: + for (n = 0; n < n_max; n += 2) + { + c[n] = to_double((VOID_STAR)a) - b[0]; + c[n + 1] = -b[1]; + a += da; b += db; + } + break; + + case SLANG_TIMES: + for (n = 0; n < n_max; n += 2) + { + double a0 = to_double((VOID_STAR)a); + c[n] = a0 * b[0]; + c[n + 1] = a0 * b[1]; + a += da; b += db; + } + break; + + case SLANG_DIVIDE: /* / */ + for (n = 0; n < n_max; n += 2) + { + double z[2]; + if ((b[0] == 0.0) && (b[1] == 0.0)) + { + SLang_Error = SL_DIVIDE_ERROR; + return -1; + } + z[0] = to_double((VOID_STAR)a); + z[1] = 0.0; + SLcomplex_divide (c + n, z, b); + a += da; b += db; + } + break; + + case SLANG_EQ: /* == */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((to_double((VOID_STAR)a) == b[0]) && (0.0 == b[1])); + a += da; b += db; + } + break; + + case SLANG_NE: /* != */ + for (n = 0; n < n_max; n += 2) + { + ic[n/2] = ((to_double((VOID_STAR)a) != b[0]) || (0.0 != b[1])); + a += da; b += db; + } + break; + } + + return 1; +} + +static int complex_unary_result (int op, unsigned char a, unsigned char *b) +{ + (void) a; + + switch (op) + { + default: + return 0; + + case SLANG_PLUSPLUS: + case SLANG_MINUSMINUS: + case SLANG_CHS: + case SLANG_MUL2: + *b = SLANG_COMPLEX_TYPE; + break; + + case SLANG_SQR: /* |Real|^2 + |Imag|^2 ==> double */ + case SLANG_ABS: /* |z| ==> double */ + *b = SLANG_DOUBLE_TYPE; + break; + + case SLANG_SIGN: + *b = SLANG_INT_TYPE; + break; + } + return 1; +} + +static int complex_unary (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + unsigned int n; + double *a, *b; + int *ic; + + (void) a_type; + + a = (double *) ap; + b = (double *) bp; + ic = (int *) bp; + + na = 2 * na; + + switch (op) + { + default: + return 0; + + case SLANG_PLUSPLUS: + for (n = 0; n < na; n += 2) b[n] = (a[n] + 1); + break; + case SLANG_MINUSMINUS: + for (n = 0; n < na; n += 2) b[n] = (a[n] - 1); + break; + case SLANG_CHS: + for (n = 0; n < na; n += 2) + { + b[n] = -(a[n]); + b[n + 1] = -(a[n + 1]); + } + break; + case SLANG_SQR: /* |Real|^2 + |Imag|^2 ==> double */ + for (n = 0; n < na; n += 2) + b[n/2] = (a[n] * a[n] + a[n + 1] * a[n + 1]); + break; + + case SLANG_MUL2: + for (n = 0; n < na; n += 2) + { + b[n] = (2 * a[n]); + b[n + 1] = (2 * a[n + 1]); + } + break; + + case SLANG_ABS: /* |z| ==> double */ + for (n = 0; n < na; n += 2) + b[n/2] = SLcomplex_abs (a + n); + break; + + case SLANG_SIGN: + /* Another creative extension. Lets return an integer which indicates + * whether the complex number is in the upperhalf plane or not. + */ + for (n = 0; n < na; n += 2) + { + if (a[n + 1] < 0.0) ic[n/2] = -1; + else if (a[n + 1] > 0.0) ic[n/2] = 1; + else ic[n/2] = 0; + } + break; + } + + return 1; +} + +static int +complex_typecast (unsigned char from_type, VOID_STAR from, unsigned int num, + unsigned char to_type, VOID_STAR to) +{ + double *z; + double *d; + char *i; + unsigned int n; + unsigned int sizeof_i; + SLang_To_Double_Fun_Type to_double; + + (void) to_type; + + z = (double *) to; + + switch (from_type) + { + default: + if (NULL == (to_double = SLarith_get_to_double_fun (from_type, &sizeof_i))) + return 0; + i = (char *) from; + for (n = 0; n < num; n++) + { + *z++ = to_double ((VOID_STAR) i); + *z++ = 0.0; + + i += sizeof_i; + } + break; + + case SLANG_DOUBLE_TYPE: + d = (double *) from; + for (n = 0; n < num; n++) + { + *z++ = d[n]; + *z++ = 0.0; + } + break; + } + + return 1; +} + +static void complex_destroy (unsigned char type, VOID_STAR ptr) +{ + (void) type; + SLfree ((char *)*(double **) ptr); +} + +static int complex_push (unsigned char type, VOID_STAR ptr) +{ + double *z; + + (void) type; + z = *(double **) ptr; + return SLang_push_complex (z[0], z[1]); +} + +static int complex_pop (unsigned char type, VOID_STAR ptr) +{ + double *z; + + (void) type; + z = *(double **) ptr; + return SLang_pop_complex (&z[0], &z[1]); +} + +int _SLinit_slcomplex (void) +{ + SLang_Class_Type *cl; + unsigned char *types; + + if (NULL == (cl = SLclass_allocate_class ("Complex_Type"))) + return -1; + + (void) SLclass_set_destroy_function (cl, complex_destroy); + (void) SLclass_set_push_function (cl, complex_push); + (void) SLclass_set_pop_function (cl, complex_pop); + + if (-1 == SLclass_register_class (cl, SLANG_COMPLEX_TYPE, 2 * sizeof (double), + SLANG_CLASS_TYPE_VECTOR)) + return -1; + + types = _SLarith_Arith_Types; + while (*types != SLANG_DOUBLE_TYPE) + { + unsigned char t = *types++; + + if ((-1 == SLclass_add_binary_op (t, SLANG_COMPLEX_TYPE, generic_complex_binary, complex_binary_result)) + || (-1 == SLclass_add_binary_op (SLANG_COMPLEX_TYPE, t, complex_generic_binary, complex_binary_result)) + || (-1 == (SLclass_add_typecast (t, SLANG_COMPLEX_TYPE, complex_typecast, 1)))) + return -1; + } + + if ((-1 == (SLclass_add_binary_op (SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, complex_complex_binary, complex_binary_result))) + || (-1 == (SLclass_add_binary_op (SLANG_COMPLEX_TYPE, SLANG_DOUBLE_TYPE, complex_double_binary, complex_binary_result))) + || (-1 == (SLclass_add_binary_op (SLANG_DOUBLE_TYPE, SLANG_COMPLEX_TYPE, double_complex_binary, complex_binary_result))) + || (-1 == (SLclass_add_unary_op (SLANG_COMPLEX_TYPE, complex_unary, complex_unary_result))) + || (-1 == (SLclass_add_typecast (SLANG_DOUBLE_TYPE, SLANG_COMPLEX_TYPE, complex_typecast, 1)))) + return -1; + + return 0; +} + +#endif /* if SLANG_HAS_COMPLEX */ + diff --git a/mdk-stage1/slang/slcompat.c b/mdk-stage1/slang/slcompat.c new file mode 100644 index 000000000..5aa122483 --- /dev/null +++ b/mdk-stage1/slang/slcompat.c @@ -0,0 +1,34 @@ +/* These functions are provided for backward compatibility and are obsolete. + * Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* Compatibility */ +int SLang_init_slunix (void) +{ + if ((-1 == SLang_init_posix_dir ()) + || (-1 == SLang_init_posix_process ()) + || (-1 == SLdefine_for_ifdef ("__SLUNIX__"))) + return -1; + + return 0; +} + +int SLang_init_slfile (void) +{ + if ((-1 == SLang_init_stdio ()) + || (-1 == SLang_init_posix_dir ()) + || (-1 == SLdefine_for_ifdef("__SLFILE__"))) + return -1; + + return 0; +} + diff --git a/mdk-stage1/slang/slcurses.c b/mdk-stage1/slang/slcurses.c new file mode 100644 index 000000000..f1212afc8 --- /dev/null +++ b/mdk-stage1/slang/slcurses.c @@ -0,0 +1,972 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include <signal.h> +#include <errno.h> + +#include "slang.h" +#include "_slang.h" +#include "slcurses.h" + +/* This file is meant to implement a primitive curses implementation in + * terms of SLsmg calls. The fact is that the interfaces are sufficiently + * different that a 100% emulation is not possible. + */ + +SLcurses_Window_Type *SLcurses_Stdscr; +int SLcurses_Esc_Delay = 150; /* 0.15 seconds */ +SLtt_Char_Type SLcurses_Acs_Map [128]; +int SLcurses_Is_Endwin = 1; +int SLcurses_Num_Colors = 8; + +static void blank_line (SLsmg_Char_Type *b, unsigned int len, SLsmg_Char_Type color) +{ + SLsmg_Char_Type *bmax; + + bmax = b + len; + color = SLSMG_BUILD_CHAR(' ', color); + + while (b < bmax) *b++ = color; +} + +static int va_mvprintw (SLcurses_Window_Type *w, int r, int c, int do_move, + char *fmt, va_list ap) +{ + char buf[1024]; + + if (do_move) SLcurses_wmove (w, r, c); + + (void) _SLvsnprintf (buf, sizeof(buf), fmt, ap); + + SLcurses_waddnstr (w, buf, -1); + return 0; +} + +int SLcurses_mvprintw (int r, int c, char *fmt, ...) +{ + va_list ap; + + va_start(ap, fmt); + va_mvprintw (SLcurses_Stdscr, r, c, 1, fmt, ap); + va_end(ap); + + return 0; +} + +int SLcurses_mvwprintw (SLcurses_Window_Type *w, int r, int c, char *fmt, ...) +{ + va_list ap; + + va_start(ap, fmt); + va_mvprintw (w, r, c, 1, fmt, ap); + va_end(ap); + + return 0; +} + +int SLcurses_wprintw (SLcurses_Window_Type *w, char *fmt, ...) +{ + va_list ap; + + va_start(ap, fmt); + va_mvprintw (w, 0, 0, 0, fmt, ap); + va_end(ap); + + return 0; +} + +int SLcurses_printw (char *fmt, ...) +{ + va_list ap; + + va_start(ap, fmt); + va_mvprintw (SLcurses_Stdscr, 0, 0, 0, fmt, ap); + va_end(ap); + + return 0; +} + +int SLcurses_nil (void) +{ + return 0; +} + +int SLcurses_has_colors(void) +{ + return SLtt_Use_Ansi_Colors; +} + +int SLcurses_nodelay (SLcurses_Window_Type *w, int onoff) +{ + w->delay_off = (onoff ? 0 : -1); + return 0; +} + +int SLcurses_wgetch (SLcurses_Window_Type *w) +{ + if (w == NULL) + return ERR; + + SLcurses_wrefresh (w); + + if ((w->delay_off == -1) || + SLang_input_pending (w->delay_off)) + { + if (w->use_keypad) + { + int ch = SLang_getkey (); + if (ch == '\033') + { + if (0 == SLang_input_pending (ESCDELAY / 100)) + return ch; + } + else if (ch == 0xFFFF) return ERR; + SLang_ungetkey (ch); + return SLkp_getkey (); + } + return SLang_getkey (); + } + + return ERR; +} + +int SLcurses_getch (void) +{ + return SLcurses_wgetch (SLcurses_Stdscr); +} + +/* This is a super hack. That fact is that SLsmg and curses + * are incompatible. + */ +static unsigned char Color_Objects[256]; + +static unsigned int map_attr_to_object (SLtt_Char_Type attr) +{ + unsigned int obj; + SLtt_Char_Type at; + + obj = (attr >> 8) & 0xFF; + + if (SLtt_Use_Ansi_Colors) + { + if (Color_Objects[obj] != 0) return obj; + + at = SLtt_get_color_object (obj & 0xF); + + if (attr & A_BOLD) at |= SLTT_BOLD_MASK; + if (attr & A_UNDERLINE) at |= SLTT_ULINE_MASK; + if (attr & A_REVERSE) at |= SLTT_REV_MASK; + + SLtt_set_color_object (obj, at); + + Color_Objects[obj] = 1; + } + else obj = obj & 0xF0; + + return obj; + +} + +int SLcurses_start_color (void) +{ + int f, b; + int obj; + + if (SLtt_Use_Ansi_Colors == 0) return -1; + + obj = 0; + for (f = 0; f < 16; f++) + { + for (b = 0; b < 16; b++) + { + obj++; + SLtt_set_color_fgbg (obj, f, b); + } + } + return 0; +} + +#ifdef SIGINT +static void sigint_handler (int sig) +{ + SLang_reset_tty (); + SLsmg_reset_smg (); + exit (sig); +} +#endif + +/* Values are assumed to be 0, 1, 2. This fact is exploited */ +static int TTY_State; + +static int init_tty (int suspend_ok) +{ + if (-1 == SLang_init_tty (-1, 1, 0)) + return -1; + +#ifdef REAL_UNIX_SYSTEM + if (suspend_ok) SLtty_set_suspend_state (1); +#endif + return 0; +} + +int SLcurses_raw (void) +{ + TTY_State = 1; + return init_tty (0); +} + +int SLcurses_cbreak (void) +{ + TTY_State = 2; + return init_tty (1); +} + +#if defined(SIGTSTP) && defined(SIGSTOP) +static void sigtstp_handler (int sig) +{ + sig = errno; + + SLsmg_suspend_smg (); + + if (TTY_State) + SLang_reset_tty (); + + kill(getpid(),SIGSTOP); + + SLsmg_resume_smg (); + + if (TTY_State) init_tty (TTY_State - 1); + + signal (SIGTSTP, sigtstp_handler); + errno = sig; +} +#endif + +SLcurses_Window_Type *SLcurses_initscr (void) +{ + SLcurses_Is_Endwin = 0; + SLsmg_Newline_Behavior = SLSMG_NEWLINE_MOVES; + SLtt_get_terminfo (); + +#if !defined(IBMPC_SYSTEM) && !defined(VMS) + if (-1 == (SLcurses_Num_Colors = SLtt_tgetnum ("Co"))) +#endif + SLcurses_Num_Colors = 8; + + if ((-1 == SLkp_init ()) + || (-1 == SLcurses_cbreak ()) + || (NULL == (SLcurses_Stdscr = SLcurses_newwin (0, 0, 0, 0))) + || (-1 == SLsmg_init_smg ())) + { + SLang_doerror (NULL); + SLang_exit_error ("SLcurses_initscr: init failed\n"); + return NULL; + } + +#ifdef SIGINT + signal (SIGINT, sigint_handler); +#endif + +#if defined(SIGTSTP) && defined(SIGSTOP) + signal (SIGTSTP, sigtstp_handler); +#endif + + SLtt_set_mono (A_BOLD >> 8, NULL, SLTT_BOLD_MASK); + SLtt_set_mono (A_UNDERLINE >> 8, NULL, SLTT_ULINE_MASK); + SLtt_set_mono (A_REVERSE >> 8, NULL, SLTT_REV_MASK); + /* SLtt_set_mono (A_BLINK >> 8, NULL, SLTT_BLINK_MASK); */ + SLtt_set_mono ((A_BOLD|A_UNDERLINE) >> 8, NULL, SLTT_ULINE_MASK|SLTT_BOLD_MASK); + SLtt_set_mono ((A_REVERSE|A_UNDERLINE) >> 8, NULL, SLTT_ULINE_MASK|SLTT_REV_MASK); + + if (SLtt_Has_Alt_Charset) + { + SLcurses_Acs_Map[SLSMG_ULCORN_CHAR] = SLSMG_ULCORN_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_URCORN_CHAR] = SLSMG_URCORN_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_LLCORN_CHAR] = SLSMG_LLCORN_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_LRCORN_CHAR] = SLSMG_LRCORN_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_UTEE_CHAR] = SLSMG_UTEE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_DTEE_CHAR] = SLSMG_DTEE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_LTEE_CHAR] = SLSMG_LTEE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_RTEE_CHAR] = SLSMG_RTEE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_VLINE_CHAR] = SLSMG_VLINE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_HLINE_CHAR] = SLSMG_HLINE_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_PLUS_CHAR] = SLSMG_PLUS_CHAR | A_ALTCHARSET; + SLcurses_Acs_Map[SLSMG_CKBRD_CHAR] = SLSMG_CKBRD_CHAR | A_ALTCHARSET; + } + else + { + /* ugly defaults to use on terminals which don't support graphics */ + SLcurses_Acs_Map[SLSMG_ULCORN_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_URCORN_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_LLCORN_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_LRCORN_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_UTEE_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_DTEE_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_LTEE_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_RTEE_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_VLINE_CHAR] = '|'; + SLcurses_Acs_Map[SLSMG_HLINE_CHAR] = '-'; + SLcurses_Acs_Map[SLSMG_PLUS_CHAR] = '+'; + SLcurses_Acs_Map[SLSMG_CKBRD_CHAR] = '#'; + } + + return SLcurses_Stdscr; +} + +int SLcurses_wattrset (SLcurses_Window_Type *w, SLtt_Char_Type ch) +{ + unsigned int obj; + + obj = map_attr_to_object (ch); + w->color = obj; + w->attr = ch; + return 0; +} + +int SLcurses_wattroff (SLcurses_Window_Type *w, SLtt_Char_Type ch) +{ + if (SLtt_Use_Ansi_Colors) + return SLcurses_wattrset (w, 0); + + w->attr &= ~ch; + return SLcurses_wattrset (w, w->attr); +} + +int SLcurses_wattron (SLcurses_Window_Type *w, SLtt_Char_Type ch) +{ + if (SLtt_Use_Ansi_Colors) + return SLcurses_wattrset (w, ch); + + w->attr |= ch; + return SLcurses_wattrset (w, w->attr); +} + +int SLcurses_delwin (SLcurses_Window_Type *w) +{ + if (w == NULL) return 0; + if (w->lines != NULL) + { + SLsmg_Char_Type **lines = w->lines; + if (w->is_subwin == 0) + { + unsigned int r, rmax; + + rmax = w->nrows; + for (r = 0; r < rmax; r++) + { + SLfree ((char *)lines[r]); + } + } + + SLfree ((char *)lines); + } + + SLfree ((char *)w); + if (w == SLcurses_Stdscr) + SLcurses_Stdscr = NULL; + return 0; +} + +SLcurses_Window_Type *SLcurses_newwin (unsigned int nrows, unsigned int ncols, + unsigned int r, unsigned int c) +{ + SLcurses_Window_Type *win; + SLsmg_Char_Type **lines; + + if (r >= (unsigned int) SLtt_Screen_Rows) + return NULL; + if (c >= (unsigned int) SLtt_Screen_Cols) + return NULL; + + if (NULL == (win = (SLcurses_Window_Type *) SLmalloc (sizeof (SLcurses_Window_Type)))) + return NULL; + + SLMEMSET ((char *) win, 0, sizeof (SLcurses_Window_Type)); + + if (nrows == 0) + nrows = (unsigned int) SLtt_Screen_Rows - r; + if (ncols == 0) + ncols = (unsigned int) SLtt_Screen_Cols - c; + + lines = (SLsmg_Char_Type **) SLmalloc (nrows * sizeof (SLsmg_Char_Type *)); + if (lines == NULL) + { + SLcurses_delwin (win); + return NULL; + } + + SLMEMSET ((char *) lines, 0, nrows * sizeof (SLsmg_Char_Type *)); + + win->lines = lines; + win->scroll_max = win->nrows = nrows; + win->ncols = ncols; + win->_begy = r; + win->_begx = c; + win->_maxx = (c + ncols) - 1; + win->_maxy = (r + nrows) - 1; + win->modified = 1; + win->delay_off = -1; + + for (r = 0; r < nrows; r++) + { + SLsmg_Char_Type *b; + + b = (SLsmg_Char_Type *) SLmalloc (ncols * sizeof (SLsmg_Char_Type)); + if (b == NULL) + { + SLcurses_delwin (win); + return NULL; + } + lines [r] = b; + blank_line (b, ncols, 0); + } + + return win; +} + +int SLcurses_wmove (SLcurses_Window_Type *win, unsigned int r, unsigned int c) +{ + if (win == NULL) return -1; + win->_cury = r; + win->_curx = c; + win->modified = 1; + return 0; +} + +static int do_newline (SLcurses_Window_Type *w) +{ + w->_curx = 0; + w->_cury += 1; + if (w->_cury >= w->scroll_max) + { + w->_cury = w->scroll_max - 1; + if (w->scroll_ok) + SLcurses_wscrl (w, 1); + } + + return 0; +} + +int SLcurses_waddch (SLcurses_Window_Type *win, SLtt_Char_Type attr) +{ + SLsmg_Char_Type *b, ch; + SLsmg_Char_Type color; + + if (win == NULL) return -1; + + if (win->_cury >= win->nrows) + { + /* Curses seems to move current postion to top of window. */ + win->_cury = win->_curx = 0; + return -1; + } + + win->modified = 1; + + ch = SLSMG_EXTRACT_CHAR(attr); + + if (attr == ch) + color = win->color; + else + { + /* hack to pick up the default color for graphics chars */ + if (((attr & A_COLOR) == 0) && ((attr & A_ALTCHARSET) != 0)) + { + /* FIXME: priority=medium: Use SLSMG_?? instead of << */ + attr |= win->color << 8; + } + color = map_attr_to_object (attr); + } + + if (ch < ' ') + { + if (ch == '\n') + { + SLcurses_wclrtoeol (win); + return do_newline (win); + } + + if (ch == '\r') + { + win->_curx = 0; + return 0; + } + + if (ch == '\b') + { + if (win->_curx > 0) + win->_curx--; + + return 0; + } + + /* HACK HACK!!!! */ + if (ch == '\t') ch = ' '; + } + + if (win->_curx >= win->ncols) + do_newline (win); + + b = win->lines[win->_cury] + win->_curx; + *b = SLSMG_BUILD_CHAR(ch,color); + win->_curx++; + + return 0; +} + +int SLcurses_wnoutrefresh (SLcurses_Window_Type *w) +{ + unsigned int len; + unsigned int r, c; + unsigned int i, imax; + + if (SLcurses_Is_Endwin) + { + if (TTY_State) init_tty (TTY_State - 1); + SLsmg_resume_smg (); + SLcurses_Is_Endwin = 0; + } + + if (w == NULL) + { + SLsmg_refresh (); + return -1; + } + + if (w->modified == 0) + return 0; + + r = w->_begy; + c = w->_begx; + + len = w->ncols; + imax = w->nrows; + + for (i = 0; i < imax; i++) + { + SLsmg_gotorc (r, c); + SLsmg_write_color_chars (w->lines[i], len); + r++; + } + + if (w->has_box) + SLsmg_draw_box(w->_begy, w->_begx, w->nrows, w->ncols); + + SLsmg_gotorc (w->_begy + w->_cury, w->_begx + w->_curx); + w->modified = 0; + return 0; +} + +int SLcurses_wrefresh (SLcurses_Window_Type *w) +{ + if (w == NULL) + return -1; + + if (w->modified == 0) + return 0; + + SLcurses_wnoutrefresh (w); + SLsmg_refresh (); + return 0; +} + +int SLcurses_wclrtoeol (SLcurses_Window_Type *w) +{ + SLsmg_Char_Type *b, *bmax; + SLsmg_Char_Type blank; + + if (w == NULL) return -1; + if (w->_cury >= w->nrows) + return 0; + + w->modified = 1; + + blank = SLSMG_BUILD_CHAR(' ',w->color); + + b = w->lines[w->_cury]; + bmax = b + w->ncols; + b += w->_curx; + + while (b < bmax) *b++ = blank; + return 0; +} + +int SLcurses_wclrtobot (SLcurses_Window_Type *w) +{ + SLsmg_Char_Type *b, *bmax; + SLsmg_Char_Type blank; + unsigned int r; + + if (w == NULL) return -1; + + w->modified = 1; + blank = SLSMG_BUILD_CHAR(' ',w->color); + SLcurses_wclrtoeol (w); + for (r = w->_cury + 1; r < w->nrows; r++) + { + b = w->lines [r]; + bmax = b + w->ncols; + + while (b < bmax) *b++ = blank; + } + + return 0; +} + +int SLcurses_wscrl (SLcurses_Window_Type *w, int n) +{ + SLsmg_Char_Type **lines; + unsigned int r, rmax, rmin, ncols; + SLsmg_Char_Type color; + + if ((w == NULL) || (w->scroll_ok == 0)) + return -1; + + w->modified = 1; +#if 0 + if (w->is_subwin) + { + SLang_reset_tty (); + SLsmg_reset_smg (); + fprintf (stderr, "\rAttempt to scroll a subwindow\n"); + exit (1); + } +#endif + + color = w->color; + ncols = w->ncols; + lines = w->lines; + rmax = w->scroll_max; + rmin = w->scroll_min; + if (rmax > w->nrows) + rmax = w->nrows; + if (rmin >= rmax) + return 0; + + while (n > 0) + { + for (r = rmin + 1; r < rmax; r++) + { + /* lines[r - 1] = lines[r]; */ + memcpy ((char *)lines[r - 1], (char *)lines[r], + sizeof (SLsmg_Char_Type) * ncols); + } + blank_line (lines[rmax - 1], ncols, color); + n--; + } + + rmax--; + while (n < 0) + { + for (r = rmax; r > rmin; r--) + { + memcpy ((char *)lines[r], (char *)lines[r - 1], + sizeof (SLsmg_Char_Type) * ncols); + } + blank_line (lines[rmin], ncols, color); + n++; + } + + /* wmove (w, w->nrows - 1, 0); */ + /* wclrtobot (w); */ + return 0; +} + +/* Note: if len is < 0, entire string will be used. + */ +int SLcurses_waddnstr (SLcurses_Window_Type *w, char *str, int len) +{ + SLsmg_Char_Type *b; + SLsmg_Char_Type color; + unsigned char ch; + unsigned int nrows, ncols, crow, ccol; + + if ((w == NULL) + || (str == NULL)) + return -1; + + w->modified = 1; + nrows = w->nrows; + ncols = w->ncols; + crow = w->_cury; + ccol = w->_curx; + color = w->color; + + if (w->scroll_max <= nrows) + nrows = w->scroll_max; + + if (crow >= nrows) + crow = 0; /* wrap back to top */ + + b = w->lines [crow] + ccol; + + while (len && ((ch = (unsigned char) *str++) != 0)) + { + len--; + + if (ch == '\n') + { + w->_cury = crow; + w->_curx = ccol; + SLcurses_wclrtoeol (w); + do_newline (w); + crow = w->_cury; + ccol = w->_curx; + b = w->lines[crow]; + continue; + } + + if (ccol >= ncols) + { + ccol = 0; + crow++; + if (crow >= nrows) + { + w->_curx = 0; + w->_cury = crow; + do_newline (w); + crow = w->_cury; + ccol = w->_curx; + } + + b = w->lines [crow]; + } + + if (ch == '\t') + { + unsigned int n = ccol; + n += SLsmg_Tab_Width; + n = SLsmg_Tab_Width - (n % SLsmg_Tab_Width); + if (ccol + n > ncols) n = ncols - len; + ccol += n; + while (n--) + *b++ = SLSMG_BUILD_CHAR(' ',color); + continue; + } + + *b++ = SLSMG_BUILD_CHAR(ch, color); + ccol++; + } + + w->_curx = ccol; + w->_cury = crow; + + return 0; +} + +/* This routine IS NOT CORRECT. It needs to compute the proper overlap + * and copy accordingly. Here, I just assume windows are same size. + */ +#if 0 +int SLcurses_overlay (SLcurses_Window_Type *swin, SLcurses_Window_Type *dwin) +{ + SLsmg_Char_Type *s, *smax, *d, *dmax; + + if ((swin == NULL) || (dwin == NULL)) + return -1; + + s = swin->buf; + smax = swin->bufmax; + d = dwin->buf; + dmax = dwin->bufmax; + + while ((s < smax) && (d < dmax)) + { + SLsmg_Char_Type ch = *s++; + if (SLSMG_EXTRACT_CHAR(ch) != ' ') + *d = ch; + d++; + } + + return -1; /* not implemented */ +} + +#endif + +SLcurses_Window_Type *SLcurses_subwin (SLcurses_Window_Type *orig, + unsigned int nlines, unsigned int ncols, + unsigned int begin_y, unsigned int begin_x) +{ + SLcurses_Window_Type *sw; + int r, c; + unsigned int i; + + if (orig == NULL) + return NULL; + + sw = (SLcurses_Window_Type *) SLmalloc (sizeof (SLcurses_Window_Type)); + if (sw == NULL) + return NULL; + + SLMEMSET ((char *)sw, 0, sizeof (SLcurses_Window_Type)); +#if 1 + r = begin_y - orig->_begy; +#else + r = 1 + ((int)orig->nrows - (int)nlines) / 2; +#endif + if (r < 0) r = 0; + if (r + nlines > orig->nrows) nlines = orig->nrows - r; + + c = ((int)orig->ncols - (int)ncols) / 2; + if (c < 0) c = 0; + if (c + ncols > orig->ncols) ncols = orig->ncols - c; + + sw->scroll_min = 0; + sw->scroll_max = sw->nrows = nlines; + sw->ncols = ncols; + sw->_begy = begin_y; + sw->_begx = begin_x; + sw->_maxx = (begin_x + ncols) - 1; + sw->_maxy = (begin_y + nlines) - 1; + + sw->lines = (SLsmg_Char_Type **) SLmalloc (nlines * sizeof (SLsmg_Char_Type *)); + if (sw->lines == NULL) + { + SLcurses_delwin (sw); + return NULL; + } + + for (i = 0; i < nlines; i++) + { + sw->lines [i] = orig->lines [r + i] + c; + } + + sw->is_subwin = 1; + return sw; +} + +int SLcurses_wclear (SLcurses_Window_Type *w) +{ + unsigned int i; + + if (w != NULL) w->modified = 1; + for (i=0; i < w->nrows; i++) + blank_line (w->lines[i], w->ncols, w->color); + return 0; +} + +int SLcurses_wdelch (SLcurses_Window_Type *w) +{ + SLsmg_Char_Type *p, *p1, *pmax; + + p = w->lines[w->_cury]; + pmax = p + w->ncols; + p += w->_curx; + p1 = p + 1; + + while (p1 < pmax) + { + *p = *p1; + p = p1; + p1++; + } + + if (p < pmax) + *p = SLSMG_BUILD_CHAR(' ',w->color); + + w->modified = 1; + return 0; +} + +int SLcurses_winsch (SLcurses_Window_Type *w, int ch) +{ + SLsmg_Char_Type *p, *p1, *pmax; + + p = w->lines[w->_cury]; + pmax = p + w->ncols; + p += w->_curx; + p1 = pmax - 1; + + while (pmax > p) + { + *pmax = *p1; + pmax = p1; + p1--; + } + + if (p < pmax) + *p = SLSMG_BUILD_CHAR(ch, w->color); + + w->modified = 1; + return 0; +} + +int SLcurses_endwin (void) +{ + SLcurses_Is_Endwin = 1; + SLsmg_suspend_smg (); + SLang_reset_tty (); + return 0; +} + +#if 0 +int SLcurses_mvwscanw (SLcurses_Window_Type *w, unsigned int r, unsigned int c, + char *fmt, ...) +{ +#if HAVE_VFSCANF + int ret; + va_list ap; + + SLcurses_wmove (w, r, c); + SLcurses_wrefresh (w); + + va_start(ap, fmt); + ret = vfscanf (stdin, fmt, ap); + va_end(ap); + return ret; +#else + return 0; +#endif +} + +int SLcurses_wscanw (SLcurses_Window_Type *w, char *fmt, ...) +{ +#if HAVE_VFSCANF + va_list ap; + int ret; + + SLcurses_wrefresh (w); + + va_start(ap, fmt); + ret = vfscanf (stdin, fmt, ap); + va_end(ap); + + return ret; +#else + return 0; +#endif +} + +int SLcurses_scanw (char *fmt, ...) +{ +#ifdef HAVE_VFSCANF + va_list ap; + int ret; + + SLcurses_wrefresh (SLcurses_Stdscr); + + va_start(ap, fmt); + ret = vfscanf (stdin, fmt, ap); + va_end(ap); + + return ret; +#else + return 0; +#endif +} +#endif + +int SLcurses_clearok (SLcurses_Window_Type *w, int bf) +{ + if (bf) + { + SLsmg_cls (); + w->modified = 1; + } + return 0; +} diff --git a/mdk-stage1/slang/slcurses.h b/mdk-stage1/slang/slcurses.h new file mode 100644 index 000000000..fa082304f --- /dev/null +++ b/mdk-stage1/slang/slcurses.h @@ -0,0 +1,353 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include <stdio.h> + +#ifndef SLANG_VERSION +# include <slang.h> +#endif + +/* This is a temporary hack until lynx is fixed to not include this file. */ +#ifndef LYCURSES_H + +typedef struct +{ + unsigned int _begy, _begx, _maxy, _maxx; + unsigned int _curx, _cury; + unsigned int nrows, ncols; + unsigned int scroll_min, scroll_max; + SLsmg_Char_Type **lines; + SLsmg_Char_Type color; + int is_subwin; + SLtt_Char_Type attr; + int delay_off; + int scroll_ok; + int modified; + int has_box; + int use_keypad; +} +SLcurses_Window_Type; + +extern int SLcurses_wclrtobot (SLcurses_Window_Type *); +extern int SLcurses_wscrl (SLcurses_Window_Type *, int); +extern int SLcurses_wrefresh (SLcurses_Window_Type *); +extern int SLcurses_delwin (SLcurses_Window_Type *); +extern int SLcurses_wprintw (SLcurses_Window_Type *, char *, ...); +extern SLcurses_Window_Type *SLcurses_newwin (unsigned int, unsigned int, + unsigned int, unsigned int); + +extern SLcurses_Window_Type *SLcurses_subwin (SLcurses_Window_Type *, + unsigned int, unsigned int, + unsigned int, unsigned int); + +extern int SLcurses_wnoutrefresh (SLcurses_Window_Type *); +extern int SLcurses_wclrtoeol (SLcurses_Window_Type *); + +extern int SLcurses_wmove (SLcurses_Window_Type *, unsigned int, unsigned int); +extern int SLcurses_waddch (SLcurses_Window_Type *, SLtt_Char_Type); +extern int SLcurses_waddnstr (SLcurses_Window_Type *, char *, int); + +#define waddnstr SLcurses_waddnstr +#define waddch SLcurses_waddch +#define waddstr(w,s) waddnstr((w),(s),-1) +#define addstr(x) waddstr(stdscr, (x)) +#define addnstr(s,n) waddnstr(stdscr,(s),(n)) +#define addch(ch) waddch(stdscr,(ch)) + +#define mvwaddnstr(w,y,x,s,n) \ + (-1 == wmove((w),(y),(x)) ? -1 : waddnstr((w),(s),(n))) +#define mvwaddstr(w,y,x,s) \ + (-1 == wmove((w),(y),(x)) ? -1 : waddnstr((w),(s), -1)) +#define mvaddnstr(y,x,s,n) mvwaddnstr(stdscr,(y),(x),(s),(n)) +#define mvaddstr(y,x,s) mvwaddstr(stdscr,(y),(x),(s)) +#define mvwaddch(w,y,x,c) \ + ((-1 == wmove((w),(y),(x))) ? -1 : waddch((w),(c))) +#define mvaddch(y,x,c) mvwaddch(stdscr,(y),(x),(c)) + +extern int SLcurses_wclear (SLcurses_Window_Type *w); +extern int SLcurses_printw (char *, ...); + +#if 0 +/* Why are these functions part of curses??? */ +extern int SLcurses_mvwscanw (SLcurses_Window_Type *, unsigned int, unsigned int, + char *, ...); +extern int SLcurses_wscanw (SLcurses_Window_Type *, char *, ...); +extern int SLcurses_scanw (char *, ...); +#define mvwscanw SLcurses_mvwscanw +#define wscanw SLcurses_wscanw +#define scanw SLcurses_scanw +#endif + +extern SLcurses_Window_Type *SLcurses_Stdscr; +#define WINDOW SLcurses_Window_Type +#define stdscr SLcurses_Stdscr + +#define subwin SLcurses_subwin +#define wclrtobot SLcurses_wclrtobot +#define wscrl SLcurses_wscrl +#define scrl(n) wscrl(stdscr,(n)) +#define scroll(w) wscrl((w),1) +#define wrefresh SLcurses_wrefresh +#define delwin SLcurses_delwin +#define wmove SLcurses_wmove +#define newwin SLcurses_newwin +#define wnoutrefresh SLcurses_wnoutrefresh +#define werase(w) SLcurses_wmove((w),0,0); SLcurses_wclrtobot(w) +#define wclear(w) SLcurses_wmove((w),0,0); SLcurses_wclrtobot(w) +#define wprintw SLcurses_wprintw +#define mvwprintw SLcurses_mvwprintw + +#define winch(w) \ + ((((w)->_cury < (w)->nrows) && ((w)->_curx < (w)->ncols)) \ + ? ((w)->lines[(w)->_cury][(w)->_curx]) : 0) + +#define inch() winch(stdscr) +#define mvwinch(w,x,y) \ + ((-1 != wmove((w),(x),(y))) ? winch(w) : (-1)) +#define doupdate SLsmg_refresh + +#define mvwin(w,a,b) ((w)->_begy = (a), (w)->_begx = (b)) + +extern int SLcurses_mvprintw (int, int, char *, ...); +extern int SLcurses_mvwprintw (SLcurses_Window_Type *, int, int, char *, ...); +extern int SLcurses_has_colors(void); +extern int SLcurses_nil (void); +extern int SLcurses_wgetch (SLcurses_Window_Type *); +extern int SLcurses_getch (void); + +extern int SLcurses_wattrset (SLcurses_Window_Type *, SLtt_Char_Type); +extern int SLcurses_wattron (SLcurses_Window_Type *, SLtt_Char_Type); +extern int SLcurses_wattroff (SLcurses_Window_Type *, SLtt_Char_Type); +#define attrset(x) SLcurses_wattrset(stdscr, (x)) +#define attron(x) SLcurses_wattron(stdscr, (x)) +#define attroff(x) SLcurses_wattroff(stdscr, (x)) +#define wattrset(w, x) SLcurses_wattrset((w), (x)) +#define wattron(w, x) SLcurses_wattron((w), (x)) +#define wattroff(w, x) SLcurses_wattroff((w), (x)) +#define wattr_get(w) ((w)->color << 8) +#define attr_get() wattr_get(stdscr) + +#define COLOR_PAIR(x) ((x) << 8) + +extern int SLcurses_start_color (void); +#define start_color SLcurses_start_color + +#define ERR 0xFFFF +#define wgetch SLcurses_wgetch +#define getch SLcurses_getch + +extern int SLcurses_nodelay (SLcurses_Window_Type *, int); +extern SLcurses_Window_Type *SLcurses_initscr (void); +#define initscr SLcurses_initscr + +extern int SLcurses_cbreak (void); +extern int SLcurses_raw (void); +#define cbreak SLcurses_cbreak +#define crmode SLcurses_cbreak +#define raw SLcurses_raw +#define noraw SLang_reset_tty +#define nocbreak SLang_reset_tty + +#define mvprintw SLcurses_mvprintw +#define has_colors SLcurses_has_colors +#define nodelay SLcurses_nodelay + +#define ungetch SLang_ungetkey + +#define COLS SLtt_Screen_Cols +#define LINES SLtt_Screen_Rows + +#define move(x,y) SLcurses_wmove(stdscr, (x), (y)) +#define wclrtoeol SLcurses_wclrtoeol +#define clrtoeol() SLcurses_wclrtoeol(stdscr) +#define clrtobot() SLcurses_wclrtobot(stdscr) + +#define printw SLcurses_printw +#define mvprintw SLcurses_mvprintw +#define wstandout(w) SLcurses_wattrset((w),A_STANDOUT) +#define wstandend(w) SLcurses_wattrset((w),A_NORMAL) +#define standout() SLcurses_wattrset(stdscr,A_STANDOUT) +#define standend() SLcurses_wattrset(stdscr,A_NORMAL) + +#define refresh() SLcurses_wrefresh(stdscr) +#define clear() SLcurses_wclear(stdscr) +#define erase() werase(stdscr) +#define touchline SLsmg_touch_lines +#define resetterm SLang_reset_tty + +extern int SLcurses_endwin (void); +#define endwin SLcurses_endwin +extern int SLcurses_Is_Endwin; +#define isendwin() SLcurses_Is_Endwin + +#define keypad(w,x) ((w)->use_keypad = (x)) + +#define KEY_MIN SL_KEY_UP +#define KEY_DOWN SL_KEY_DOWN +#define KEY_UP SL_KEY_UP +#define KEY_LEFT SL_KEY_LEFT +#define KEY_RIGHT SL_KEY_RIGHT +#define KEY_A1 SL_KEY_A1 +#define KEY_B1 SL_KEY_B1 +#define KEY_C1 SL_KEY_C1 +#define KEY_A2 SL_KEY_A2 +#define KEY_B2 SL_KEY_B2 +#define KEY_C2 SL_KEY_C2 +#define KEY_A3 SL_KEY_A3 +#define KEY_B3 SL_KEY_B3 +#define KEY_C3 SL_KEY_C3 +#define KEY_REDO SL_KEY_REDO +#define KEY_UNDO SL_KEY_UNDO +#define KEY_BACKSPACE SL_KEY_BACKSPACE +#define KEY_PPAGE SL_KEY_PPAGE +#define KEY_NPAGE SL_KEY_NPAGE +#define KEY_HOME SL_KEY_HOME +#define KEY_END SL_KEY_END +#define KEY_F0 SL_KEY_F0 +#define KEY_F SL_KEY_F +#define KEY_ENTER SL_KEY_ENTER +#define KEY_MAX 0xFFFF + +/* Ugly Hacks that may not work */ +#define flushinp SLcurses_nil +#define winsertln(w) \ + ((w)->scroll_min=(w)->_cury, \ + (w)->scroll_max=(w)->nrows, \ + wscrl((w), -1)) + +extern SLtt_Char_Type SLcurses_Acs_Map [128]; +#define acs_map SLcurses_Acs_Map + +#define ACS_ULCORNER (acs_map[SLSMG_ULCORN_CHAR]) +#define ACS_URCORNER (acs_map[SLSMG_URCORN_CHAR]) +#define ACS_LRCORNER (acs_map[SLSMG_LRCORN_CHAR]) +#define ACS_LLCORNER (acs_map[SLSMG_LLCORN_CHAR]) +#define ACS_TTEE (acs_map[SLSMG_UTEE_CHAR]) +#define ACS_LTEE (acs_map[SLSMG_LTEE_CHAR]) +#define ACS_RTEE (acs_map[SLSMG_RTEE_CHAR]) +#define ACS_BTEE (acs_map[SLSMG_DTEE_CHAR]) +#define ACS_PLUS (acs_map[SLSMG_PLUS_CHAR]) +#define ACS_VLINE (acs_map[SLSMG_VLINE_CHAR]) +#define ACS_HLINE (acs_map[SLSMG_HLINE_CHAR]) +#define ACS_S1 '-' +#define ACS_S9 '-' +#define ACS_DIAMOND '&' +#define ACS_CKBOARD (acs_map[SLSMG_CKBRD_CHAR]) +#define ACS_DEGREE 'o' +#define ACS_PLMINUS '+' +#define ACS_BULLET '*' +#define ACS_LARROW '<' +#define ACS_RARROW '>' +#define ACS_DARROW 'v' +#define ACS_UARROW '^' +#define ACS_BOARD '#' +#define ACS_LANTERN '#' +#define ACS_BLOCK '#' + +#if 1 +#define hline(x,y) SLcurses_nil () +#define vline(x,y) SLcurses_nil () +#endif + +#define A_CHARTEXT 0x00FF +#define A_NORMAL 0 +#define A_BOLD 0x1000 +#define A_REVERSE 0x2000 +#define A_STANDOUT A_REVERSE +#define A_UNDERLINE 0x4000 +#define A_BLINK 0 +#define A_COLOR 0x0700 +#define A_ALTCHARSET 0x8000 +#define A_DIM 0 +#define A_PROTECT 0 +#define A_INVIS 0 + +#define COLOR_BLACK SLSMG_COLOR_BLACK +#define COLOR_RED SLSMG_COLOR_RED +#define COLOR_GREEN SLSMG_COLOR_GREEN +#define COLOR_YELLOW SLSMG_COLOR_BROWN +#define COLOR_BLUE SLSMG_COLOR_BLUE +#define COLOR_MAGENTA SLSMG_COLOR_MAGENTA +#define COLOR_CYAN SLSMG_COLOR_CYAN +#define COLOR_WHITE SLSMG_COLOR_LGRAY + +extern int SLcurses_Num_Colors; +#define COLORS SLcurses_Num_Colors +#define COLOR_PAIRS (SLcurses_Num_Colors*SLcurses_Num_Colors) + +#define init_pair(_x,_f,_b) \ + SLtt_set_color_object((_x), ((_f) == (_b) ? 0x0700 : ((_f) | ((_b) << 8)) << 8)) + +#define scrollok(a,b) ((a)->scroll_ok = (b)) +#define getyx(a,y,x) (y=(a)->_cury, x=(a)->_curx) +#define getmaxyx(a,y,x) (y=(a)->nrows, x=(a)->ncols) +#define napms(x) usleep(1000 * (x)) +typedef SLtt_Char_Type chtype; +#define beep SLtt_beep +#define curs_set(x) SLtt_set_cursor_visibility(x) +#define touchwin(x) SLsmg_touch_lines((x)->_begy, (x)->nrows) +#define flash SLtt_beep + +#define wsetscrreg(w,a,b) ((w)->scroll_min = (a), (w)->scroll_max = (b)) + +#define wtimeout(a,b) (a)->delay_off = ((b >= 0) ? (b) / 100 : -1) +#define timeout(a) wtimeout(stdscr, a) +extern int SLcurses_wdelch (SLcurses_Window_Type *); +#define wdelch SLcurses_wdelch +#define delch() wdelch(stdscr) + +extern int SLcurses_winsch (SLcurses_Window_Type *, int); +#define winsch SLcurses_winsch + +extern int SLcurses_Esc_Delay;/* ESC expire time in milliseconds (ncurses compatible) */ +#define ESCDELAY SLcurses_Esc_Delay + +extern int SLcurses_clearok (SLcurses_Window_Type *, int); +#define clearok SLcurses_clearok + +/* Functions that have not been implemented. */ +#define copywin(w,v,a,b,c,d,e,f,g) SLcurses_nil() +#define wdeleteln(win) SLcurses_nil() +#define resetty SLcurses_nil +#define savetty SLcurses_nil +#define overlay(u,v) SLcurses_nil() + +/* These functions do nothing */ +#define savetty SLcurses_nil +#define nonl SLcurses_nil +#define echo SLcurses_nil +#define noecho SLcurses_nil +#define saveterm SLcurses_nil +#define box(w,y,z) ((w)->has_box = 1, (w)->modified = 1) +#define leaveok(a,b) SLcurses_nil() +#define nl() SLcurses_nil() +#define trace(x) SLcurses_nil() +#define tigetstr(x) NULL + +/* These have no place in C */ +#define TRUE 1 +#define FALSE 0 +#define bool int + +/* Lynx compatability */ +#else + +#define stdscr NULL +#define COLS SLtt_Screen_Cols +#define LINES SLtt_Screen_Rows +#define move SLsmg_gotorc +#define addstr SLsmg_write_string +#define clear SLsmg_cls +#define standout SLsmg_reverse_video +#define standend SLsmg_normal_video +#define clrtoeol SLsmg_erase_eol +#define scrollok(a,b) SLsmg_Newline_Moves = ((b) ? 1 : -1) +#define addch SLsmg_write_char +#define echo() +#define printw SLsmg_printf +#define endwin SLsmg_reset_smg(),SLang_reset_tty + +#endif diff --git a/mdk-stage1/slang/sldisply.c b/mdk-stage1/slang/sldisply.c new file mode 100644 index 000000000..1e1161774 --- /dev/null +++ b/mdk-stage1/slang/sldisply.c @@ -0,0 +1,2596 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include <time.h> +#include <ctype.h> + +#if !defined(VMS) || (__VMS_VER >= 70000000) +# include <sys/time.h> +# ifdef __QNX__ +# include <sys/select.h> +# endif +# include <sys/types.h> +#endif + +#ifdef __BEOS__ +/* Prototype for select */ +# include <net/socket.h> +#endif + +#ifdef HAVE_TERMIOS_H +# include <termios.h> +#endif + +#ifdef VMS +# include <unixlib.h> +# include <unixio.h> +# include <dvidef.h> +# include <descrip.h> +# include <lib$routines.h> +# include <starlet.h> +#else +# if !defined(sun) +# include <sys/ioctl.h> +# endif +#endif + +#ifdef SYSV +# include <sys/termio.h> +# include <sys/stream.h> +# include <sys/ptem.h> +# include <sys/tty.h> +#endif + +#if defined (_AIX) && !defined (FD_SET) +# include <sys/select.h> /* for FD_ISSET, FD_SET, FD_ZERO */ +#endif + +#include <errno.h> + +#if defined(__DECC) && defined(VMS) +/* These get prototypes for write an sleep */ +# include <unixio.h> +#endif +#include <signal.h> + +#include "slang.h" +#include "_slang.h" + +/* Colors: These definitions are used for the display. However, the + * application only uses object handles which get mapped to this + * internal representation. The mapping is performed by the Color_Map + * structure below. */ + +#define CHAR_MASK 0x000000FF +#define FG_MASK 0x0000FF00 +#define BG_MASK 0x00FF0000 +#define ATTR_MASK 0x1F000000 +#define BGALL_MASK 0x0FFF0000 + +/* The 0x10000000 bit represents the alternate character set. BGALL_MASK does + * not include this attribute. + */ + +#define GET_FG(color) ((color & FG_MASK) >> 8) +#define GET_BG(color) ((color & BG_MASK) >> 16) +#define MAKE_COLOR(fg, bg) (((fg) | ((bg) << 8)) << 8) + +int SLtt_Screen_Cols; +int SLtt_Screen_Rows; +int SLtt_Term_Cannot_Insert; +int SLtt_Term_Cannot_Scroll; +int SLtt_Use_Ansi_Colors; +int SLtt_Blink_Mode = 1; +int SLtt_Use_Blink_For_ACS = 0; +int SLtt_Newline_Ok = 0; +int SLtt_Has_Alt_Charset = 0; +int SLtt_Force_Keypad_Init = 0; + +void (*_SLtt_color_changed_hook)(void); + +#if SLTT_HAS_NON_BCE_SUPPORT +static int Bce_Color_Offset = 0; +#endif +static int Can_Background_Color_Erase = 1; + +/* -1 means unknown */ +int SLtt_Has_Status_Line = -1; /* hs */ +int SLang_TT_Write_FD = -1; + +static int Automatic_Margins; +/* static int No_Move_In_Standout; */ +static int Worthless_Highlight; +#define HP_GLITCH_CODE +#ifdef HP_GLITCH_CODE +/* This glitch is exclusive to HP term. Basically it means that to clear + * attributes, one has to erase to the end of the line. + */ +static int Has_HP_Glitch; +#endif + +static char *Reset_Color_String; +static int Is_Color_Terminal = 0; + +static int Linux_Console; + +/* It is crucial that JMAX_COLORS must be less than 128 since the high bit + * is used to indicate a character from the ACS (alt char set). The exception + * to this rule is if SLtt_Use_Blink_For_ACS is true. This means that of + * the highbit is set, we interpret that as a blink character. This is + * exploited by DOSemu. + */ +#define JMAX_COLORS 256 +#define JNORMAL_COLOR 0 + +typedef struct +{ + SLtt_Char_Type fgbg; + SLtt_Char_Type mono; + char *custom_esc; +} +Ansi_Color_Type; + +#define RGB1(r, g, b) ((r) | ((g) << 1) | ((b) << 2)) +#define RGB(r, g, b, br, bg, bb) ((RGB1(r, g, b) << 8) | (RGB1(br, bg, bb) << 16)) + +static Ansi_Color_Type Ansi_Color_Map[JMAX_COLORS] = +{ + {RGB(1, 1, 1, 0, 0, 0), 0x00000000, NULL}, /* white/black */ + {RGB(0, 1, 0, 0, 0, 0), SLTT_REV_MASK, NULL}, /* green/black */ + {RGB(1, 0, 1, 0, 0, 0), SLTT_REV_MASK, NULL}, /* magenta/black */ + {RGB(0, 1, 1, 0, 0, 0), SLTT_REV_MASK, NULL}, /* cyan/black */ + {RGB(1, 0, 0, 0, 0, 0), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 0, 0, 1), SLTT_REV_MASK, NULL}, + {RGB(1, 0, 0, 0, 0, 1), SLTT_REV_MASK, NULL}, + {RGB(1, 0, 0, 0, 1, 0), SLTT_REV_MASK, NULL}, + {RGB(0, 0, 1, 1, 0, 0), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 0, 0), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 1, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(1, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(1, 0, 1, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 0, 0, 0, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL}, + {RGB(0, 1, 0, 1, 1, 1), SLTT_REV_MASK, NULL} +}; + +static char *Color_Fg_Str = "\033[3%dm"; +static char *Color_Bg_Str = "\033[4%dm"; +static char *Default_Color_Fg_Str = "\033[39m"; +static char *Default_Color_Bg_Str = "\033[49m"; + +static int Max_Terminfo_Colors = 8; /* termcap Co */ + +char *SLtt_Graphics_Char_Pairs; /* ac termcap string -- def is vt100 */ + +/* 1 if terminal lacks the ability to go into insert mode or into delete + mode. Currently controlled by S-Lang but later perhaps termcap. */ + +static char *UnderLine_Vid_Str; +static char *Blink_Vid_Str; +static char *Bold_Vid_Str; +static char *Ins_Mode_Str; /* = "\033[4h"; */ /* ins mode (im) */ +static char *Eins_Mode_Str; /* = "\033[4l"; */ /* end ins mode (ei) */ +static char *Scroll_R_Str; /* = "\033[%d;%dr"; */ /* scroll region */ +static char *Cls_Str; /* = "\033[2J\033[H"; */ /* cl termcap STR for ansi terminals */ +static char *Rev_Vid_Str; /* = "\033[7m"; */ /* mr,so termcap string */ +static char *Norm_Vid_Str; /* = "\033[m"; */ /* me,se termcap string */ +static char *Del_Eol_Str; /* = "\033[K"; */ /* ce */ +static char *Del_Bol_Str; /* = "\033[1K"; */ /* cb */ +static char *Del_Char_Str; /* = "\033[P"; */ /* dc */ +static char *Del_N_Lines_Str; /* = "\033[%dM"; */ /* DL */ +static char *Add_N_Lines_Str; /* = "\033[%dL"; */ /* AL */ +static char *Rev_Scroll_Str; +static char *Curs_Up_Str; +static char *Curs_F_Str; /* RI termcap string */ +static char *Cursor_Visible_Str; /* ve termcap string */ +static char *Cursor_Invisible_Str; /* vi termcap string */ +#if 0 +static char *Start_Mouse_Rpt_Str; /* Start mouse reporting mode */ +static char *End_Mouse_Rpt_Str; /* End mouse reporting mode */ +#endif +static char *Start_Alt_Chars_Str; /* as */ +static char *End_Alt_Chars_Str; /* ae */ +static char *Enable_Alt_Char_Set; /* eA */ + +static char *Term_Init_Str; +static char *Keypad_Init_Str; +static char *Term_Reset_Str; +static char *Keypad_Reset_Str; + +/* status line functions */ +static char *Disable_Status_line_Str; /* ds */ +static char *Return_From_Status_Line_Str; /* fs */ +static char *Goto_Status_Line_Str; /* ts */ +static int Num_Status_Line_Columns; /* ws */ +/* static int Status_Line_Esc_Ok; */ /* es */ + +/* static int Len_Curs_F_Str = 5; */ + +/* cm string has %i%d since termcap numbers columns from 0 */ +/* char *CURS_POS_STR = "\033[%d;%df"; ansi-- hor and vert pos */ +static char *Curs_Pos_Str; /* = "\033[%i%d;%dH";*/ /* cm termcap string */ + +/* scrolling region */ +static int Scroll_r1 = 0, Scroll_r2 = 23; +static int Cursor_r, Cursor_c; /* 0 based */ + +/* current attributes --- initialized to impossible value */ +static SLtt_Char_Type Current_Fgbg = 0xFFFFFFFFU; + +static int Cursor_Set; /* 1 if cursor position known, 0 + * if not. -1 if only row is known + */ + +#define MAX_OUTPUT_BUFFER_SIZE 4096 + +static unsigned char Output_Buffer[MAX_OUTPUT_BUFFER_SIZE]; +static unsigned char *Output_Bufferp = Output_Buffer; + +unsigned long SLtt_Num_Chars_Output; + +int _SLusleep (unsigned long usecs) +{ +#if !defined(VMS) || (__VMS_VER >= 70000000) + struct timeval tv; + tv.tv_sec = usecs / 1000000; + tv.tv_usec = usecs % 1000000; + return select(0, NULL, NULL, NULL, &tv); +#else + return 0; +#endif +} + +int SLtt_flush_output (void) +{ + int nwrite = 0; + unsigned int total; + int n = (int) (Output_Bufferp - Output_Buffer); + + SLtt_Num_Chars_Output += n; + + total = 0; + while (n > 0) + { + nwrite = write (SLang_TT_Write_FD, (char *) Output_Buffer + total, n); + if (nwrite == -1) + { + nwrite = 0; +#ifdef EAGAIN + if (errno == EAGAIN) + { + _SLusleep (100000); /* 1/10 sec */ + continue; + } +#endif +#ifdef EWOULDBLOCK + if (errno == EWOULDBLOCK) + { + _SLusleep (100000); + continue; + } +#endif +#ifdef EINTR + if (errno == EINTR) continue; +#endif + break; + } + n -= nwrite; + total += nwrite; + } + Output_Bufferp = Output_Buffer; + return n; +} + +int SLtt_Baud_Rate; +static void tt_write(char *str, unsigned int n) +{ + static unsigned long last_time; + static int total; + unsigned long now; + unsigned int ndiff; + + if ((str == NULL) || (n == 0)) return; + total += n; + + while (1) + { + ndiff = MAX_OUTPUT_BUFFER_SIZE - (int) (Output_Bufferp - Output_Buffer); + if (ndiff < n) + { + SLMEMCPY ((char *) Output_Bufferp, (char *) str, ndiff); + Output_Bufferp += ndiff; + SLtt_flush_output (); + n -= ndiff; + str += ndiff; + } + else + { + SLMEMCPY ((char *) Output_Bufferp, str, n); + Output_Bufferp += n; + break; + } + } + + if (((SLtt_Baud_Rate > 150) && (SLtt_Baud_Rate <= 9600)) + && (10 * total > SLtt_Baud_Rate)) + { + total = 0; + if ((now = (unsigned long) time(NULL)) - last_time <= 1) + { + SLtt_flush_output (); + sleep((unsigned) 1); + } + last_time = now; + } +} + +static void tt_write_string (char *str) +{ + if (str != NULL) tt_write(str, strlen(str)); +} + +void SLtt_write_string (char *str) +{ + tt_write_string (str); + Cursor_Set = 0; +} + +void SLtt_putchar (char ch) +{ + SLtt_normal_video (); + if (Cursor_Set == 1) + { + if (ch >= ' ') Cursor_c++; + else if (ch == '\b') Cursor_c--; + else if (ch == '\r') Cursor_c = 0; + else Cursor_Set = 0; + + if ((Cursor_c + 1 == SLtt_Screen_Cols) + && Automatic_Margins) Cursor_Set = 0; + } + + if (Output_Bufferp < Output_Buffer + MAX_OUTPUT_BUFFER_SIZE) + { + *Output_Bufferp++ = (unsigned char) ch; + } + else tt_write (&ch, 1); +} + +static unsigned int tt_sprintf(char *buf, char *fmt, int x, int y) +{ + char *fmt_max; + register unsigned char *b, ch; + int offset; + int z, z1, parse_level; + int zero_pad; + int field_width; + int variables [26]; + int stack [64]; + unsigned int stack_len; + int parms [10]; +#define STACK_POP (stack_len ? stack[--stack_len] : 0) + + if (fmt == NULL) + { + *buf = 0; + return 0; + } + + stack [0] = y; /* pushed for termcap */ + stack [1] = x; + stack_len = 2; + + parms [1] = x; /* p1 */ + parms [2] = y; /* p2 */ + + offset = 0; + zero_pad = 0; + field_width = 0; + + b = (unsigned char *) buf; + fmt_max = fmt + strlen (fmt); + + while (fmt < fmt_max) + { + ch = *fmt++; + + if (ch != '%') + { + *b++ = ch; + continue; + } + + if (fmt == fmt_max) break; + ch = *fmt++; + + switch (ch) + { + default: + *b++ = ch; + break; + + case 'p': + + if (fmt == fmt_max) break; + ch = *fmt++; + if ((ch >= '0') && (ch <= '9')) + stack [stack_len++] = parms [ch - '0']; + break; + + case '\'': /* 'x' */ + if (fmt == fmt_max) break; + stack [stack_len++] = *fmt++; + if (fmt < fmt_max) fmt++; /* skip ' */ + break; + + case '{': /* literal constant, e.g. {30} */ + z = 0; + while ((fmt < fmt_max) && ((ch = *fmt) <= '9') && (ch >= '0')) + { + z = z * 10 + (ch - '0'); + fmt++; + } + stack [stack_len++] = z; + if ((ch == '}') && (fmt < fmt_max)) fmt++; + break; + + case '0': + if (fmt == fmt_max) break; + ch = *fmt; + if ((ch != '2') && (ch != '3')) + break; + zero_pad = 1; + fmt++; + /* drop */ + + case '2': + case '3': + if (fmt == fmt_max) + if (*fmt == 'x') + { + char x_fmt_buf [4]; + char *x_fmt_buf_ptr; + + x_fmt_buf_ptr = x_fmt_buf; + if (zero_pad) *x_fmt_buf_ptr++ = '0'; + *x_fmt_buf_ptr++ = ch; + *x_fmt_buf_ptr++ = 'X'; + *x_fmt_buf_ptr = 0; + + z = STACK_POP; + z += offset; + + sprintf ((char *)b, x_fmt_buf, z); + b += strlen ((char *)b); + zero_pad = 0; + break; + } + + field_width = (ch - '0'); + /* drop */ + + case 'd': + z = STACK_POP; + z += offset; + if (z >= 100) + { + *b++ = z / 100 + '0'; + z = z % 100; + zero_pad = 1; + field_width = 2; + } + else if (zero_pad && (field_width == 3)) + *b++ = '0'; + + if (z >= 10) + { + *b++ = z / 10 + '0'; + z = z % 10; + } + else if (zero_pad && (field_width >= 2)) + *b++ = '0'; + + *b++ = z + '0'; + field_width = zero_pad = 0; + break; + + case 'x': + z = STACK_POP; + z += offset; + sprintf ((char *) b, "%X", z); + b += strlen ((char *)b); + break; + + case 'i': + offset = 1; + break; + + case '+': + /* Handling this depends upon whether or not we are parsing + * terminfo. Terminfo requires the stack so use it as an + * indicator. + */ + if (stack_len > 2) + { + z = STACK_POP; + stack [stack_len - 1] += z; + } + else if (fmt < fmt_max) + { + ch = *fmt++; + if ((unsigned char) ch == 128) ch = 0; + ch = ch + (unsigned char) STACK_POP; + if (ch == '\n') ch++; + *b++ = ch; + } + break; + + /* Binary operators */ + case '-': + case '*': + case '/': + case 'm': + case '&': + case '|': + case '^': + case '=': + case '>': + case '<': + case 'A': + case 'O': + z1 = STACK_POP; + z = STACK_POP; + switch (ch) + { + case '-': z = (z - z1); break; + case '*': z = (z * z1); break; + case '/': z = (z / z1); break; + case 'm': z = (z % z1); break; + case '&': z = (z & z1); break; + case '|': z = (z | z1); break; + case '^': z = (z ^ z1); break; + case '=': z = (z == z1); break; + case '>': z = (z > z1); break; + case '<': z = (z < z1); break; + case 'A': z = (z && z1); break; + case 'O': z = (z || z1); break; + } + stack [stack_len++] = z; + break; + + /* unary */ + case '!': + z = STACK_POP; + stack [stack_len++] = !z; + break; + + case '~': + z = STACK_POP; + stack [stack_len++] = ~z; + break; + + case 'r': /* termcap -- swap parameters */ + z = stack [0]; + stack [0] = stack [1]; + stack [1] = z; + break; + + case '.': /* termcap */ + case 'c': + ch = (unsigned char) STACK_POP; + if (ch == '\n') ch++; + *b++ = ch; + break; + + case 'g': + if (fmt == fmt_max) break; + ch = *fmt++; + if ((ch >= 'a') && (ch <= 'z')) + stack [stack_len++] = variables [ch - 'a']; + break; + + case 'P': + if (fmt == fmt_max) break; + ch = *fmt++; + if ((ch >= 'a') && (ch <= 'z')) + variables [ch - 'a'] = STACK_POP; + break; + + /* If then else parsing. Actually, this is rather easy. The + * key is to notice that 'then' does all the work. 'if' simply + * there to indicate the start of a test and endif indicates + * the end of tests. If 'else' is seen, then skip to + * endif. + */ + case '?': /* if */ + case ';': /* endif */ + break; + + case 't': /* then */ + z = STACK_POP; + if (z != 0) + break; /* good. Continue parsing. */ + + /* z == 0 and test has failed. So, skip past this entire if + * expression to the matching else or matching endif. + */ + /* drop */ + case 'e': /* else */ + + parse_level = 0; + while (fmt < fmt_max) + { + unsigned char ch1; + + ch1 = *fmt++; + if ((ch1 != '%') || (fmt == fmt_max)) + continue; + + ch1 = *fmt++; + + if (ch1 == '?') parse_level++; /* new if */ + else if (ch1 == 'e') + { + if ((ch != 'e') && (parse_level == 0)) + break; + } + else if (ch1 == ';') + { + if (parse_level == 0) + break; + parse_level--; + } + } + break; + } + } + *b = 0; + return (unsigned int) (b - (unsigned char *) buf); +} + +static void tt_printf(char *fmt, int x, int y) +{ + char buf[1024]; + unsigned int n; + if (fmt == NULL) return; + n = tt_sprintf(buf, fmt, x, y); + tt_write(buf, n); +} + +void SLtt_set_scroll_region (int r1, int r2) +{ + Scroll_r1 = r1; + Scroll_r2 = r2; + tt_printf (Scroll_R_Str, Scroll_r1, Scroll_r2); + Cursor_Set = 0; +} + +void SLtt_reset_scroll_region (void) +{ + SLtt_set_scroll_region(0, SLtt_Screen_Rows - 1); +} + +int SLtt_set_cursor_visibility (int show) +{ + if ((Cursor_Visible_Str == NULL) || (Cursor_Invisible_Str == NULL)) + return -1; + + tt_write_string (show ? Cursor_Visible_Str : Cursor_Invisible_Str); + return 0; +} + +/* the goto_rc function moves to row relative to scrolling region */ +void SLtt_goto_rc(int r, int c) +{ + char *s = NULL; + int n; + char buf[6]; + + if ((c < 0) || (r < 0)) + { + Cursor_Set = 0; + return; + } + + /* if (No_Move_In_Standout && Current_Fgbg) SLtt_normal_video (); */ + r += Scroll_r1; + + if ((Cursor_Set > 0) || ((Cursor_Set < 0) && !Automatic_Margins)) + { + n = r - Cursor_r; + if ((n == -1) && (Cursor_Set > 0) && (Cursor_c == c) + && (Curs_Up_Str != NULL)) + { + s = Curs_Up_Str; + } + else if ((n >= 0) && (n <= 4)) + { + if ((n == 0) && (Cursor_Set == 1) + && ((c > 1) || (c == Cursor_c))) + { + if (Cursor_c == c) return; + if (Cursor_c == c + 1) + { + s = buf; + *s++ = '\b'; *s = 0; + s = buf; + } + } + else if (c == 0) + { + s = buf; + if ((Cursor_Set != 1) || (Cursor_c != 0)) *s++ = '\r'; + while (n--) *s++ = '\n'; +#ifdef VMS + /* Need to add this after \n to start a new record. Sheesh. */ + *s++ = '\r'; +#endif + *s = 0; + s = buf; + } + /* Will fail on VMS */ +#ifndef VMS + else if (SLtt_Newline_Ok && (Cursor_Set == 1) && + (Cursor_c >= c) && (c + 3 > Cursor_c)) + { + s = buf; + while (n--) *s++ = '\n'; + n = Cursor_c - c; + while (n--) *s++ = '\b'; + *s = 0; + s = buf; + } +#endif + } + } + if (s != NULL) tt_write_string(s); + else tt_printf(Curs_Pos_Str, r, c); + Cursor_c = c; Cursor_r = r; + Cursor_Set = 1; +} + +void SLtt_begin_insert (void) +{ + tt_write_string(Ins_Mode_Str); +} + +void SLtt_end_insert (void) +{ + tt_write_string(Eins_Mode_Str); +} + +void SLtt_delete_char (void) +{ + SLtt_normal_video (); + tt_write_string(Del_Char_Str); +} + +void SLtt_erase_line (void) +{ + tt_write_string("\r"); + Cursor_Set = 1; Cursor_c = 0; + SLtt_del_eol(); +} + +/* It appears that the Linux console, and most likely others do not + * like scrolling regions that consist of one line. So I have to + * resort to this stupidity to make up for that stupidity. + */ +static void delete_line_in_scroll_region (void) +{ + SLtt_goto_rc (Cursor_r - Scroll_r1, 0); + SLtt_del_eol (); +} + +void SLtt_delete_nlines (int n) +{ + int r1, curs; + char buf[132]; + + if (n <= 0) return; + SLtt_normal_video (); + + if (Scroll_r1 == Scroll_r2) + { + delete_line_in_scroll_region (); + return; + } + + if (Del_N_Lines_Str != NULL) tt_printf(Del_N_Lines_Str,n, 0); + else + /* get a new terminal */ + { + r1 = Scroll_r1; + curs = Cursor_r; + SLtt_set_scroll_region(curs, Scroll_r2); + SLtt_goto_rc(Scroll_r2 - Scroll_r1, 0); + SLMEMSET(buf, '\n', (unsigned int) n); + tt_write(buf, (unsigned int) n); + /* while (n--) tt_putchar('\n'); */ + SLtt_set_scroll_region(r1, Scroll_r2); + SLtt_goto_rc(curs, 0); + } +} + +void SLtt_cls (void) +{ + /* If the terminal is a color terminal but the user wants black and + * white, then make sure that the colors are reset. This appears to be + * necessary. + */ + if ((SLtt_Use_Ansi_Colors == 0) && Is_Color_Terminal) + { + if (Reset_Color_String != NULL) + tt_write_string (Reset_Color_String); + else + tt_write_string ("\033[0m\033[m"); + } + + SLtt_normal_video(); + SLtt_reset_scroll_region (); + tt_write_string(Cls_Str); +} + +void SLtt_reverse_index (int n) +{ + if (!n) return; + + SLtt_normal_video(); + + if (Scroll_r1 == Scroll_r2) + { + delete_line_in_scroll_region (); + return; + } + + if (Add_N_Lines_Str != NULL) tt_printf(Add_N_Lines_Str,n, 0); + else + { + while(n--) tt_write_string(Rev_Scroll_Str); + } +} + +int SLtt_Ignore_Beep = 1; +static char *Visible_Bell_Str; + +void SLtt_beep (void) +{ + if (SLtt_Ignore_Beep & 0x1) SLtt_putchar('\007'); + + if (SLtt_Ignore_Beep & 0x2) + { + if (Visible_Bell_Str != NULL) tt_write_string (Visible_Bell_Str); +#ifdef __linux__ + else if (Linux_Console) + { + tt_write_string ("\033[?5h"); + SLtt_flush_output (); + _SLusleep (50000); + tt_write_string ("\033[?5l"); + } +#endif + } + SLtt_flush_output (); +} + +static void del_eol (void) +{ + int c; + + if (Del_Eol_Str != NULL) + { + tt_write_string(Del_Eol_Str); + return; + } + + c = Cursor_c; + /* Avoid writing to the lower right corner. If the terminal does not + * have Del_Eol_Str, then it probably does not have what it takes to play + * games with insert for for a space into that corner. + */ + if (Cursor_r + 1 < SLtt_Screen_Rows) + c++; + + while (c < SLtt_Screen_Cols) + { + tt_write (" ", 1); + c++; + } +} + +void SLtt_del_eol (void) +{ + if (Current_Fgbg != 0xFFFFFFFFU) SLtt_normal_video (); + del_eol (); +} + +typedef struct +{ + char *name; + SLtt_Char_Type color; +} +Color_Def_Type; + +#define MAX_COLOR_NAMES 17 +static Color_Def_Type Color_Defs [MAX_COLOR_NAMES] = +{ + {"black", SLSMG_COLOR_BLACK}, + {"red", SLSMG_COLOR_RED}, + {"green", SLSMG_COLOR_GREEN}, + {"brown", SLSMG_COLOR_BROWN}, + {"blue", SLSMG_COLOR_BLUE}, + {"magenta", SLSMG_COLOR_MAGENTA}, + {"cyan", SLSMG_COLOR_CYAN}, + {"lightgray", SLSMG_COLOR_LGRAY}, + {"gray", SLSMG_COLOR_GRAY}, + {"brightred", SLSMG_COLOR_BRIGHT_RED}, + {"brightgreen", SLSMG_COLOR_BRIGHT_GREEN}, + {"yellow", SLSMG_COLOR_BRIGHT_BROWN}, + {"brightblue", SLSMG_COLOR_BRIGHT_BLUE}, + {"brightmagenta", SLSMG_COLOR_BRIGHT_CYAN}, + {"brightcyan", SLSMG_COLOR_BRIGHT_MAGENTA}, + {"white", SLSMG_COLOR_BRIGHT_WHITE}, +#define SLSMG_COLOR_DEFAULT 0xFF + {"default", SLSMG_COLOR_DEFAULT} +}; + +void SLtt_set_mono (int obj, char *what, SLtt_Char_Type mask) +{ + (void) what; + if ((obj < 0) || (obj >= JMAX_COLORS)) + { + return; + } + Ansi_Color_Map[obj].mono = mask & ATTR_MASK; +} + +static char *check_color_for_digit_form (char *color) +{ + unsigned int i, ich; + char *s = color; + + i = 0; + while ((ich = (int) *s) != 0) + { + if ((ich < '0') || (ich > '9')) + return color; + + i = i * 10 + (ich - '0'); + s++; + } + + if (i < MAX_COLOR_NAMES) + color = Color_Defs[i].name; + + return color; +} + +static int get_default_colors (char **fgp, char **bgp) +{ + static char fg_buf[16], bg_buf[16], *bg, *fg; + static int already_parsed; + char *p, *pmax; + + if (already_parsed == -1) + return -1; + + if (already_parsed) + { + *fgp = fg; + *bgp = bg; + return 0; + } + + already_parsed = -1; + + bg = getenv ("COLORFGBG"); + + if (bg == NULL) + { + bg = getenv ("DEFAULT_COLORS"); + if (bg == NULL) + return -1; + } + + p = fg_buf; + pmax = p + (sizeof (fg_buf) - 1); + + while ((*bg != 0) && (*bg != ';')) + { + if (p < pmax) *p++ = *bg; + bg++; + } + *p = 0; + + if (*bg) bg++; + + p = bg_buf; + pmax = p + (sizeof (bg_buf) - 1); + + /* Mark suggested allowing for extra spplication specific stuff following + * the background color. That is what the check for the semi-colon is for. + */ + while ((*bg != 0) && (*bg != ';')) + { + if (p < pmax) *p++ = *bg; + bg++; + } + *p = 0; + + if (!strcmp (fg_buf, "default") || !strcmp(bg_buf, "default")) + { + *fgp = *bgp = fg = bg = "default"; + } + else + { + *fgp = fg = check_color_for_digit_form (fg_buf); + *bgp = bg = check_color_for_digit_form (bg_buf); + } + already_parsed = 1; + return 0; +} + +static unsigned char FgBg_Stats[JMAX_COLORS]; + +static int Color_0_Modified = 0; + +void SLtt_set_color_object (int obj, SLtt_Char_Type attr) +{ + char *cust_esc; + + if ((obj < 0) || (obj >= JMAX_COLORS)) return; + + cust_esc = Ansi_Color_Map[obj].custom_esc; + if (cust_esc != NULL) + { + SLfree (cust_esc); + FgBg_Stats[(Ansi_Color_Map[obj].fgbg >> 8) & 0x7F] -= 1; + Ansi_Color_Map[obj].custom_esc = NULL; + } + + Ansi_Color_Map[obj].fgbg = attr; + if (obj == 0) Color_0_Modified = 1; + + if (_SLtt_color_changed_hook != NULL) + (*_SLtt_color_changed_hook)(); +} + +SLtt_Char_Type SLtt_get_color_object (int obj) +{ + if ((obj < 0) || (obj >= JMAX_COLORS)) return 0; + return Ansi_Color_Map[obj].fgbg; +} + +void SLtt_add_color_attribute (int obj, SLtt_Char_Type attr) +{ + if ((obj < 0) || (obj >= JMAX_COLORS)) return; + + Ansi_Color_Map[obj].fgbg |= (attr & ATTR_MASK); + if (obj == 0) Color_0_Modified = 1; + if (_SLtt_color_changed_hook != NULL) + (*_SLtt_color_changed_hook)(); +} + +static SLtt_Char_Type fb_to_fgbg (SLtt_Char_Type f, SLtt_Char_Type b) +{ + SLtt_Char_Type attr; + + if (Max_Terminfo_Colors != 8) + { + if (f != SLSMG_COLOR_DEFAULT) f %= Max_Terminfo_Colors; + if (b != SLSMG_COLOR_DEFAULT) b %= Max_Terminfo_Colors; + return ((f << 8) | (b << 16)); + } + + /* Otherwise we have 8 ansi colors. Try to get bright versions + * by using the BOLD and BLINK attributes. + */ + + attr = 0; + + /* Note: If f represents default, it will have the value 0xFF */ + if (f != SLSMG_COLOR_DEFAULT) + { + if (f & 0x8) attr = SLTT_BOLD_MASK; + f &= 0x7; + } + + if (b != SLSMG_COLOR_DEFAULT) + { + if (b & 0x8) attr |= SLTT_BLINK_MASK; + b &= 0x7; + } + + return ((f << 8) | (b << 16) | attr); +} + +/* This looks for colors with name form 'colorN'. If color is of this + * form, N is passed back via paramter list. + */ +static int parse_color_digit_name (char *color, SLtt_Char_Type *f) +{ + unsigned int i; + unsigned char ch; + + if (strncmp (color, "color", 5)) + return -1; + + color += 5; + if (*color == 0) + return -1; + + i = 0; + while (1) + { + ch = (unsigned char) *color++; + if (ch == 0) + break; + if ((ch > '9') || (ch < '0')) + return -1; + i = 10 * i + (ch - '0'); + } + + *f = (SLtt_Char_Type) i; + return 0; +} + +static int make_color_fgbg (char *fg, char *bg, SLtt_Char_Type *fgbg) +{ + SLtt_Char_Type f = 0xFFFFFFFFU, b = 0xFFFFFFFFU; + char *dfg, *dbg; + unsigned int i; + + if ((fg != NULL) && (*fg == 0)) fg = NULL; + if ((bg != NULL) && (*bg == 0)) bg = NULL; + + if ((fg == NULL) || (bg == NULL)) + { + if (-1 == get_default_colors (&dfg, &dbg)) + return -1; + + if (fg == NULL) fg = dfg; + if (bg == NULL) bg = dbg; + } + + if (-1 == parse_color_digit_name (fg, &f)) + { + for (i = 0; i < MAX_COLOR_NAMES; i++) + { + if (strcmp(fg, Color_Defs[i].name)) continue; + f = Color_Defs[i].color; + break; + } + } + + if (-1 == parse_color_digit_name (bg, &b)) + { + for (i = 0; i < MAX_COLOR_NAMES; i++) + { + if (strcmp(bg, Color_Defs[i].name)) continue; + b = Color_Defs[i].color; + break; + } + } + + if ((f == 0xFFFFFFFFU) || (b == 0xFFFFFFFFU)) + return -1; + + *fgbg = fb_to_fgbg (f, b); + return 0; +} + +void SLtt_set_color (int obj, char *what, char *fg, char *bg) +{ + SLtt_Char_Type fgbg; + + (void) what; + if ((obj < 0) || (obj >= JMAX_COLORS)) + return; + + if (-1 != make_color_fgbg (fg, bg, &fgbg)) + SLtt_set_color_object (obj, fgbg); +} + +void SLtt_set_color_fgbg (int obj, SLtt_Char_Type f, SLtt_Char_Type b) +{ + SLtt_set_color_object (obj, fb_to_fgbg (f, b)); +} + +void SLtt_set_color_esc (int obj, char *esc) +{ + char *cust_esc; + SLtt_Char_Type fgbg = 0; + int i; + + if ((obj < 0) || (obj >= JMAX_COLORS)) + { + return; + } + + cust_esc = Ansi_Color_Map[obj].custom_esc; + if (cust_esc != NULL) + { + SLfree (cust_esc); + FgBg_Stats[(Ansi_Color_Map[obj].fgbg >> 8) & 0x7F] -= 1; + } + + cust_esc = (char *) SLmalloc (strlen(esc) + 1); + if (cust_esc != NULL) strcpy (cust_esc, esc); + + Ansi_Color_Map[obj].custom_esc = cust_esc; + if (cust_esc == NULL) fgbg = 0; + else + { + /* The whole point of this is to generate a unique fgbg */ + for (i = 0; i < JMAX_COLORS; i++) + { + if (FgBg_Stats[i] == 0) fgbg = i; + + if (obj == i) continue; + if ((Ansi_Color_Map[i].custom_esc) == NULL) continue; + if (!strcmp (Ansi_Color_Map[i].custom_esc, cust_esc)) + { + fgbg = (Ansi_Color_Map[i].fgbg >> 8) & 0x7F; + break; + } + } + FgBg_Stats[fgbg] += 1; + } + + fgbg |= 0x80; + Ansi_Color_Map[obj].fgbg = (fgbg | (fgbg << 8)) << 8; + if (obj == 0) Color_0_Modified = 1; + if (_SLtt_color_changed_hook != NULL) + (*_SLtt_color_changed_hook)(); +} + +void SLtt_set_alt_char_set (int i) +{ + static int last_i; + if (SLtt_Has_Alt_Charset == 0) return; + if (i == last_i) return; + tt_write_string (i ? Start_Alt_Chars_Str : End_Alt_Chars_Str ); + last_i = i; +} + +static void write_attributes (SLtt_Char_Type fgbg) +{ + int bg0, fg0; + int unknown_attributes; + + if (Worthless_Highlight) return; + if (fgbg == Current_Fgbg) return; + + unknown_attributes = 0; + + /* Before spitting out colors, fix attributes */ + if ((fgbg & ATTR_MASK) != (Current_Fgbg & ATTR_MASK)) + { + if (Current_Fgbg & ATTR_MASK) + { + tt_write_string(Norm_Vid_Str); + /* In case normal video turns off ALL attributes: */ + if (fgbg & SLTT_ALTC_MASK) + Current_Fgbg &= ~SLTT_ALTC_MASK; + SLtt_set_alt_char_set (0); + } + + if ((fgbg & SLTT_ALTC_MASK) + != (Current_Fgbg & SLTT_ALTC_MASK)) + { + SLtt_set_alt_char_set ((int) (fgbg & SLTT_ALTC_MASK)); + } + + if (fgbg & SLTT_ULINE_MASK) tt_write_string (UnderLine_Vid_Str); + if (fgbg & SLTT_BOLD_MASK) SLtt_bold_video (); + if (fgbg & SLTT_REV_MASK) tt_write_string (Rev_Vid_Str); + if (fgbg & SLTT_BLINK_MASK) + { + /* Someday Linux will have a blink mode that set high intensity + * background. Lets be prepared. + */ + if (SLtt_Blink_Mode) tt_write_string (Blink_Vid_Str); + } + unknown_attributes = 1; + } + + if (SLtt_Use_Ansi_Colors) + { + fg0 = (int) GET_FG(fgbg); + bg0 = (int) GET_BG(fgbg); + + if (unknown_attributes + || (fg0 != (int)GET_FG(Current_Fgbg))) + { + if (fg0 == SLSMG_COLOR_DEFAULT) + tt_write_string (Default_Color_Fg_Str); + else + tt_printf (Color_Fg_Str, fg0, 0); + } + + if (unknown_attributes + || (bg0 != (int)GET_BG(Current_Fgbg))) + { + if (bg0 == SLSMG_COLOR_DEFAULT) + tt_write_string (Default_Color_Bg_Str); + else + tt_printf (Color_Bg_Str, bg0, 0); + } + } + + Current_Fgbg = fgbg; +} + +static int Video_Initialized; + +void SLtt_reverse_video (int color) +{ + SLtt_Char_Type fgbg; + char *esc; + + if (Worthless_Highlight) return; + if ((color < 0) || (color >= JMAX_COLORS)) return; + + if (Video_Initialized == 0) + { + if (color == JNORMAL_COLOR) + { + tt_write_string (Norm_Vid_Str); + } + else tt_write_string (Rev_Vid_Str); + Current_Fgbg = 0xFFFFFFFFU; + return; + } + + if (SLtt_Use_Ansi_Colors) + { + fgbg = Ansi_Color_Map[color].fgbg; + if ((esc = Ansi_Color_Map[color].custom_esc) != NULL) + { + if (fgbg != Current_Fgbg) + { + Current_Fgbg = fgbg; + tt_write_string (esc); + return; + } + } + } + else fgbg = Ansi_Color_Map[color].mono; + + if (fgbg == Current_Fgbg) return; + write_attributes (fgbg); +} + +void SLtt_normal_video (void) +{ + SLtt_reverse_video(JNORMAL_COLOR); +} + +void SLtt_narrow_width (void) +{ + tt_write_string("\033[?3l"); +} + +void SLtt_wide_width (void) +{ + tt_write_string("\033[?3h"); +} + +/* Highest bit represents the character set. */ +#define COLOR_MASK 0x7F00 + +#if SLTT_HAS_NON_BCE_SUPPORT +static int bce_color_eqs (unsigned int a, unsigned int b) +{ + a = (a & COLOR_MASK) >> 8; + b = (b & COLOR_MASK) >> 8; + + if (a == b) + return 1; + + if (SLtt_Use_Ansi_Colors == 0) + return Ansi_Color_Map[a].mono == Ansi_Color_Map[b].mono; + + if (Bce_Color_Offset == 0) + return Ansi_Color_Map[a].fgbg == Ansi_Color_Map[b].fgbg; + + /* If either are color 0, then we do not know what that means since the + * terminal does not support BCE */ + if ((a == 0) || (b == 0)) + return 0; + + return Ansi_Color_Map[a-1].fgbg == Ansi_Color_Map[b-1].fgbg; +} +#define COLOR_EQS(a,b) bce_color_eqs (a,b) +#else +# define COLOR_OF(x) (((unsigned int)(x) & COLOR_MASK) >> 8) +# define COLOR_EQS(a, b) \ + (SLtt_Use_Ansi_Colors \ + ? (Ansi_Color_Map[COLOR_OF(a)].fgbg == Ansi_Color_Map[COLOR_OF(b)].fgbg)\ + : (Ansi_Color_Map[COLOR_OF(a)].mono == Ansi_Color_Map[COLOR_OF(b)].mono)) +#endif + +#define CHAR_EQS(a, b) (((a) == (b))\ + || ((((a) & ~COLOR_MASK) == ((b) & ~COLOR_MASK))\ + && COLOR_EQS((a), (b)))) + +/* The whole point of this routine is to prevent writing to the last column + * and last row on terminals with automatic margins. + */ +static void write_string_with_care (char *str) +{ + unsigned int len; + + if (str == NULL) return; + + len = strlen (str); + if (Automatic_Margins && (Cursor_r + 1 == SLtt_Screen_Rows)) + { + if (len + (unsigned int) Cursor_c >= (unsigned int) SLtt_Screen_Cols) + { + /* For now, just do not write there. Later, something more + * sophisticated will be implemented. + */ + if (SLtt_Screen_Cols > Cursor_c) + len = SLtt_Screen_Cols - Cursor_c - 1; + else + len = 0; + } + } + tt_write (str, len); +} + +static void send_attr_str (SLsmg_Char_Type *s) +{ + unsigned char out[256], ch, *p; + register SLtt_Char_Type attr; + register SLsmg_Char_Type sh; + int color, last_color = -1; + + p = out; + while (0 != (sh = *s++)) + { + ch = sh & 0xFF; + color = ((int) sh & 0xFF00) >> 8; + +#if SLTT_HAS_NON_BCE_SUPPORT + if (Bce_Color_Offset + && (color >= Bce_Color_Offset)) + color -= Bce_Color_Offset; +#endif + + if (color != last_color) + { + if (SLtt_Use_Ansi_Colors) attr = Ansi_Color_Map[color & 0x7F].fgbg; + else attr = Ansi_Color_Map[color & 0x7F].mono; + + if (sh & 0x8000) /* alternate char set */ + { + if (SLtt_Use_Blink_For_ACS) + { + if (SLtt_Blink_Mode) attr |= SLTT_BLINK_MASK; + } + else attr |= SLTT_ALTC_MASK; + } + + if (attr != Current_Fgbg) + { + if ((ch != ' ') || + /* it is a space so only consider it different if it + * has different attributes. + */ + (attr & BGALL_MASK) != (Current_Fgbg & BGALL_MASK)) + { + if (p != out) + { + *p = 0; + write_string_with_care ((char *) out); + Cursor_c += (int) (p - out); + p = out; + } + + if (SLtt_Use_Ansi_Colors && (NULL != Ansi_Color_Map[color & 0x7F].custom_esc)) + { + tt_write_string (Ansi_Color_Map[color & 0x7F].custom_esc); + /* Just in case the custom escape sequence screwed up + * the alt character set state... + */ + if ((attr & SLTT_ALTC_MASK) != (Current_Fgbg & SLTT_ALTC_MASK)) + SLtt_set_alt_char_set ((int) (attr & SLTT_ALTC_MASK)); + Current_Fgbg = attr; + } + else write_attributes (attr); + + last_color = color; + } + } + } + *p++ = ch; + } + *p = 0; + if (p != out) write_string_with_care ((char *) out); + Cursor_c += (int) (p - out); +} + +static void forward_cursor (unsigned int n, int row) +{ + char buf [1024]; + + if (n <= 4) + { + SLtt_normal_video (); + SLMEMSET (buf, ' ', n); + buf[n] = 0; + write_string_with_care (buf); + Cursor_c += n; + } + else if (Curs_F_Str != NULL) + { + Cursor_c += n; + n = tt_sprintf(buf, Curs_F_Str, (int) n, 0); + tt_write(buf, n); + } + else SLtt_goto_rc (row, (int) (Cursor_c + n)); +} + + +void SLtt_smart_puts(SLsmg_Char_Type *neww, SLsmg_Char_Type *oldd, int len, int row) +{ + register SLsmg_Char_Type *p, *q, *qmax, *pmax, *buf; + SLsmg_Char_Type buffer[256]; + unsigned int n_spaces; + SLsmg_Char_Type *space_match, *last_buffered_match; +#ifdef HP_GLITCH_CODE + int handle_hp_glitch = 0; +#endif + SLsmg_Char_Type space_char; +#define SLTT_USE_INSERT_HACK 1 +#if SLTT_USE_INSERT_HACK + SLsmg_Char_Type insert_hack_prev = 0; + SLsmg_Char_Type insert_hack_char = 0; + + if ((row + 1 == SLtt_Screen_Rows) + && (len == SLtt_Screen_Cols) + && (len > 1) + && (SLtt_Term_Cannot_Insert == 0) + && Automatic_Margins) + { + insert_hack_char = neww[len-1]; + if (oldd[len-1] == insert_hack_char) + insert_hack_char = 0; + else + insert_hack_prev = neww[len-2]; + } +#endif + + q = oldd; p = neww; + qmax = oldd + len; + pmax = p + len; + + /* Find out where to begin --- while they match, we are ok */ + while (1) + { + if (q == qmax) return; +#if SLANG_HAS_KANJI_SUPPORT + if (*p & 0x80) + { /* new is kanji */ + if ((*q & 0x80) && ((q + 1) < qmax)) + { /* old is also kanji */ + if (((0xFF & *q) != (0xFF & *p)) + || ((0xFF & q[1]) != (0xFF & p[1]))) + break; /* both kanji, but not match */ + + else + { /* kanji match ! */ + if (!COLOR_EQS(*q, *p)) break; + q++; p++; + if (!COLOR_EQS(*q, *p)) break; + /* really match! */ + q++; p++; + continue; + } + } + else break; /* old is not kanji */ + } + else + { /* new is not kanji */ + if (*q & 0x80) break; /* old is kanji */ + } +#endif + if (!CHAR_EQS(*q, *p)) break; + q++; p++; + } + +#ifdef HP_GLITCH_CODE + if (Has_HP_Glitch) + { + SLsmg_Char_Type *qq = q; + + SLtt_goto_rc (row, (int) (p - neww)); + + while (qq < qmax) + { + if (*qq & 0xFF00) + { + SLtt_normal_video (); + SLtt_del_eol (); + qmax = q; + handle_hp_glitch = 1; + break; + } + qq++; + } + } +#endif + /* Find where the last non-blank character on old/new screen is */ + + space_char = ' '; + if ((*(pmax-1) & 0xFF) == ' ') + { + /* If we get here, then we can erase to the end of the line to create + * the final space. However, this will only work _if_ erasing will + * get us the correct color. If the terminal supports BCE, then this + * is easy. If it does not, then we can only perform this operation + * if the color is known via something like COLORFGBG. For now, + * I just will not perform the optimization for such terminals. + */ + if ((Can_Background_Color_Erase) + && SLtt_Use_Ansi_Colors) + space_char = *(pmax - 1); + + while (pmax > p) + { + pmax--; + if (!CHAR_EQS(*pmax, space_char)) + { + pmax++; + break; + } + } + } + + while (qmax > q) + { + qmax--; + if (!CHAR_EQS(*qmax, space_char)) + { + qmax++; + break; + } + } + + last_buffered_match = buf = buffer; /* buffer is empty */ + +#ifdef HP_GLITCH_CODE + if (handle_hp_glitch) + { + while (p < pmax) + { + *buf++ = *p++; + } + } +#endif + +#ifdef HP_GLITCH_CODE + if (Has_HP_Glitch == 0) + { +#endif + /* Try use use erase to bol if possible */ + if ((Del_Bol_Str != NULL) && ((*neww & 0xFF) == 32)) + { + SLsmg_Char_Type *p1; + SLsmg_Char_Type blank; + + p1 = neww; + if ((Can_Background_Color_Erase) + && SLtt_Use_Ansi_Colors) + blank = *p1; + /* black+white attributes do not support bce */ + else + blank = 32; + + while ((p1 < pmax) && (CHAR_EQS (*p1, blank))) + p1++; + + /* Is this optimization worth it? Assume Del_Bol_Str is ESC [ 1 K + * It costs 4 chars + the space needed to properly position the + * cursor, e.g., ESC [ 10;10H. So, it costs at least 13 characters. + */ + if ((p1 > neww + 13) + && (p1 >= p) + /* Avoid erasing from the end of the line */ + && ((p1 != pmax) || (pmax < neww + len))) + { + int ofs = (int) (p1 - neww); + q = oldd + ofs; + p = p1; + SLtt_goto_rc (row, ofs - 1); + SLtt_reverse_video (blank >> 8); + tt_write_string (Del_Bol_Str); + tt_write (" ", 1); + Cursor_c += 1; + } + else + SLtt_goto_rc (row, (int) (p - neww)); + } + else + SLtt_goto_rc (row, (int) (p - neww)); +#ifdef HP_GLITCH_CODE + } +#endif + + + /* loop using overwrite then skip algorithm until done */ + while (1) + { + /* while they do not match and we do not hit a space, buffer them up */ + n_spaces = 0; + while (p < pmax) + { + if (CHAR_EQS(*q, 32) && CHAR_EQS(*p, 32)) + { + /* If *q is not a space, we would have to overwrite it. + * However, if *q is a space, then while *p is also one, + * we only need to skip over the blank field. + */ + space_match = p; + p++; q++; + while ((p < pmax) + && CHAR_EQS(*q, 32) + && CHAR_EQS(*p, 32)) + { + p++; + q++; + } + n_spaces = (unsigned int) (p - space_match); + break; + } +#if SLANG_HAS_KANJI_SUPPORT + if ((*p & 0x80) && ((p + 1) < pmax)) + { /* new is kanji */ + if (*q & 0x80) + { /* old is also kanji */ + if (((0xFF & *q) != (0xFF & *p)) + || ((0xFF & q[1]) != (0xFF & p[1]))) + { + /* both kanji, but not match */ + *buf++ = *p++; + *buf++ = *p++; + q += 2; + continue; + } + else + { /* kanji match ? */ + if (!COLOR_EQS(*q, *p) || !COLOR_EQS(*(q+1), *(p+1))) + { + /* code is match, but color is diff */ + *buf++ = *p++; + *buf++ = *p++; + q += 2; + continue; + } + /* really match ! */ + break; + } + } + else + { /* old is not kanji */ + *buf++ = *p++; + *buf++ = *p++; + q += 2; + continue; + } + } + else + { /* new is not kanji */ + if (*q & 0x80) + { /* old is kanji */ + *buf++ = *p++; + q++; + continue; + } + } +#endif + + if (CHAR_EQS(*q, *p)) break; + *buf++ = *p++; + q++; + } + *buf = 0; + + if (buf != buffer) send_attr_str (buffer); + buf = buffer; + + if (n_spaces + && ((p < pmax) /* erase to eol will achieve this effect*/ + || (space_char != 32)))/* unless space_char is not a simple space */ + { + forward_cursor (n_spaces, row); + } + + /* Now we overwrote what we could and cursor is placed at position + * of a possible match of new and old. If this is the case, skip + * some more. + */ +#if !SLANG_HAS_KANJI_SUPPORT + while ((p < pmax) && CHAR_EQS(*p, *q)) + { + *buf++ = *p++; + q++; + } +#else + /* Kanji */ + while (p < pmax) + { + if ((*p & 0x80) && ((p + 1) < pmax)) + { /* new is kanji */ + if (*q & 0x80) + { /* old is also kanji */ + if (((0xFF & *q) == (0xFF & *p)) + && ((0xFF & q[1]) == (0xFF & p[1]))) + { + /* kanji match ? */ + if (!COLOR_EQS(*q, *p) + || !COLOR_EQS(q[1], p[1])) + break; + + *buf++ = *p++; + q++; + if (p >= pmax) + { + *buf++ = 32; + p++; + break; + } + else + { + *buf++ = *p++; + q++; + continue; + } + } + else break; /* both kanji, but not match */ + } + else break; /* old is not kanji */ + } + else + { /* new is not kanji */ + if (*q & 0x80) break; /* old is kanji */ + if (!CHAR_EQS(*q, *p)) break; + *buf++ = *p++; + q++; + } + } +#endif + last_buffered_match = buf; + if (p >= pmax) break; + + /* jump to new position is it is greater than 5 otherwise + * let it sit in the buffer and output it later. + */ + if ((int) (buf - buffer) >= 5) + { + forward_cursor ((unsigned int) (buf - buffer), row); + last_buffered_match = buf = buffer; + } + } + + if (buf != buffer) + { + if (q < qmax) + { + if ((buf == last_buffered_match) + && ((int) (buf - buffer) >= 5)) + { + forward_cursor ((unsigned int) (buf - buffer), row); + } + else + { + *buf = 0; + send_attr_str (buffer); + } + } + } + + if (q < qmax) + { + SLtt_reverse_video (space_char >> 8); + del_eol (); + } + +#if SLTT_USE_INSERT_HACK + else if (insert_hack_char) + { + SLtt_goto_rc (SLtt_Screen_Rows-1, SLtt_Screen_Cols-2); + buffer[0] = insert_hack_char; + buffer[1] = 0; + send_attr_str (buffer); + SLtt_goto_rc (SLtt_Screen_Rows-1, SLtt_Screen_Cols-2); + buffer[0] = insert_hack_prev; + SLtt_begin_insert (); + send_attr_str (buffer); + SLtt_end_insert (); + } +#endif + + if (Automatic_Margins && (Cursor_c + 1 >= SLtt_Screen_Cols)) Cursor_Set = 0; +} + +static void get_color_info (void) +{ + char *fg, *bg; + + /* Allow easy mechanism to override inadequate termcap/terminfo files. */ + if (SLtt_Use_Ansi_Colors == 0) + SLtt_Use_Ansi_Colors = (NULL != getenv ("COLORTERM")); + + if (SLtt_Use_Ansi_Colors) + Is_Color_Terminal = 1; + +#if SLTT_HAS_NON_BCE_SUPPORT + if (Can_Background_Color_Erase == 0) + Can_Background_Color_Erase = (NULL != getenv ("COLORTERM_BCE")); +#endif + + if (-1 == get_default_colors (&fg, &bg)) + return; + + /* Check to see if application has already set them. */ + if (Color_0_Modified) + return; + + SLtt_set_color (0, NULL, fg, bg); + SLtt_set_color (1, NULL, bg, fg); +} + +/* termcap stuff */ + +#ifdef __unix__ + +static int Termcap_Initalized = 0; + +#ifdef USE_TERMCAP +/* Termcap based system */ +static char Termcap_Buf[4096]; +static char Termcap_String_Buf[4096]; +static char *Termcap_String_Ptr; +extern char *tgetstr(char *, char **); +extern int tgetent(char *, char *); +extern int tgetnum(char *); +extern int tgetflag(char *); +#else +/* Terminfo */ +static SLterminfo_Type *Terminfo; +#endif + +#define TGETFLAG(x) (SLtt_tgetflag(x) > 0) + +static char *fixup_tgetstr (char *what) +{ + register char *w, *w1; + char *wsave; + + if (what == NULL) + return NULL; + + /* Check for AIX brain-damage */ + if (*what == '@') + return NULL; + + /* lose pad info --- with today's technology, term is a loser if + it is really needed */ + while ((*what == '.') || + ((*what >= '0') && (*what <= '9'))) what++; + if (*what == '*') what++; + + /* lose terminfo padding--- looks like $<...> */ + w = what; + while (*w) if ((*w++ == '$') && (*w == '<')) + { + w1 = w - 1; + while (*w && (*w != '>')) w++; + if (*w == 0) break; + w++; + wsave = w1; + while ((*w1++ = *w++) != 0); + w = wsave; + } + + if (*what == 0) what = NULL; + return what; +} + +char *SLtt_tgetstr (char *s) +{ + if (Termcap_Initalized == 0) + return NULL; + +#ifdef USE_TERMCAP + s = tgetstr (s, &Termcap_String_Ptr); +#else + s = _SLtt_tigetstr (Terminfo, s); +#endif + return fixup_tgetstr (s); +} + +int SLtt_tgetnum (char *s) +{ + if (Termcap_Initalized == 0) + return -1; +#ifdef USE_TERMCAP + return tgetnum (s); +#else + return _SLtt_tigetnum (Terminfo, s); +#endif +} + +int SLtt_tgetflag (char *s) +{ + if (Termcap_Initalized == 0) + return -1; +#ifdef USE_TERMCAP + return tgetflag (s); +#else + return _SLtt_tigetflag (Terminfo, s); +#endif +} + +static int Vt100_Like = 0; + +void SLtt_get_terminfo (void) +{ + char *term; + int status; + + term = getenv ("TERM"); + if (term == NULL) + SLang_exit_error("TERM environment variable needs set."); + + if (0 == (status = SLtt_initialize (term))) + return; + + if (status == -1) + { + SLang_exit_error ("Unknown terminal: %s\n\ +Check the TERM environment variable.\n\ +Also make sure that the terminal is defined in the terminfo database.\n\ +Alternatively, set the TERMCAP environment variable to the desired\n\ +termcap entry.", + term); + } + + if (status == -2) + { + SLang_exit_error ("\ +Your terminal lacks the ability to clear the screen or position the cursor.\n"); + } +} + +/* Returns 0 if all goes well, -1 if terminal capabilities cannot be deduced, + * or -2 if terminal cannot position the cursor. + */ +int SLtt_initialize (char *term) +{ + char *t, ch; + int is_xterm; + int almost_vtxxx; + + if (SLang_TT_Write_FD == -1) + { + /* Apparantly, this cannot fail according to the man pages. */ + SLang_TT_Write_FD = fileno (stdout); + } + + if (term == NULL) + { + term = getenv ("TERM"); + if (term == NULL) + return -1; + } + + Linux_Console = (!strncmp (term, "linux", 5) +# ifdef linux + || !strncmp(term, "con", 3) +# endif + ); + + t = term; + + if (strcmp(t, "vt52") && (*t++ == 'v') && (*t++ == 't') + && (ch = *t, (ch >= '1') && (ch <= '9'))) Vt100_Like = 1; + + is_xterm = ((0 == strncmp (term, "xterm", 5)) + || (0 == strncmp (term, "rxvt", 4)) + || (0 == strncmp (term, "Eterm", 5))); + + almost_vtxxx = (Vt100_Like + || Linux_Console + || is_xterm + || !strcmp (term, "screen")); + +# ifndef USE_TERMCAP + if (NULL == (Terminfo = _SLtt_tigetent (term))) + { + if (almost_vtxxx) /* Special cases. */ + { + int vt102 = 1; + if (!strcmp (term, "vt100")) vt102 = 0; + get_color_info (); + SLtt_set_term_vtxxx (&vt102); + return 0; + } + return -1; + } +# else /* USE_TERMCAP */ + if (1 != tgetent(Termcap_Buf, term)) + return -1; + Termcap_String_Ptr = Termcap_String_Buf; +# endif /* NOT USE_TERMCAP */ + + Termcap_Initalized = 1; + + Cls_Str = SLtt_tgetstr ("cl"); + Curs_Pos_Str = SLtt_tgetstr ("cm"); + + if ((NULL == (Ins_Mode_Str = SLtt_tgetstr("im"))) + || ( NULL == (Eins_Mode_Str = SLtt_tgetstr("ei"))) + || ( NULL == (Del_Char_Str = SLtt_tgetstr("dc")))) + SLtt_Term_Cannot_Insert = 1; + + Visible_Bell_Str = SLtt_tgetstr ("vb"); + Curs_Up_Str = SLtt_tgetstr ("up"); + Rev_Scroll_Str = SLtt_tgetstr("sr"); + Del_N_Lines_Str = SLtt_tgetstr("DL"); + Add_N_Lines_Str = SLtt_tgetstr("AL"); + + /* Actually these are used to initialize terminals that use cursor + * addressing. Hard to believe. + */ + Term_Init_Str = SLtt_tgetstr ("ti"); + Term_Reset_Str = SLtt_tgetstr ("te"); + + /* If I do this for vtxxx terminals, arrow keys start sending ESC O A, + * which I do not want. This is mainly for HP terminals. + */ + if ((almost_vtxxx == 0) || SLtt_Force_Keypad_Init) + { + Keypad_Init_Str = SLtt_tgetstr ("ks"); + Keypad_Reset_Str = SLtt_tgetstr ("ke"); + } + + /* Make up for defective termcap/terminfo databases */ + if ((Vt100_Like && (term[2] != '1')) + || Linux_Console + || is_xterm + ) + { + if (Del_N_Lines_Str == NULL) Del_N_Lines_Str = "\033[%dM"; + if (Add_N_Lines_Str == NULL) Add_N_Lines_Str = "\033[%dL"; + } + + Scroll_R_Str = SLtt_tgetstr("cs"); + + SLtt_get_screen_size (); + + if ((Scroll_R_Str == NULL) + || (((NULL == Del_N_Lines_Str) || (NULL == Add_N_Lines_Str)) + && (NULL == Rev_Scroll_Str))) + { + if (is_xterm + || Linux_Console + ) + { + /* Defective termcap mode!!!! */ + SLtt_set_term_vtxxx (NULL); + } + else SLtt_Term_Cannot_Scroll = 1; + } + + Del_Eol_Str = SLtt_tgetstr("ce"); + Del_Bol_Str = SLtt_tgetstr("cb"); + if (is_xterm && (Del_Bol_Str == NULL)) + Del_Bol_Str = "\033[1K"; + if (is_xterm && (Del_Eol_Str == NULL)) + Del_Bol_Str = "\033[K"; + + Rev_Vid_Str = SLtt_tgetstr("mr"); + if (Rev_Vid_Str == NULL) Rev_Vid_Str = SLtt_tgetstr("so"); + + Bold_Vid_Str = SLtt_tgetstr("md"); + + /* Although xterm cannot blink, it does display the blinking characters + * as bold ones. Some Rxvt will display the background as high intensity. + */ + if ((NULL == (Blink_Vid_Str = SLtt_tgetstr("mb"))) + && is_xterm) + Blink_Vid_Str = "\033[5m"; + + UnderLine_Vid_Str = SLtt_tgetstr("us"); + + Start_Alt_Chars_Str = SLtt_tgetstr ("as"); /* smacs */ + End_Alt_Chars_Str = SLtt_tgetstr ("ae"); /* rmacs */ + Enable_Alt_Char_Set = SLtt_tgetstr ("eA"); /* enacs */ + SLtt_Graphics_Char_Pairs = SLtt_tgetstr ("ac"); + + if (NULL == SLtt_Graphics_Char_Pairs) + { + /* make up for defective termcap/terminfo */ + if (Vt100_Like) + { + Start_Alt_Chars_Str = "\016"; + End_Alt_Chars_Str = "\017"; + Enable_Alt_Char_Set = "\033)0"; + } + } + + /* aixterm added by willi */ + if (is_xterm || !strncmp (term, "aixterm", 7)) + { + Start_Alt_Chars_Str = "\016"; + End_Alt_Chars_Str = "\017"; + Enable_Alt_Char_Set = "\033(B\033)0"; + } + + if ((SLtt_Graphics_Char_Pairs == NULL) && + ((Start_Alt_Chars_Str == NULL) || (End_Alt_Chars_Str == NULL))) + { + SLtt_Has_Alt_Charset = 0; + Enable_Alt_Char_Set = NULL; + } + else SLtt_Has_Alt_Charset = 1; + +#ifdef AMIGA + Enable_Alt_Char_Set = Start_Alt_Chars_Str = End_Alt_Chars_Str = NULL; +#endif + + /* status line capabilities */ + if ((SLtt_Has_Status_Line == -1) + && (0 != (SLtt_Has_Status_Line = TGETFLAG ("hs")))) + { + Disable_Status_line_Str = SLtt_tgetstr ("ds"); + Return_From_Status_Line_Str = SLtt_tgetstr ("fs"); + Goto_Status_Line_Str = SLtt_tgetstr ("ts"); + /* Status_Line_Esc_Ok = TGETFLAG("es"); */ + Num_Status_Line_Columns = SLtt_tgetnum ("ws"); + if (Num_Status_Line_Columns < 0) Num_Status_Line_Columns = 0; + } + + if (NULL == (Norm_Vid_Str = SLtt_tgetstr("me"))) + { + Norm_Vid_Str = SLtt_tgetstr("se"); + } + + Cursor_Invisible_Str = SLtt_tgetstr("vi"); + Cursor_Visible_Str = SLtt_tgetstr("ve"); + + Curs_F_Str = SLtt_tgetstr("RI"); + +# if 0 + if (NULL != Curs_F_Str) + { + Len_Curs_F_Str = strlen(Curs_F_Str); + } + else Len_Curs_F_Str = strlen(Curs_Pos_Str); +# endif + + Automatic_Margins = TGETFLAG ("am"); + /* No_Move_In_Standout = !TGETFLAG ("ms"); */ +# ifdef HP_GLITCH_CODE + Has_HP_Glitch = TGETFLAG ("xs"); +# else + Worthless_Highlight = TGETFLAG ("xs"); +# endif + + if (Worthless_Highlight == 0) + { /* Magic cookie glitch */ + Worthless_Highlight = (SLtt_tgetnum ("sg") > 0); + } + + if (Worthless_Highlight) + SLtt_Has_Alt_Charset = 0; + + Reset_Color_String = SLtt_tgetstr ("op"); + Color_Fg_Str = SLtt_tgetstr ("AF"); /* ANSI setaf */ + Color_Bg_Str = SLtt_tgetstr ("AB"); /* ANSI setbf */ + if ((Color_Fg_Str == NULL) || (Color_Bg_Str == NULL)) + { + Color_Fg_Str = SLtt_tgetstr ("Sf"); /* setf */ + Color_Bg_Str = SLtt_tgetstr ("Sb"); /* setb */ + } + + if ((Max_Terminfo_Colors = SLtt_tgetnum ("Co")) < 0) + Max_Terminfo_Colors = 8; + + if ((Color_Bg_Str != NULL) && (Color_Fg_Str != NULL)) + SLtt_Use_Ansi_Colors = 1; + else + { +#if 0 + Color_Fg_Str = "%?%p1%{7}%>%t\033[1;3%p1%{8}%m%dm%e\033[3%p1%dm%;"; + Color_Bg_Str = "%?%p1%{7}%>%t\033[5;4%p1%{8}%m%dm%e\033[4%p1%dm%;"; + Max_Terminfo_Colors = 16; +#else + Color_Fg_Str = "\033[3%dm"; + Color_Bg_Str = "\033[4%dm"; + Max_Terminfo_Colors = 8; +#endif + } + +#if SLTT_HAS_NON_BCE_SUPPORT + Can_Background_Color_Erase = TGETFLAG ("ut"); /* bce */ + /* Modern xterms have the BCE capability as well as the linux console */ + if (Can_Background_Color_Erase == 0) + { + Can_Background_Color_Erase = (Linux_Console +# if SLTT_XTERM_ALWAYS_BCE + || is_xterm +# endif + ); + } +#endif + get_color_info (); + + + if ((Cls_Str == NULL) + || (Curs_Pos_Str == NULL)) + return -2; + + return 0; +} + +#endif +/* Unix */ + +/* specific to vtxxx only */ +void SLtt_enable_cursor_keys (void) +{ +#ifdef __unix__ + if (Vt100_Like) +#endif + tt_write_string("\033=\033[?1l"); +} + +#ifdef VMS +int SLtt_initialize (char *term) +{ + SLtt_get_terminfo (); + return 0; +} + +void SLtt_get_terminfo () +{ + int zero = 0; + + Color_Fg_Str = "\033[3%dm"; + Color_Bg_Str = "\033[4%dm"; + Max_Terminfo_Colors = 8; + + get_color_info (); + + SLtt_set_term_vtxxx(&zero); + Start_Alt_Chars_Str = "\016"; + End_Alt_Chars_Str = "\017"; + SLtt_Has_Alt_Charset = 1; + SLtt_Graphics_Char_Pairs = "aaffgghhjjkkllmmnnooqqssttuuvvwwxx"; + Enable_Alt_Char_Set = "\033(B\033)0"; + SLtt_get_screen_size (); +} +#endif + +/* This sets term for vt102 terminals it parameter vt100 is 0. If vt100 + * is non-zero, set terminal appropriate for a only vt100 + * (no add line capability). */ + +void SLtt_set_term_vtxxx(int *vt100) +{ + Norm_Vid_Str = "\033[m"; + + Scroll_R_Str = "\033[%i%d;%dr"; + Cls_Str = "\033[2J\033[H"; + Rev_Vid_Str = "\033[7m"; + Bold_Vid_Str = "\033[1m"; + Blink_Vid_Str = "\033[5m"; + UnderLine_Vid_Str = "\033[4m"; + Del_Eol_Str = "\033[K"; + Del_Bol_Str = "\033[1K"; + Rev_Scroll_Str = "\033M"; + Curs_F_Str = "\033[%dC"; + /* Len_Curs_F_Str = 5; */ + Curs_Pos_Str = "\033[%i%d;%dH"; + if ((vt100 == NULL) || (*vt100 == 0)) + { + Ins_Mode_Str = "\033[4h"; + Eins_Mode_Str = "\033[4l"; + Del_Char_Str = "\033[P"; + Del_N_Lines_Str = "\033[%dM"; + Add_N_Lines_Str = "\033[%dL"; + SLtt_Term_Cannot_Insert = 0; + } + else + { + Del_N_Lines_Str = NULL; + Add_N_Lines_Str = NULL; + SLtt_Term_Cannot_Insert = 1; + } + SLtt_Term_Cannot_Scroll = 0; + /* No_Move_In_Standout = 0; */ +} + +int SLtt_init_video (void) +{ + /* send_string_to_term("\033[?6h"); */ + /* relative origin mode */ + tt_write_string (Term_Init_Str); + tt_write_string (Keypad_Init_Str); + SLtt_reset_scroll_region(); + SLtt_end_insert(); + tt_write_string (Enable_Alt_Char_Set); + Video_Initialized = 1; + return 0; +} + +int SLtt_reset_video (void) +{ + SLtt_goto_rc (SLtt_Screen_Rows - 1, 0); + Cursor_Set = 0; + SLtt_normal_video (); /* MSKermit requires this */ + tt_write_string(Norm_Vid_Str); + + Current_Fgbg = 0xFFFFFFFFU; + SLtt_set_alt_char_set (0); + if (SLtt_Use_Ansi_Colors) + { + if (Reset_Color_String == NULL) + { + SLtt_Char_Type attr; + if (-1 != make_color_fgbg (NULL, NULL, &attr)) + write_attributes (attr); + else tt_write_string ("\033[0m\033[m"); + } + else tt_write_string (Reset_Color_String); + Current_Fgbg = 0xFFFFFFFFU; + } + SLtt_erase_line (); + tt_write_string (Keypad_Reset_Str); + tt_write_string (Term_Reset_Str); + SLtt_flush_output (); + Video_Initialized = 0; + return 0; +} + +void SLtt_bold_video (void) +{ + tt_write_string (Bold_Vid_Str); +} + +int SLtt_set_mouse_mode (int mode, int force) +{ + char *term; + + if (force == 0) + { + if (NULL == (term = (char *) getenv("TERM"))) return -1; + if (strncmp ("xterm", term, 5)) + return -1; + } + + if (mode) + tt_write_string ("\033[?9h"); + else + tt_write_string ("\033[?9l"); + + return 0; +} + +void SLtt_disable_status_line (void) +{ + if (SLtt_Has_Status_Line > 0) + { + tt_write_string (Disable_Status_line_Str); + SLtt_flush_output (); + } +} + +int SLtt_write_to_status_line (char *s, int col) +{ + if ((SLtt_Has_Status_Line <= 0) + || (Goto_Status_Line_Str == NULL) + || (Return_From_Status_Line_Str == NULL)) + return -1; + + tt_printf (Goto_Status_Line_Str, col, 0); + tt_write_string (s); + tt_write_string (Return_From_Status_Line_Str); + return 0; +} + +void SLtt_get_screen_size (void) +{ +#ifdef VMS + int status, code; + unsigned short chan; + $DESCRIPTOR(dev_dsc, "SYS$INPUT:"); +#endif + int r = 0, c = 0; + +#ifdef TIOCGWINSZ + struct winsize wind_struct; + + do + { + if ((ioctl(1,TIOCGWINSZ,&wind_struct) == 0) + || (ioctl(0, TIOCGWINSZ, &wind_struct) == 0) + || (ioctl(2, TIOCGWINSZ, &wind_struct) == 0)) + { + c = (int) wind_struct.ws_col; + r = (int) wind_struct.ws_row; + break; + } + } + while (errno == EINTR); + +#endif + +#ifdef VMS + status = sys$assign(&dev_dsc,&chan,0,0,0); + if (status & 1) + { + code = DVI$_DEVBUFSIZ; + status = lib$getdvi(&code, &chan,0, &c, 0,0); + if (!(status & 1)) + c = 80; + code = DVI$_TT_PAGE; + status = lib$getdvi(&code, &chan,0, &r, 0,0); + if (!(status & 1)) + r = 24; + sys$dassgn(chan); + } +#endif + + if (r <= 0) + { + char *s = getenv ("LINES"); + if (s != NULL) r = atoi (s); + } + + if (c <= 0) + { + char *s = getenv ("COLUMNS"); + if (s != NULL) c = atoi (s); + } + + if (r <= 0) r = 24; + if (c <= 0) c = 80; +#if 0 + if ((r <= 0) || (r > 200)) r = 24; + if ((c <= 0) || (c > 250)) c = 80; +#endif + SLtt_Screen_Rows = r; + SLtt_Screen_Cols = c; +} + +#if SLTT_HAS_NON_BCE_SUPPORT +int _SLtt_get_bce_color_offset (void) +{ + if ((SLtt_Use_Ansi_Colors == 0) + || Can_Background_Color_Erase + || SLtt_Use_Blink_For_ACS) /* in this case, we cannot lose a color */ + Bce_Color_Offset = 0; + else + { + if (GET_BG(Ansi_Color_Map[0].fgbg) == SLSMG_COLOR_DEFAULT) + Bce_Color_Offset = 0; + else + Bce_Color_Offset = 1; + } + + return Bce_Color_Offset; +} +#endif diff --git a/mdk-stage1/slang/slerr.c b/mdk-stage1/slang/slerr.c new file mode 100644 index 000000000..139b3859b --- /dev/null +++ b/mdk-stage1/slang/slerr.c @@ -0,0 +1,181 @@ +/* error handling common to all routines. */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +void (*SLang_VMessage_Hook) (char *, va_list); +void (*SLang_Error_Hook)(char *); +void (*SLang_Exit_Error_Hook)(char *, va_list); +volatile int SLang_Error = 0; +char *SLang_Error_Message; +volatile int SLKeyBoard_Quit = 0; + +static char *get_error_string (void) +{ + char *str; + + if (!SLang_Error) SLang_Error = SL_UNKNOWN_ERROR; + if (SLang_Error_Message != NULL) str = SLang_Error_Message; + else switch(SLang_Error) + { + case SL_NOT_IMPLEMENTED: str = "Not Implemented"; break; + case SL_APPLICATION_ERROR: str = "Application Error"; break; + case SL_VARIABLE_UNINITIALIZED: str = "Variable Uninitialized"; break; + case SL_MALLOC_ERROR : str = "Malloc Error"; break; + case SL_INTERNAL_ERROR: str = "Internal Error"; break; + case SL_STACK_OVERFLOW: str = "Stack Overflow"; break; + case SL_STACK_UNDERFLOW: str = "Stack Underflow"; break; + case SL_INTRINSIC_ERROR: str = "Intrinsic Error"; break; + case SL_USER_BREAK: str = "User Break"; break; + case SL_UNDEFINED_NAME: str = "Undefined Name"; break; + case SL_SYNTAX_ERROR: str = "Syntax Error"; break; + case SL_DUPLICATE_DEFINITION: str = "Duplicate Definition"; break; + case SL_TYPE_MISMATCH: str = "Type Mismatch"; break; + case SL_READONLY_ERROR: str = "Variable is read-only"; break; + case SL_DIVIDE_ERROR: str = "Divide by zero"; break; + case SL_OBJ_NOPEN: str = "Object not opened"; break; + case SL_OBJ_UNKNOWN: str = "Object unknown"; break; + case SL_INVALID_PARM: str = "Invalid Parameter"; break; + case SL_TYPE_UNDEFINED_OP_ERROR: + str = "Operation not defined for datatype"; break; + case SL_USER_ERROR: + str = "User Error"; break; + case SL_USAGE_ERROR: + str = "Illegal usage of function"; + break; + case SL_FLOATING_EXCEPTION: + str = "Floating Point Exception"; + break; + case SL_UNKNOWN_ERROR: + default: str = "Unknown Error Code"; + } + + SLang_Error_Message = NULL; + return str; +} + +void SLang_doerror (char *error) +{ + char *str = NULL; + char *err; + char *malloced_err_buf; + char err_buf [1024]; + + malloced_err_buf = NULL; + + if (((SLang_Error == SL_USER_ERROR) + || (SLang_Error == SL_USAGE_ERROR)) + && (error != NULL) && (*error != 0)) + err = error; + else + { + char *sle = "S-Lang Error: "; + unsigned int len; + char *fmt; + + str = get_error_string (); + + fmt = "%s%s%s"; + if ((error == NULL) || (*error == 0)) + error = ""; + else if (SLang_Error == SL_UNKNOWN_ERROR) + /* Do not display an unknown error message if error is non-NULL */ + str = ""; + else + fmt = "%s%s: %s"; + + len = strlen (sle) + strlen (str) + strlen(error) + 1; + + err = err_buf; + if (len >= sizeof (err_buf)) + { + if (NULL == (malloced_err_buf = SLmalloc (len))) + err = NULL; + else + err = malloced_err_buf; + } + + if (err != NULL) sprintf (err, fmt, sle, str, error); + else err = "Out of memory"; + } + + if (SLang_Error_Hook == NULL) + { + fputs (err, stderr); + fputs("\r\n", stderr); + fflush (stderr); + } + else + (*SLang_Error_Hook)(err); + + SLfree (malloced_err_buf); +} + +void SLang_verror (int err_code, char *fmt, ...) +{ + va_list ap; + char err [1024]; + + if (err_code == 0) err_code = SL_INTRINSIC_ERROR; + if (SLang_Error == 0) SLang_Error = err_code; + + if (fmt != NULL) + { + va_start(ap, fmt); + (void) _SLvsnprintf (err, sizeof (err), fmt, ap); + fmt = err; + va_end(ap); + } + + SLang_doerror (fmt); +} + +void SLang_exit_error (char *fmt, ...) +{ + va_list ap; + + va_start (ap, fmt); + if (SLang_Exit_Error_Hook != NULL) + { + (*SLang_Exit_Error_Hook) (fmt, ap); + exit (1); + } + + if (fmt != NULL) + { + vfprintf (stderr, fmt, ap); + fputs ("\r\n", stderr); + fflush (stderr); + } + va_end (ap); + + exit (1); +} + +void SLang_vmessage (char *fmt, ...) +{ + va_list ap; + + if (fmt == NULL) + return; + + va_start (ap, fmt); + + if (SLang_VMessage_Hook != NULL) + (*SLang_VMessage_Hook) (fmt, ap); + else + { + vfprintf (stdout, fmt, ap); + fputs ("\r\n", stdout); + } + + va_end (ap); +} diff --git a/mdk-stage1/slang/slerrno.c b/mdk-stage1/slang/slerrno.c new file mode 100644 index 000000000..662fadde1 --- /dev/null +++ b/mdk-stage1/slang/slerrno.c @@ -0,0 +1,219 @@ +/* The point of this file is to handle errno values in a system independent + * way so that they may be used in slang scripts. + */ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include <errno.h> +#include "slang.h" +#include "_slang.h" + +typedef struct +{ + char *msg; + int sys_errno; + char *symbolic_name; +} +Errno_Map_Type; + +static Errno_Map_Type Errno_Map [] = +{ +#ifndef EPERM +# define EPERM -1 +#endif + {"Not owner", EPERM, "EPERM"}, +#ifndef ENOENT +# define ENOENT -1 +#endif + {"No such file or directory", ENOENT, "ENOENT"}, +#ifndef ESRCH +# define ESRCH -1 +#endif + {"No such process", ESRCH, "ESRCH"}, +#ifndef EINTR +# define EINTR -1 +#endif + {"Interrupted system call", EINTR, "EINTR"}, +#ifndef EIO +# define EIO -1 +#endif + {"I/O error", EIO, "EIO"}, +#ifndef ENXIO +# define ENXIO -1 +#endif + {"No such device or address", ENXIO, "ENXIO"}, +#ifndef E2BIG +# define E2BIG -1 +#endif + {"Arg list too long", E2BIG, "E2BIG"}, +#ifndef ENOEXEC +# define ENOEXEC -1 +#endif + {"Exec format error", ENOEXEC,"ENOEXEC"}, +#ifndef EBADF +# define EBADF -1 +#endif + {"Bad file number", EBADF, "EBADF"}, +#ifndef ECHILD +# define ECHILD -1 +#endif + {"No children", ECHILD, "ECHILD"}, +#ifndef EAGAIN +# define EAGAIN -1 +#endif + {"Try again", EAGAIN, "EAGAIN"}, +#ifndef ENOMEM +# define ENOMEM -1 +#endif + {"Not enough core", ENOMEM, "ENOMEM"}, +#ifndef EACCES +# define EACCES -1 +#endif + {"Permission denied", EACCES, "EACCES"}, +#ifndef EFAULT +# define EFAULT -1 +#endif + {"Bad address", EFAULT, "EFAULT"}, +#ifndef ENOTBLK +# define ENOTBLK -1 +#endif + {"Block device required", ENOTBLK, "ENOTBLK"}, +#ifndef EBUSY +# define EBUSY -1 +#endif + {"Mount device busy", EBUSY, "EBUSY"}, +#ifndef EEXIST +# define EEXIST -1 +#endif + {"File exists", EEXIST, "EEXIST"}, +#ifndef EXDEV +# define EXDEV -1 +#endif + {"Cross-device link", EXDEV, "EXDEV"}, +#ifndef ENODEV +# define ENODEV -1 +#endif + {"No such device", ENODEV, "ENODEV"}, +#ifndef ENOTDIR +# define ENOTDIR -1 +#endif + {"Not a directory", ENOTDIR, "ENOTDIR"}, +#ifndef EISDIR +# define EISDIR -1 +#endif + {"Is a directory", EISDIR, "EISDIR"}, +#ifndef EINVAL +# define EINVAL -1 +#endif + {"Invalid argument", EINVAL, "EINVAL"}, +#ifndef ENFILE +# define ENFILE -1 +#endif + {"File table overflow", ENFILE, "ENFILE"}, +#ifndef EMFILE +# define EMFILE -1 +#endif + {"Too many open files", EMFILE, "EMFILE"}, +#ifndef ENOTTY +# define ENOTTY -1 +#endif + {"Not a typewriter", ENOTTY, "ENOTTY"}, +#ifndef ETXTBSY +# define ETXTBSY -1 +#endif + {"Text file busy", ETXTBSY, "ETXTBSY"}, +#ifndef EFBIG +# define EFBIG -1 +#endif + {"File too large", EFBIG, "EFBIG"}, +#ifndef ENOSPC +# define ENOSPC -1 +#endif + {"No space left on device", ENOSPC, "ENOSPC"}, +#ifndef ESPIPE +# define ESPIPE -1 +#endif + {"Illegal seek", ESPIPE, "ESPIPE"}, +#ifndef EROFS +# define EROFS -1 +#endif + {"Read-only file system", EROFS, "EROFS"}, +#ifndef EMLINK +# define EMLINK -1 +#endif + {"Too many links", EMLINK, "EMLINK"}, +#ifndef EPIPE +# define EPIPE -1 +#endif + {"Broken pipe", EPIPE, "EPIPE"}, +#ifndef ELOOP +# define ELOOP -1 +#endif + {"Too many levels of symbolic links",ELOOP, "ELOOP"}, +#ifndef ENAMETOOLONG +# define ENAMETOOLONG -1 +#endif + {"File name too long", ENAMETOOLONG, "ENAMETOOLONG"}, + + {NULL, 0, NULL} +}; + +int _SLerrno_errno; + +int SLerrno_set_errno (int sys_errno) +{ + _SLerrno_errno = sys_errno; + return 0; +} + +char *SLerrno_strerror (int sys_errno) +{ + Errno_Map_Type *e; + + e = Errno_Map; + while (e->msg != NULL) + { + if (e->sys_errno == sys_errno) + return e->msg; + + e++; + } + + if (sys_errno == SL_ERRNO_NOT_IMPLEMENTED) + return "System call not available for this platform"; + + return "Unknown error"; +} + +static char *intrin_errno_string (int *sys_errno) +{ + return SLerrno_strerror (*sys_errno); +} + +int _SLerrno_init (void) +{ + static Errno_Map_Type *e; + + if (e != NULL) /* already initialized */ + return 0; + + if ((-1 == SLadd_intrinsic_function ("errno_string", (FVOID_STAR) intrin_errno_string, + SLANG_STRING_TYPE, 1, SLANG_INT_TYPE)) + || (-1 == SLadd_intrinsic_variable ("errno", (VOID_STAR)&_SLerrno_errno, SLANG_INT_TYPE, 1))) + return -1; + + e = Errno_Map; + while (e->msg != NULL) + { + if (-1 == SLadd_intrinsic_variable (e->symbolic_name, (VOID_STAR) &e->sys_errno, SLANG_INT_TYPE, 1)) + return -1; + e++; + } + + return 0; +} diff --git a/mdk-stage1/slang/slgetkey.c b/mdk-stage1/slang/slgetkey.c new file mode 100644 index 000000000..2f2914f07 --- /dev/null +++ b/mdk-stage1/slang/slgetkey.c @@ -0,0 +1,306 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +unsigned int SLang_Input_Buffer_Len = 0; +unsigned char SLang_Input_Buffer [SL_MAX_INPUT_BUFFER_LEN]; + +int SLang_Abort_Char = 7; +int SLang_Ignore_User_Abort = 0; + +/* This has the effect of mapping all characters in the range 128-169 to + * ESC [ something + */ + +unsigned int SLang_getkey (void) +{ + unsigned int imax; + unsigned int ch; + + if (SLang_Input_Buffer_Len) + { + ch = (unsigned int) *SLang_Input_Buffer; + SLang_Input_Buffer_Len--; + imax = SLang_Input_Buffer_Len; + + SLMEMCPY ((char *) SLang_Input_Buffer, + (char *) (SLang_Input_Buffer + 1), imax); + } + else if (SLANG_GETKEY_ERROR == (ch = _SLsys_getkey ())) return ch; + +#if _SLANG_MAP_VTXXX_8BIT +# if !defined(IBMPC_SYSTEM) + if (ch & 0x80) + { + unsigned char i; + i = (unsigned char) (ch & 0x7F); + if (i < ' ') + { + i += 64; + SLang_ungetkey (i); + ch = 27; + } + } +# endif +#endif + return(ch); +} + +int SLang_ungetkey_string (unsigned char *s, unsigned int n) +{ + register unsigned char *bmax, *b, *b1; + if (SLang_Input_Buffer_Len + n + 3 > SL_MAX_INPUT_BUFFER_LEN) + return -1; + + b = SLang_Input_Buffer; + bmax = (b - 1) + SLang_Input_Buffer_Len; + b1 = bmax + n; + while (bmax >= b) *b1-- = *bmax--; + bmax = b + n; + while (b < bmax) *b++ = *s++; + SLang_Input_Buffer_Len += n; + return 0; +} + +int SLang_buffer_keystring (unsigned char *s, unsigned int n) +{ + + if (n + SLang_Input_Buffer_Len + 3 > SL_MAX_INPUT_BUFFER_LEN) return -1; + + SLMEMCPY ((char *) SLang_Input_Buffer + SLang_Input_Buffer_Len, + (char *) s, n); + SLang_Input_Buffer_Len += n; + return 0; +} + +int SLang_ungetkey (unsigned char ch) +{ + return SLang_ungetkey_string(&ch, 1); +} + +int SLang_input_pending (int tsecs) +{ + int n; + unsigned char c; + if (SLang_Input_Buffer_Len) return (int) SLang_Input_Buffer_Len; + + n = _SLsys_input_pending (tsecs); + + if (n <= 0) return 0; + + c = (unsigned char) SLang_getkey (); + SLang_ungetkey_string (&c, 1); + + return n; +} + +void SLang_flush_input (void) +{ + int quit = SLKeyBoard_Quit; + + SLang_Input_Buffer_Len = 0; + SLKeyBoard_Quit = 0; + while (_SLsys_input_pending (0) > 0) + { + (void) _SLsys_getkey (); + /* Set this to 0 because _SLsys_getkey may stuff keyboard buffer if + * key sends key sequence (OS/2, DOS, maybe VMS). + */ + SLang_Input_Buffer_Len = 0; + } + SLKeyBoard_Quit = quit; +} + +#ifdef IBMPC_SYSTEM +static int Map_To_ANSI; +int SLgetkey_map_to_ansi (int enable) +{ + Map_To_ANSI = enable; + return 0; +} + +static int convert_scancode (unsigned int scan, + unsigned int shift, + int getkey, + unsigned int *ret_key) +{ + unsigned char buf[16]; + unsigned char *b; + unsigned char end; + int is_arrow; + + shift &= (_SLTT_KEY_ALT|_SLTT_KEY_SHIFT|_SLTT_KEY_CTRL); + + b = buf; + if (_SLTT_KEY_ALT == shift) + { + shift = 0; + *b++ = 27; + } + *b++ = 27; + *b++ = '['; + + is_arrow = 0; + end = '~'; + if (shift) + { + if (shift == _SLTT_KEY_CTRL) + end = '^'; + else if (shift == _SLTT_KEY_SHIFT) + end = '$'; + else shift = 0; + } + + /* These mappings correspond to what rxvt produces under Linux */ + switch (scan & 0xFF) + { + default: + return -1; + + case 0x47: /* home */ + *b++ = '1'; + break; + case 0x48: /* up */ + end = 'A'; + is_arrow = 1; + break; + case 0x49: /* PgUp */ + *b++ = '5'; + break; + case 0x4B: /* Left */ + end = 'D'; + is_arrow = 1; + break; + case 0x4D: /* Right */ + end = 'C'; + is_arrow = 1; + break; + case 0x4F: /* End */ + *b++ = '4'; + break; + case 0x50: /* Down */ + end = 'B'; + is_arrow = 1; + break; + case 0x51: /* PgDn */ + *b++ = '6'; + break; + case 0x52: /* Insert */ + *b++ = '2'; + break; + case 0x53: /* Delete */ + *b++ = '3'; + break; + case ';': /* F1 */ + *b++ = '1'; + *b++ = '1'; + break; + case '<': /* F2 */ + *b++ = '1'; + *b++ = '2'; + break; + case '=': /* F3 */ + *b++ = '1'; + *b++ = '3'; + break; + + case '>': /* F4 */ + *b++ = '1'; + *b++ = '4'; + break; + + case '?': /* F5 */ + *b++ = '1'; + *b++ = '5'; + break; + + case '@': /* F6 */ + *b++ = '1'; + *b++ = '7'; + break; + + case 'A': /* F7 */ + *b++ = '1'; + *b++ = '8'; + break; + + case 'B': /* F8 */ + *b++ = '1'; + *b++ = '9'; + break; + + case 'C': /* F9 */ + *b++ = '2'; + *b++ = '0'; + break; + + case 'D': /* F10 */ + *b++ = '2'; + *b++ = '1'; + break; + + case 0x57: /* F11 */ + *b++ = '2'; + *b++ = '3'; + break; + + case 0x58: /* F12 */ + *b++ = '2'; + *b++ = '4'; + break; + } + + if (is_arrow && shift) + { + if (shift == _SLTT_KEY_CTRL) + end &= 0x1F; + else + end |= 0x20; + } + *b++ = end; + + if (getkey) + { + (void) SLang_buffer_keystring (buf + 1, (unsigned int) (b - (buf + 1))); + *ret_key = buf[0]; + return 0; + } + + (void) SLang_buffer_keystring (buf, (unsigned int) (b - buf)); + return 0; +} + + +unsigned int _SLpc_convert_scancode (unsigned int scan, + unsigned int shift, + int getkey) +{ + unsigned char buf[16]; + + if (Map_To_ANSI) + { + if (0 == convert_scancode (scan, shift, getkey, &scan)) + return scan; + } + + if (getkey) + { + buf[0] = scan & 0xFF; + SLang_buffer_keystring (buf, 1); + return (scan >> 8) & 0xFF; + } + buf[0] = (scan >> 8) & 0xFF; + buf[1] = scan & 0xFF; + (void) SLang_buffer_keystring (buf, 2); + return 0; +} + +#endif diff --git a/mdk-stage1/slang/slimport.c b/mdk-stage1/slang/slimport.c new file mode 100644 index 000000000..44b4b25e1 --- /dev/null +++ b/mdk-stage1/slang/slimport.c @@ -0,0 +1,281 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#define SLANG_HAS_DYNAMIC_LINKING 1 + +#ifndef HAVE_DLFCN_H +# undef SLANG_HAS_DYNAMIC_LINKING +# define SLANG_HAS_DYNAMIC_LINKING 0 +#endif + +/* The rest of this file is in the if block */ +#if SLANG_HAS_DYNAMIC_LINKING + +#ifdef HAVE_DLFCN_H +# include <dlfcn.h> +#endif + +static char *Module_Path; +#define MODULE_PATH_ENV_NAME "SLANG_MODULE_PATH" +#ifndef MODULE_INSTALL_DIR +# define MODULE_INSTALL_DIR "/usr/local/lib/slang/modules" +#endif + +typedef struct _Handle_Type +{ + struct _Handle_Type *next; + char *name; + VOID_STAR handle; + void (*deinit_fun) (void); +} +Handle_Type; + +static Handle_Type *Handle_List; + +static void delete_handles (void) +{ + while (Handle_List != NULL) + { + Handle_Type *next = Handle_List->next; + + if (Handle_List->deinit_fun != NULL) + Handle_List->deinit_fun (); + (void) dlclose (Handle_List->handle); + SLang_free_slstring (Handle_List->name); + SLfree ((char *)Handle_List); + Handle_List = next; + } +} + +static Handle_Type *save_handle (char *name, VOID_STAR h, void (*df)(void)) +{ + Handle_Type *l; + + l = (Handle_Type *) SLmalloc (sizeof (Handle_Type)); + if (l == NULL) + return NULL; + memset ((char *) l, 0, sizeof(Handle_Type)); + if (NULL == (l->name = SLang_create_slstring (name))) + { + SLfree ((char *) l); + return NULL; + } + l->handle = h; + l->next = Handle_List; + l->deinit_fun = df; + Handle_List = l; + + return l; +} + +static Handle_Type *find_handle (char *name) +{ + Handle_Type *l; + + l = Handle_List; + while (l != NULL) + { + if (0 == strcmp (l->name, name)) + break; + l = l->next; + } + return l; +} + +static int import_from_library (char *name, + char *init_fun_name, char *deinit_fun_name, + char *file, + char *ns, + char *ns_init_fun_name) +{ + VOID_STAR handle; + int (*init_fun) (void); + int (*ns_init_fun) (char *); + void (*deinit_fun) (void); + char *err; + char filebuf[1024]; + char *fun_name; + + if (NULL != find_handle (name)) + return 0; /* already loaded */ + + while (1) + { +#ifndef RTLD_GLOBAL +# define RTLD_GLOBAL 0 +#endif +#ifdef RTLD_NOW + handle = (VOID_STAR) dlopen (file, RTLD_NOW | RTLD_GLOBAL); +#else + handle = (VOID_STAR) dlopen (file, RTLD_LAZY | RTLD_GLOBAL); +#endif + + if (handle != NULL) + break; + + if (NULL == strchr (file, '/')) + { + _SLsnprintf (filebuf, sizeof (filebuf), "./%s", file); + file = filebuf; + continue; + } + + if (NULL == (err = (char *) dlerror ())) + err = "UNKNOWN"; + + SLang_verror (SL_INTRINSIC_ERROR, + "Error linking to %s: %s", file, err); + return -1; + } + + fun_name = ns_init_fun_name; + ns_init_fun = (int (*)(char *)) dlsym (handle, fun_name); + if (ns_init_fun == NULL) + { + if ((ns != NULL) + && (0 != strcmp (ns, "Global"))) + goto return_error; + + fun_name = init_fun_name; + init_fun = (int (*)(void)) dlsym (handle, fun_name); + if (init_fun == NULL) + goto return_error; + + if (-1 == (*init_fun) ()) + { + dlclose (handle); + return -1; + } + } + else if (-1 == (*ns_init_fun) (ns)) + { + dlclose (handle); + return -1; + } + + + deinit_fun = (void (*)(void)) dlsym (handle, deinit_fun_name); + + (void) save_handle (name, handle, deinit_fun); + return 0; + + return_error: + + if (NULL == (err = (char *) dlerror ())) + err = "UNKNOWN"; + + dlclose (handle); + SLang_verror (SL_INTRINSIC_ERROR, + "Unable to get symbol %s from %s: %s", + name, file, err); + return -1; +} + +static void import_module (void) +{ + char module_name[256]; + char symbol_name[256]; + char deinit_name[256]; + char ns_init_name[256]; + char *path; + char *file; + char *module; + char *ns = NULL; + + if (SLang_Num_Function_Args == 2) + { + if (-1 == SLang_pop_slstring (&ns)) + return; + } + + if (-1 == SLang_pop_slstring (&module)) + { + SLang_free_slstring (ns); /* NULL ok */ + return; + } + + _SLsnprintf (symbol_name, sizeof(symbol_name), "init_%s_module", module); + _SLsnprintf (module_name, sizeof(module_name), "%s-module.so", module); + _SLsnprintf (deinit_name, sizeof(deinit_name), "deinit_%s_module", module); + _SLsnprintf (ns_init_name, sizeof (ns_init_name), "init_%s_module_ns", module); + + if (Module_Path != NULL) + file = SLpath_find_file_in_path (Module_Path, module_name); + else file = NULL; + + if ((file == NULL) + && (NULL != (path = getenv (MODULE_PATH_ENV_NAME)))) + file = SLpath_find_file_in_path (path, module_name); + + if (file == NULL) + file = SLpath_find_file_in_path (MODULE_INSTALL_DIR, module_name); + + if (file != NULL) + { + (void) import_from_library (symbol_name, symbol_name, deinit_name, file, ns, ns_init_name); + SLfree (file); + } + else + { + /* Maybe the system loader can find it in LD_LIBRARY_PATH */ + (void) import_from_library (symbol_name, symbol_name, deinit_name, module_name, ns, ns_init_name); + } +} + +static void set_import_module_path (char *path) +{ + (void) SLang_set_module_load_path (path); +} + +static char *get_import_module_path (void) +{ + char *path; + if (Module_Path != NULL) + return Module_Path; + if (NULL != (path = getenv (MODULE_PATH_ENV_NAME))) + return path; + return MODULE_INSTALL_DIR; +} + +static SLang_Intrin_Fun_Type Module_Intrins [] = +{ + MAKE_INTRINSIC_0("import", import_module, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("set_import_module_path", set_import_module_path, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("get_import_module_path", get_import_module_path, SLANG_STRING_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +#endif /* SLANG_HAS_DYNAMIC_LINKING */ + +int SLang_set_module_load_path (char *path) +{ +#if SLANG_HAS_DYNAMIC_LINKING + if (NULL == (path = SLang_create_slstring (path))) + return -1; + SLang_free_slstring (Module_Path); + Module_Path = path; + return 0; +#else + (void) path; + return -1; +#endif +} + +int SLang_init_import (void) +{ +#if SLANG_HAS_DYNAMIC_LINKING + (void) SLang_add_cleanup_function (delete_handles); + return SLadd_intrin_fun_table (Module_Intrins, "__IMPORT__"); +#else + return 0; +#endif +} diff --git a/mdk-stage1/slang/slinclud.h b/mdk-stage1/slang/slinclud.h new file mode 100644 index 000000000..d60a4423e --- /dev/null +++ b/mdk-stage1/slang/slinclud.h @@ -0,0 +1,26 @@ +#ifndef _SLANG_INCLUDE_H_ +#define _SLANG_INCLUDE_H_ + +#include "config.h" +#include "sl-feat.h" + +#include <stdio.h> +#include <string.h> + +#ifdef HAVE_STDLIB_H +# include <stdlib.h> +#endif + +#ifdef HAVE_UNISTD_H +# include <unistd.h> +#endif + +#ifdef HAVE_MALLOC_H +# include <malloc.h> +#endif + +#ifdef HAVE_MEMORY_H +# include <memory.h> +#endif + +#endif /* _SLANG_INCLUDE_H_ */ diff --git a/mdk-stage1/slang/slintall.c b/mdk-stage1/slang/slintall.c new file mode 100644 index 000000000..a66b9d6d2 --- /dev/null +++ b/mdk-stage1/slang/slintall.c @@ -0,0 +1,27 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +int SLang_init_all (void) +{ + if ((-1 == SLang_init_slang ()) + || (-1 == SLang_init_slmath ()) + || (-1 == SLang_init_posix_dir ()) + || (-1 == SLang_init_posix_process ()) + || (-1 == SLang_init_stdio ()) + || (-1 == SLang_init_array ()) + || (-1 == SLang_init_posix_io ()) + || (-1 == SLang_init_ospath ()) + ) + return -1; + + return 0; +} + diff --git a/mdk-stage1/slang/slistruc.c b/mdk-stage1/slang/slistruc.c new file mode 100644 index 000000000..06b8fd6ff --- /dev/null +++ b/mdk-stage1/slang/slistruc.c @@ -0,0 +1,218 @@ +/* Intrinsic Structure type implementation */ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* Intrinsic structures */ + +typedef struct +{ + char *name; + VOID_STAR addr; + SLang_IStruct_Field_Type *fields; +} +_SLang_IStruct_Type; + +static SLang_IStruct_Field_Type *istruct_pop_field (char *name, int no_readonly, VOID_STAR *addr) +{ + _SLang_IStruct_Type *s; + SLang_IStruct_Field_Type *f; + char *struct_addr; + + /* Note: There is no need to free this object */ + if (-1 == SLclass_pop_ptr_obj (SLANG_ISTRUCT_TYPE, (VOID_STAR *) &s)) + return NULL; + + if (NULL == (struct_addr = *(char **)s->addr)) + { + SLang_verror (SL_INTRINSIC_ERROR, + "%s is NULL. Unable to access field", s->name); + return NULL; + } + + f = s->fields; + while (f->field_name != NULL) + { + /* Since both these are slstrings, just test pointers */ + if (f->field_name != name) + { + f++; + continue; + } + + if (no_readonly && f->read_only) + { + SLang_verror (SL_READONLY_ERROR, + "%s.%s is read-only", s->name, name); + return NULL; + } + + *addr = (VOID_STAR) (struct_addr + f->offset); + return f; + } + + SLang_verror (SL_TYPE_MISMATCH, + "%s has no field called %s", s->name, name); + return NULL; +} + +static int istruct_sget (unsigned char type, char *name) +{ + SLang_IStruct_Field_Type *f; + VOID_STAR addr; + SLang_Class_Type *cl; + + if (NULL == (f = istruct_pop_field (name, 0, &addr))) + return -1; + + type = f->type; + cl = _SLclass_get_class (type); + + return (cl->cl_push_intrinsic)(f->type, addr); +} + +static int istruct_sput (unsigned char type, char *name) +{ + SLang_IStruct_Field_Type *f; + VOID_STAR addr; + SLang_Class_Type *cl; + + if (NULL == (f = istruct_pop_field (name, 1, &addr))) + return -1; + + type = f->type; + cl = _SLclass_get_class (type); + + return (*cl->cl_pop) (type, addr); +} + +static int istruct_push (unsigned char type, VOID_STAR ptr) +{ + _SLang_IStruct_Type *s; + + s = *(_SLang_IStruct_Type **) ptr; + if ((s == NULL) + || (s->addr == NULL) + || (*(char **) s->addr == NULL)) + return SLang_push_null (); + + return SLclass_push_ptr_obj (type, (VOID_STAR) s); +} + +static int istruct_pop (unsigned char type, VOID_STAR ptr) +{ + return SLclass_pop_ptr_obj (type, (VOID_STAR *)ptr); +} + +static void istruct_destroy (unsigned char type, VOID_STAR ptr) +{ + (void) type; + (void) ptr; +} + +/* Intrinsic struct objects are not stored in a variable. So, the address that + * is passed here is actually a pointer to the struct. So, pass its address + * to istruct_push since v is a variable. Confusing, n'est pas? + */ +static int istruct_push_intrinsic (unsigned char type, VOID_STAR v) +{ + return istruct_push (type, (VOID_STAR) &v); +} + +static int init_intrin_struct (void) +{ + SLang_Class_Type *cl; + static int initialized; + + if (initialized) + return 0; + + if (NULL == (cl = SLclass_allocate_class ("IStruct_Type"))) + return -1; + + cl->cl_pop = istruct_pop; + cl->cl_push = istruct_push; + cl->cl_sget = istruct_sget; + cl->cl_sput = istruct_sput; + cl->cl_destroy = istruct_destroy; + cl->cl_push_intrinsic = istruct_push_intrinsic; + + if (-1 == SLclass_register_class (cl, SLANG_ISTRUCT_TYPE, sizeof (_SLang_IStruct_Type *), + SLANG_CLASS_TYPE_PTR)) + return -1; + + initialized = 1; + return 0; +} + +int SLadd_istruct_table (SLang_IStruct_Field_Type *fields, VOID_STAR addr, char *name) +{ + _SLang_IStruct_Type *s; + SLang_IStruct_Field_Type *f; + + if (-1 == init_intrin_struct ()) + return -1; + + if (addr == NULL) + { + SLang_verror (SL_INVALID_PARM, + "SLadd_istruct_table: address must be non-NULL"); + return -1; + } + + if (fields == NULL) + return -1; + + /* Make the field names slstrings so that only the pointers need to be + * compared. However, this table may have been already been added for + * another instance of the intrinsic object. So, check for the presence + * of an slstring. + */ + f = fields; + while (f->field_name != NULL) + { + char *fname; + + fname = SLang_create_slstring (f->field_name); + if (fname == NULL) + return -1; + + /* Here is the check for the slstring */ + if (f->field_name == fname) + SLang_free_slstring (fname); + else /* replace string literal with slstring */ + f->field_name = fname; + + f++; + } + + s = (_SLang_IStruct_Type *)SLmalloc (sizeof (_SLang_IStruct_Type)); + if (s == NULL) + return -1; + + memset ((char *)s, 0, sizeof (_SLang_IStruct_Type)); + if (NULL == (s->name = SLang_create_slstring (name))) + { + SLfree ((char *) s); + return -1; + } + + s->addr = addr; + s->fields = fields; + + if (-1 == SLadd_intrinsic_variable (name, (VOID_STAR) s, SLANG_ISTRUCT_TYPE, 1)) + { + SLang_free_slstring (s->name); + SLfree ((char *) s); + return -1; + } + + return 0; +} diff --git a/mdk-stage1/slang/slkeymap.c b/mdk-stage1/slang/slkeymap.c new file mode 100644 index 000000000..dff65433e --- /dev/null +++ b/mdk-stage1/slang/slkeymap.c @@ -0,0 +1,596 @@ +/* Keymap routines for SLang. The role of these keymap routines is simple: + * Just read keys from the tty and return a pointer to a keymap structure. + * That is, a keymap is simple a mapping of strings (keys from tty) to + * structures. Also included are routines for managing the keymaps. + */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* We need a define a rule for upperand lower case chars that user cannot + change! This could be a problem for international chars! */ + +#define UPPER_CASE_KEY(x) (((x) >= 'a') && ((x) <= 'z') ? (x) - 32 : (x)) +#define LOWER_CASE_KEY(x) (((x) >= 'A') && ((x) <= 'Z') ? (x) + 32 : (x)) + +int SLang_Key_TimeOut_Flag = 0; /* true if more than 1 sec has elapsed + without key in multikey sequence */ + +int SLang_Last_Key_Char; + +SLKeyMap_List_Type SLKeyMap_List[SLANG_MAX_KEYMAPS]; + +static SLang_Key_Type *malloc_key(unsigned char *str) +{ + SLang_Key_Type *neew; + + if (NULL == (neew = (SLang_Key_Type *) SLmalloc(sizeof(SLang_Key_Type)))) + return NULL; + + SLMEMSET ((char *) neew, 0, sizeof (SLang_Key_Type)); + SLMEMCPY((char *) neew->str, (char *) str, (unsigned int) *str); + return(neew); +} + +static SLKeyMap_List_Type *add_keymap (char *name, SLang_Key_Type *map) +{ + int i; + + for (i = 0; i < SLANG_MAX_KEYMAPS; i++) + { + if (SLKeyMap_List[i].keymap == NULL) + { + if (NULL == (name = SLang_create_slstring (name))) + return NULL; + + SLKeyMap_List[i].keymap = map; + SLKeyMap_List[i].name = name; + return &SLKeyMap_List[i]; + } + } + SLang_Error = SL_UNKNOWN_ERROR; + /* SLang_doerror ("Keymap quota exceeded."); */ + return NULL; +} + +FVOID_STAR SLang_find_key_function(char *name, SLKeyMap_List_Type *keymap) +{ + SLKeymap_Function_Type *fp = keymap -> functions; + char ch = *name; + + while ((fp != NULL) && (fp->name != NULL)) + { + if ((ch == *fp->name) + && (0 == strcmp(fp->name, name))) + return (FVOID_STAR) fp->f; + + fp++; + } + return NULL; +} + +#ifdef REAL_UNIX_SYSTEM +/* Expand termcap string specified by s. s as passed will have the format: + * "XY)..." where XY represents a termcap keyname. + */ +static char *process_termcap_string (char *s, char *str, int *ip, int imax) +{ + char c[3], *val; + int i; + + if ((0 == (c[0] = s[0])) + || (0 == (c[1] = s[1])) + || (s[2] != ')')) + { + SLang_verror (SL_SYNTAX_ERROR, "setkey: ^(%s is badly formed", s); + return NULL; + } + s += 3; + + c[2] = 0; + if ((NULL == (val = SLtt_tgetstr (c))) + || (*val == 0)) + return NULL; + + i = *ip; + while ((i < imax) && (*val != 0)) + { + str[i++] = *val++; + } + *ip = i; + + return s; +} +#endif + +/* convert things like "^A" to 1 etc... The 0th char is the strlen INCLUDING + * the length character itself. + */ +char *SLang_process_keystring(char *s) +{ + /* FIXME: v2.0, make this thread safe */ + static char str[32]; + unsigned char ch; + int i; + + i = 1; + while (*s != 0) + { + ch = (unsigned char) *s++; + if (ch == '^') + { + ch = *s++; + if (ch == 0) + { + if (i < 32) + str[i++] = '^'; + break; + } +#ifdef REAL_UNIX_SYSTEM + if (ch == '(') + { + s = process_termcap_string (s, str, &i, 32); + if (s == NULL) + { + str[0] = 1; + return str; + } + continue; + } +#endif + ch = UPPER_CASE_KEY(ch); + if (ch == '?') ch = 127; else ch = ch - 'A' + 1; + } + + if (i >= 32) break; + str[i++] = ch; + } + + if (i > SLANG_MAX_KEYMAP_KEY_SEQ) + { + SLang_verror (SL_INVALID_PARM, "Key sequence is too long"); + return NULL; + } + + str[0] = i; + return(str); +} + +static int key_string_compare (unsigned char *a, unsigned char *b, unsigned int len) +{ + unsigned char *amax = a + len; + int cha, chb, cha_up, chb_up; + + while (a < amax) + { + cha = *a++; + chb = *b++; + + if (cha == chb) continue; + + cha_up = UPPER_CASE_KEY(cha); + chb_up = UPPER_CASE_KEY(chb); + + if (cha_up == chb_up) + { + /* Use case-sensitive result. */ + return cha - chb; + } + /* Use case-insensitive result. */ + return cha_up - chb_up; + } + return 0; +} + +static char *Define_Key_Error = "Inconsistency in define key."; + +/* This function also performs an insertion in an ordered way. */ +static int find_the_key (char *s, SLKeyMap_List_Type *kml, SLang_Key_Type **keyp) +{ + unsigned char ch; + unsigned int str_len; + SLang_Key_Type *key, *last, *neew; + unsigned char *str; + + *keyp = NULL; + + if (NULL == (str = (unsigned char *) SLang_process_keystring(s))) + return -2; + + if (1 == (str_len = str[0])) + return 0; + + ch = str[1]; + key = kml->keymap + ch; + + if (str_len == 2) + { + if (key->next != NULL) + { + SLang_doerror (Define_Key_Error); + return -2; + } + + if (key->type == SLKEY_F_INTERPRET) + SLang_free_slstring (key->f.s); + + key->str[0] = str_len; + key->str[1] = ch; + + *keyp = key; + return 0; + } + + /* insert the key definition */ + while (1) + { + int cmp; + unsigned int key_len, len; + + last = key; + key = key->next; + + if ((key != NULL) && (key->str != NULL)) + { + len = key_len = key->str[0]; + if (len > str_len) len = str_len; + + cmp = key_string_compare (str + 1, key->str + 1, len - 1); + + if (cmp > 0) + continue; + + if (cmp == 0) + { + if (key_len != str_len) + { + SLang_doerror (Define_Key_Error); + return -2; + } + + if (key->type == SLKEY_F_INTERPRET) + SLang_free_slstring (key->f.s); + + *keyp = key; + return 0; + } + /* Drop to cmp < 0 case */ + } + + if (NULL == (neew = malloc_key(str))) return -1; + + neew -> next = key; + last -> next = neew; + + *keyp = neew; + return 0; + } +} + +/* returns -2 if inconsistent, -1 if malloc error, 0 upon success */ +int SLkm_define_key (char *s, FVOID_STAR f, SLKeyMap_List_Type *kml) +{ + SLang_Key_Type *key; + unsigned int type = SLKEY_F_INTRINSIC; + int ret; + + ret = find_the_key (s, kml, &key); + if ((ret != 0) || (key == NULL)) + return ret; + + key->type = type; + key->f.f = f; + return 0; +} + +int SLang_define_key (char *s, char *funct, SLKeyMap_List_Type *kml) +{ + SLang_Key_Type *key; + FVOID_STAR f; + int ret; + + ret = find_the_key (s, kml, &key); + if ((ret != 0) || (key == NULL)) + return ret; + + f = SLang_find_key_function(funct, kml); + + if (f == NULL) /* assume interpreted */ + { + char *str = SLang_create_slstring (funct); + if (str == NULL) return -1; + key->type = SLKEY_F_INTERPRET; + key->f.s = str; + } + else + { + key->type = SLKEY_F_INTRINSIC; + key->f.f = f; + } + return 0; +} + +int SLkm_define_keysym (char *s, unsigned int keysym, SLKeyMap_List_Type *kml) +{ + SLang_Key_Type *key; + int ret; + + ret = find_the_key (s, kml, &key); + + if ((ret != 0) || (key == NULL)) + return ret; + + key->type = SLKEY_F_KEYSYM; + key->f.keysym = keysym; + return 0; +} + +SLang_Key_Type *SLang_do_key(SLKeyMap_List_Type *kml, int (*getkey)(void)) +{ + register SLang_Key_Type *key, *next, *kmax; + unsigned int len; + unsigned char input_ch; + register unsigned char chup, chlow; + unsigned char key_ch = 0; + + SLang_Last_Key_Char = (*getkey)(); + SLang_Key_TimeOut_Flag = 0; + + if (SLANG_GETKEY_ERROR == (unsigned int) SLang_Last_Key_Char) + return NULL; + + input_ch = (unsigned char) SLang_Last_Key_Char; + + key = (SLang_Key_Type *) &((kml->keymap)[input_ch]); + + /* if the next one is null, then we know this MAY be it. */ + while (key->next == NULL) + { + if (key->type != 0) + return key; + + /* Try its opposite case counterpart */ + chlow = LOWER_CASE_KEY(input_ch); + if (input_ch == chlow) + input_ch = UPPER_CASE_KEY(input_ch); + + key = kml->keymap + input_ch; + if (key->type == 0) + return NULL; + } + + /* It appears to be a prefix character in a key sequence. */ + + len = 1; /* already read one character */ + key = key->next; /* Now we are in the key list */ + kmax = NULL; /* set to end of list */ + + while (1) + { + SLang_Key_TimeOut_Flag = 1; + SLang_Last_Key_Char = (*getkey)(); + SLang_Key_TimeOut_Flag = 0; + + len++; + + if ((SLANG_GETKEY_ERROR == (unsigned int) SLang_Last_Key_Char) + || SLKeyBoard_Quit) + break; + + input_ch = (unsigned char) SLang_Last_Key_Char; + + chup = UPPER_CASE_KEY(input_ch); chlow = LOWER_CASE_KEY(input_ch); + + while (key != kmax) + { + if (key->str[0] > len) + { + key_ch = key->str[len]; + if (chup == UPPER_CASE_KEY(key_ch)) + break; + } + key = key->next; + } + + if (key == kmax) break; + + /* If the input character is lowercase, check to see if there is + * a lowercase match. If so, set key to it. Note: the + * algorithm assumes the sorting performed by key_string_compare. + */ + if (input_ch != key_ch) + { + next = key->next; + while (next != kmax) + { + if (next->str[0] > len) + { + unsigned char next_ch = next->str[len]; + if (next_ch == input_ch) + { + key = next; + break; + } + if (next_ch != chup) + break; + } + next = next->next; + } + } + + /* Ok, we found the first position of a possible match. If it + * is exact, we are done. + */ + if ((unsigned int) key->str[0] == len + 1) + return key; + + /* Apparantly, there are some ambiguities. Read next key to resolve + * the ambiguity. Adjust kmax to encompass ambiguities. + */ + + next = key->next; + while (next != kmax) + { + if ((unsigned int) next->str[0] > len) + { + key_ch = next->str[len]; + if (chup != UPPER_CASE_KEY(key_ch)) + break; + } + next = next->next; + } + kmax = next; + } + + return NULL; +} + +void SLang_undefine_key(char *s, SLKeyMap_List_Type *kml) +{ + int n, i; + SLang_Key_Type *key, *next, *last, *key_root, *keymap; + unsigned char *str; + + keymap = kml -> keymap; + if (NULL == (str = (unsigned char *) SLang_process_keystring(s))) + return; + + if (0 == (n = *str++ - 1)) return; + i = *str; + + last = key_root = (SLang_Key_Type *) &(keymap[i]); + key = key_root->next; + + while (key != NULL) + { + next = key->next; + if (0 == SLMEMCMP ((char *)(key->str + 1), (char *) str, n)) + { + if (key->type == SLKEY_F_INTERPRET) + SLang_free_slstring (key->f.s); + + SLfree((char *) key); + last->next = next; + } + else last = key; + key = next; + } + + if (n == 1) + { + *key_root->str = 0; + key_root->f.f = NULL; + key_root->type = 0; + } +} + +char *SLang_make_keystring(unsigned char *s) +{ + static char buf [3 * SLANG_MAX_KEYMAP_KEY_SEQ + 1]; + char *b; + int n; + + n = *s++ - 1; + + if (n > SLANG_MAX_KEYMAP_KEY_SEQ) + { + SLang_verror (SL_INVALID_PARM, "Key sequence is too long"); + return NULL; + } + + b = buf; + while (n--) + { + if (*s < 32) + { + *b++ = '^'; + *b++ = *s + 'A' - 1; + } + else *b++ = *s; + s++; + } + *b = 0; + return(buf); +} + +static SLang_Key_Type *copy_keymap(SLKeyMap_List_Type *kml) +{ + int i; + SLang_Key_Type *neew, *old, *new_root, *km; + + if (NULL == (new_root = (SLang_Key_Type *) SLcalloc(256, sizeof(SLang_Key_Type)))) + return NULL; + + if (kml == NULL) return new_root; + km = kml->keymap; + + for (i = 0; i < 256; i++) + { + old = &(km[i]); + neew = &(new_root[i]); + + if (old->type == SLKEY_F_INTERPRET) + neew->f.s = SLang_create_slstring (old->f.s); + else + neew->f.f = old->f.f; + + neew->type = old->type; + SLMEMCPY((char *) neew->str, (char *) old->str, (unsigned int) *old->str); + + old = old->next; + while (old != NULL) + { + neew->next = malloc_key((unsigned char *) old->str); + neew = neew->next; + + if (old->type == SLKEY_F_INTERPRET) + neew->f.s = SLang_create_slstring (old->f.s); + else + neew->f.f = old->f.f; + + neew->type = old->type; + old = old->next; + } + neew->next = NULL; + } + return(new_root); +} + +SLKeyMap_List_Type *SLang_create_keymap(char *name, SLKeyMap_List_Type *map) +{ + SLang_Key_Type *neew; + SLKeyMap_List_Type *new_map; + + if ((NULL == (neew = copy_keymap(map))) + || (NULL == (new_map = add_keymap(name, neew)))) return NULL; + + if (map != NULL) new_map -> functions = map -> functions; + + return new_map; +} + +SLKeyMap_List_Type *SLang_find_keymap(char *name) +{ + SLKeyMap_List_Type *kmap, *kmap_max; + + kmap = SLKeyMap_List; + kmap_max = kmap + SLANG_MAX_KEYMAPS; + + while (kmap < kmap_max) + { + if ((kmap->name != NULL) + && (0 == strcmp (kmap->name, name))) + return kmap; + + kmap++; + } + return NULL; +} diff --git a/mdk-stage1/slang/slkeypad.c b/mdk-stage1/slang/slkeypad.c new file mode 100644 index 000000000..524dc80fa --- /dev/null +++ b/mdk-stage1/slang/slkeypad.c @@ -0,0 +1,163 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static SLKeyMap_List_Type *Keymap_List; + +int SLkp_init (void) +{ + char esc_seq[10]; + int i; + + if (NULL == (Keymap_List = SLang_create_keymap ("_SLKeypad", NULL))) + return -1; + + esc_seq[1] = 0; + for (i = 1; i < 256; i++) + { + esc_seq[0] = (char) i; + SLkm_define_keysym (esc_seq, i, Keymap_List); + } + + /* Now add most common ones. */ +#ifndef IBMPC_SYSTEM + SLkm_define_keysym ("^@", 0, Keymap_List); + + SLkm_define_keysym ("\033[A", SL_KEY_UP, Keymap_List); + SLkm_define_keysym ("\033OA", SL_KEY_UP, Keymap_List); + SLkm_define_keysym ("\033[B", SL_KEY_DOWN, Keymap_List); + SLkm_define_keysym ("\033OB", SL_KEY_DOWN, Keymap_List); + SLkm_define_keysym ("\033[C", SL_KEY_RIGHT, Keymap_List); + SLkm_define_keysym ("\033OC", SL_KEY_RIGHT, Keymap_List); + SLkm_define_keysym ("\033[D", SL_KEY_LEFT, Keymap_List); + SLkm_define_keysym ("\033OD", SL_KEY_LEFT, Keymap_List); + SLkm_define_keysym ("\033[2~", SL_KEY_IC, Keymap_List); + SLkm_define_keysym ("\033[7~", SL_KEY_HOME, Keymap_List); + SLkm_define_keysym ("\033[5~", SL_KEY_PPAGE, Keymap_List); + SLkm_define_keysym ("\033[6~", SL_KEY_NPAGE, Keymap_List); + SLkm_define_keysym ("\033[8~", SL_KEY_END, Keymap_List); + SLkm_define_keysym ("\033[3~", SL_KEY_DELETE, Keymap_List); +#else + /* Note: This will not work if SLgetkey_map_to_ansi (1) has + * been called. + */ + SLkm_define_keysym ("^@\x48", SL_KEY_UP, Keymap_List ); + SLkm_define_keysym ("^@\x50", SL_KEY_DOWN, Keymap_List ); + SLkm_define_keysym ("^@\x4d", SL_KEY_RIGHT, Keymap_List ); + SLkm_define_keysym ("^@\x4b", SL_KEY_LEFT, Keymap_List ); + SLkm_define_keysym ("^@\x47", SL_KEY_HOME, Keymap_List ); + SLkm_define_keysym ("^@\x49", SL_KEY_PPAGE, Keymap_List ); + SLkm_define_keysym ("^@\x51", SL_KEY_NPAGE, Keymap_List ); + SLkm_define_keysym ("^@\x4f", SL_KEY_END, Keymap_List ); + SLkm_define_keysym ("^@\x52", SL_KEY_IC, Keymap_List ); + SLkm_define_keysym ("^@\x53", SL_KEY_DELETE, Keymap_List ); + + SLkm_define_keysym ("\xE0\x48", SL_KEY_UP, Keymap_List ); + SLkm_define_keysym ("\xE0\x50", SL_KEY_DOWN, Keymap_List ); + SLkm_define_keysym ("\xE0\x4d", SL_KEY_RIGHT, Keymap_List ); + SLkm_define_keysym ("\xE0\x4b", SL_KEY_LEFT, Keymap_List ); + SLkm_define_keysym ("\xE0\x47", SL_KEY_HOME, Keymap_List ); + SLkm_define_keysym ("\xE0\x49", SL_KEY_PPAGE, Keymap_List ); + SLkm_define_keysym ("\xE0\x51", SL_KEY_NPAGE, Keymap_List ); + SLkm_define_keysym ("\xE0\x4f", SL_KEY_END, Keymap_List ); + SLkm_define_keysym ("\xE0\x52", SL_KEY_IC, Keymap_List ); + SLkm_define_keysym ("\xE0\x53", SL_KEY_DELETE, Keymap_List ); + + strcpy (esc_seq, "^@ "); /* guarantees esc_seq[3] = 0. */ + + for (i = 0x3b; i < 0x45; i++) + { + esc_seq [2] = i; + SLkm_define_keysym (esc_seq, SL_KEY_F(i - 0x3a), Keymap_List); + } + esc_seq[2] = 0x57; SLkm_define_keysym (esc_seq, SL_KEY_F(11), Keymap_List); + esc_seq[2] = 0x58; SLkm_define_keysym (esc_seq, SL_KEY_F(12), Keymap_List); +#endif + +#ifdef REAL_UNIX_SYSTEM + strcpy (esc_seq, "^(kX)"); + for (i = 0; i <= 9; i++) + { + esc_seq[3] = '0' + i; + SLkm_define_keysym (esc_seq, SL_KEY_F(i), Keymap_List); + } + SLkm_define_keysym ("^(k;)", SL_KEY_F(10), Keymap_List); + + SLkm_define_keysym ("^(ku)", SL_KEY_UP, Keymap_List); + SLkm_define_keysym ("^(kd)", SL_KEY_DOWN, Keymap_List); + SLkm_define_keysym ("^(kl)", SL_KEY_LEFT, Keymap_List); + SLkm_define_keysym ("^(kr)", SL_KEY_RIGHT, Keymap_List); + SLkm_define_keysym ("^(kP)", SL_KEY_PPAGE, Keymap_List); + SLkm_define_keysym ("^(kN)", SL_KEY_NPAGE, Keymap_List); + SLkm_define_keysym ("^(kh)", SL_KEY_HOME, Keymap_List); + SLkm_define_keysym ("^(@7)", SL_KEY_END, Keymap_List); + SLkm_define_keysym ("^(K1)", SL_KEY_A1, Keymap_List); + SLkm_define_keysym ("^(K3)", SL_KEY_A3, Keymap_List); + SLkm_define_keysym ("^(K2)", SL_KEY_B2, Keymap_List); + SLkm_define_keysym ("^(K4)", SL_KEY_C1, Keymap_List); + SLkm_define_keysym ("^(K5)", SL_KEY_C3, Keymap_List); + SLkm_define_keysym ("^(%0)", SL_KEY_REDO, Keymap_List); + SLkm_define_keysym ("^(&8)", SL_KEY_UNDO, Keymap_List); + SLkm_define_keysym ("^(kb)", SL_KEY_BACKSPACE, Keymap_List); + SLkm_define_keysym ("^(@8)", SL_KEY_ENTER, Keymap_List); + SLkm_define_keysym ("^(kD)", SL_KEY_DELETE, Keymap_List); +#endif + + if (SLang_Error) + return -1; + return 0; +} + +int SLkp_getkey (void) +{ + SLang_Key_Type *key; + + key = SLang_do_key (Keymap_List, (int (*)(void)) SLang_getkey); + if ((key == NULL) || (key->type != SLKEY_F_KEYSYM)) + { + SLang_flush_input (); + return SL_KEY_ERR; + } + + return key->f.keysym; +} + +int SLkp_define_keysym (char *keystr, unsigned int keysym) +{ + if (SLkm_define_keysym (keystr, keysym, Keymap_List) < 0) + return -1; + + return 0; +} + +#if 0 +int main (int argc, char **argv) +{ + int ch; + + SLtt_get_terminfo (); + + if (-1 == SLkp_init ()) + return 1; + + SLang_init_tty (-1, 0, 0); + + while ('q' != (ch = SLkp_getkey ())) + { + fprintf (stdout, "Keycode = %d\r\n", ch); + fflush (stdout); + } + + SLang_reset_tty (); + + return 0; +} +#endif + diff --git a/mdk-stage1/slang/sllimits.h b/mdk-stage1/slang/sllimits.h new file mode 100644 index 000000000..c4ae03b83 --- /dev/null +++ b/mdk-stage1/slang/sllimits.h @@ -0,0 +1,64 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +/* sllimits.h */ + +/* slstring.c: Size of the hash table used for strings (prime numbers) */ +#ifdef __MSDOS_16BIT__ +# define SLSTRING_HASH_TABLE_SIZE 601 +# define SLASSOC_HASH_TABLE_SIZE 601 +#else +# define SLSTRING_HASH_TABLE_SIZE 2909 +# define SLASSOC_HASH_TABLE_SIZE 2909 +#endif + +/* slang.c: maximum size of run time stack */ +#ifdef __MSDOS_16BIT__ +# define SLANG_MAX_STACK_LEN 500 +#else +# define SLANG_MAX_STACK_LEN 2500 +#endif + +/* slang.c: This sets the size on the depth of function calls */ +#ifdef __MSDOS_16BIT__ +# define SLANG_MAX_RECURSIVE_DEPTH 50 +#else +# define SLANG_MAX_RECURSIVE_DEPTH 250 +#endif + +/* slang.c: Size of the stack used for local variables */ +#ifdef __MSDOS_16BIT__ +# define SLANG_MAX_LOCAL_STACK 200 +#else +# define SLANG_MAX_LOCAL_STACK 1024 +#endif + +/* slang.c: The size of the hash table used for local and global objects. + * These should be prime numbers. + */ +#define SLGLOBALS_HASH_TABLE_SIZE 2909 +#define SLLOCALS_HASH_TABLE_SIZE 73 +#define SLSTATIC_HASH_TABLE_SIZE 73 + +/* Size of the keyboard buffer use by the ungetkey routines */ +#ifdef __MSDOS_16BIT__ +# define SL_MAX_INPUT_BUFFER_LEN 40 +#else +# define SL_MAX_INPUT_BUFFER_LEN 1024 +#endif + +/* Maximum number of nested switch statements */ +#define SLANG_MAX_NESTED_SWITCH 10 + +/* Size of the block stack (used in byte-compiling) */ +#define SLANG_MAX_BLOCK_STACK_LEN 50 + +/* slfile.c: Max number of open file pointers */ +#ifdef __MSDOS_16BIT__ +# define SL_MAX_FILES 32 +#else +# define SL_MAX_FILES 256 +#endif diff --git a/mdk-stage1/slang/slmalloc.c b/mdk-stage1/slang/slmalloc.c new file mode 100644 index 000000000..914e1e0ef --- /dev/null +++ b/mdk-stage1/slang/slmalloc.c @@ -0,0 +1,165 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#ifdef SL_MALLOC_DEBUG +# undef SL_MALLOC_DEBUG +#endif + +#include "slang.h" +#include "_slang.h" + +#ifdef __alpha +# define Chunk 8 +#else +# define Chunk 4 +#endif + +static long Total_Allocated; +static long Max_Single_Allocation; +static long Max_Allocated; +/* #define SLDEBUG_DOUT */ + +#ifdef SLDEBUG_DOUT +static FILE *dout; +#endif + +void SLmalloc_dump_statistics (void) +{ +#ifdef SLDEBUG_DOUT + fflush (dout); +#endif + fprintf (stderr, "Total Allocated: %ld\nHighest single allocation: %ld\nHighest Total Allocated:%ld\n", + Total_Allocated, Max_Single_Allocation, Max_Allocated); +} + +static void register_at_exit_fun (void) +{ + static int is_registered = 0; + if (is_registered) + return; + is_registered = 1; + +#ifdef SLDEBUG_DOUT + if (dout == NULL) dout = fopen ("malloc.out", "w"); +#endif + SLang_add_cleanup_function (SLmalloc_dump_statistics); +} + +static void fixup (unsigned char *p, unsigned long n, char *what) +{ + register_at_exit_fun (); + + p += Chunk; + *(p - 4)= (unsigned char) ((n >> 24) & 0xFF); + *(p - 3) = (unsigned char) ((n >> 16) & 0xFF); + *(p - 2) = (unsigned char) ((n >> 8) & 0xFF); + *(p - 1) = (unsigned char) (n & 0xFF); + *(p + (int) n) = 27; + *(p + (int) (n + 1)) = 182; + *(p + (int) (n + 2)) = 81; + *(p + (int) (n + 3)) = 86; + Total_Allocated += (long) n; + if (Total_Allocated > Max_Allocated) Max_Allocated = Total_Allocated; + if ((long) n > Max_Single_Allocation) + Max_Single_Allocation = (long) n; + +#ifdef SLDEBUG_DOUT + fprintf (dout, "ALLOC: %s\t%p %ld\n", what, p, (long) n); +#else + (void) what; +#endif +} + +static void SLmalloc_doerror (char *buf) +{ + SLang_doerror (buf); +} + +static int check_memory (unsigned char *p, char *what) +{ + char buf[128]; + unsigned long n; + + register_at_exit_fun (); + + n = ((unsigned long) *(p - 4)) << 24; + n |= ((unsigned long) *(p - 3)) << 16; + n |= ((unsigned long) *(p - 2)) << 8; + n |= (unsigned long) *(p - 1); + + if (n == 0xFFFFFFFFUL) + { + sprintf (buf, "%s: %p: Already FREE! Abort NOW.", what, p - Chunk); + SLmalloc_doerror (buf); + return -1; + } + + if ((*(p + (int) n) != 27) + || (*(p + (int) (n + 1)) != 182) + || (*(p + (int) (n + 2)) != 81) + || (*(p + (int) (n + 3)) != 86)) + { + sprintf (buf, "\007%s: %p: Memory corrupt! Abort NOW.", what, p); + SLmalloc_doerror (buf); + return -1; + } + + *(p - 4) = *(p - 3) = *(p - 2) = *(p - 1) = 0xFF; + + Total_Allocated -= (long) n; + if (Total_Allocated < 0) + { + sprintf (buf, "\007%s: %p\nFreed %ld, Allocated is: %ld!\n", + what, p, (long) n, Total_Allocated); + SLang_doerror (buf); + } +#ifdef SLDEBUG_DOUT + fprintf (dout, "FREE: %s:\t%p %ld\n", what, p, (long) n); +#endif + return 0; +} + +void SLdebug_free (char *p) +{ + if (p == NULL) return; + if (-1 == check_memory ((unsigned char *) p, "FREE")) return; + + SLFREE (p - Chunk); +} + +char *SLdebug_malloc (unsigned long n) +{ + char *p; + + if ((p = (char *) SLMALLOC (n + 2 * Chunk)) == NULL) return NULL; + + fixup ((unsigned char *) p, n, "MALLOC"); + return p + Chunk; +} + +char *SLdebug_realloc (char *p, unsigned long n) +{ + if (-1 == check_memory ((unsigned char *) p, "REALLOC")) return NULL; + if ((p = (char *) SLREALLOC (p - Chunk, n + 2 * Chunk)) == NULL) return NULL; + fixup ((unsigned char *) p, n, "REALLOC"); + return p + Chunk; +} + +char *SLdebug_calloc (unsigned long n, unsigned long size) +{ + char *p; + int m; + + /* This is tough -- hope this is a good assumption!! */ + if (size >= Chunk) m = 1; else m = Chunk; + + if ((p = (char *) SLCALLOC (n + m + m, size)) == NULL) return NULL; + fixup ((unsigned char *) p, size * n, "CALLOC"); + return p + Chunk; +} + diff --git a/mdk-stage1/slang/slmath.c b/mdk-stage1/slang/slmath.c new file mode 100644 index 000000000..1d61e14d3 --- /dev/null +++ b/mdk-stage1/slang/slmath.c @@ -0,0 +1,565 @@ +/* sin, cos, etc, for S-Lang */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include <math.h> + +#include "slang.h" +#include "_slang.h" + +#ifdef PI +# undef PI +#endif +#define PI 3.14159265358979323846264338327950288 + +#if defined(__unix__) +#include <signal.h> +#include <errno.h> + +#define SIGNAL SLsignal + +static void math_floating_point_exception (int sig) +{ + sig = errno; + if (SLang_Error == 0) SLang_Error = SL_FLOATING_EXCEPTION; + (void) SIGNAL (SIGFPE, math_floating_point_exception); + errno = sig; +} +#endif + +double SLmath_hypot (double x, double y) +{ + double fr, fi, ratio; + + fr = fabs(x); + fi = fabs(y); + + if (fr > fi) + { + ratio = y / x; + x = fr * sqrt (1.0 + ratio * ratio); + } + else if (fi == 0.0) x = 0.0; + else + { + ratio = x / y; + x = fi * sqrt (1.0 + ratio * ratio); + } + + return x; +} + +/* usage here is a1 a2 ... an n x ==> a1x^n + a2 x ^(n - 1) + ... + an */ +static double math_poly (void) +{ + int n; + double xn = 1.0, sum = 0.0; + double an, x; + + if ((SLang_pop_double(&x, NULL, NULL)) + || (SLang_pop_integer(&n))) return(0.0); + + while (n-- > 0) + { + if (SLang_pop_double(&an, NULL, NULL)) break; + sum += an * xn; + xn = xn * x; + } + return (double) sum; +} + +static int double_math_op_result (int op, unsigned char a, unsigned char *b) +{ + (void) op; + + if (a != SLANG_FLOAT_TYPE) + *b = SLANG_DOUBLE_TYPE; + else + *b = a; + + return 1; +} + +#ifdef HAVE_ASINH +# define ASINH_FUN asinh +#else +# define ASINH_FUN my_asinh +static double my_asinh (double x) +{ + return log (x + sqrt (x*x + 1)); +} +#endif +#ifdef HAVE_ACOSH +# define ACOSH_FUN acosh +#else +# define ACOSH_FUN my_acosh +static double my_acosh (double x) +{ + return log (x + sqrt(x*x - 1)); /* x >= 1 */ +} +#endif +#ifdef HAVE_ATANH +# define ATANH_FUN atanh +#else +# define ATANH_FUN my_atanh +static double my_atanh (double x) +{ + return 0.5 * log ((1.0 + x)/(1.0 - x)); /* 0 <= x^2 < 1 */ +} +#endif + +static int double_math_op (int op, + unsigned char type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + double *a, *b; + unsigned int i; + double (*fun) (double); + + (void) type; + a = (double *) ap; + b = (double *) bp; + + switch (op) + { + default: + return 0; + + case SLMATH_SINH: + fun = sinh; + break; + case SLMATH_COSH: + fun = cosh; + break; + case SLMATH_TANH: + fun = tanh; + break; + case SLMATH_TAN: + fun = tan; + break; + case SLMATH_ASIN: + fun = asin; + break; + case SLMATH_ACOS: + fun = acos; + break; + case SLMATH_ATAN: + fun = atan; + break; + case SLMATH_EXP: + fun = exp; + break; + case SLMATH_LOG: + fun = log; + break; + case SLMATH_LOG10: + fun = log10; + break; + case SLMATH_SQRT: + fun = sqrt; + break; + case SLMATH_SIN: + fun = sin; + break; + case SLMATH_COS: + fun = cos; + break; + + case SLMATH_ASINH: + fun = ASINH_FUN; + break; + case SLMATH_ATANH: + fun = ATANH_FUN; + break; + case SLMATH_ACOSH: + fun = ACOSH_FUN; + break; + + case SLMATH_CONJ: + case SLMATH_REAL: + for (i = 0; i < na; i++) + b[i] = a[i]; + return 1; + case SLMATH_IMAG: + for (i = 0; i < na; i++) + b[i] = 0.0; + return 1; + } + + for (i = 0; i < na; i++) + b[i] = (*fun) (a[i]); + + return 1; +} + +static int float_math_op (int op, + unsigned char type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + float *a, *b; + unsigned int i; + double (*fun) (double); + + (void) type; + a = (float *) ap; + b = (float *) bp; + + + switch (op) + { + default: + return 0; + + case SLMATH_SINH: + fun = sinh; + break; + case SLMATH_COSH: + fun = cosh; + break; + case SLMATH_TANH: + fun = tanh; + break; + case SLMATH_TAN: + fun = tan; + break; + case SLMATH_ASIN: + fun = asin; + break; + case SLMATH_ACOS: + fun = acos; + break; + case SLMATH_ATAN: + fun = atan; + break; + case SLMATH_EXP: + fun = exp; + break; + case SLMATH_LOG: + fun = log; + break; + case SLMATH_LOG10: + fun = log10; + break; + case SLMATH_SQRT: + fun = sqrt; + break; + case SLMATH_SIN: + fun = sin; + break; + case SLMATH_COS: + fun = cos; + break; + + case SLMATH_ASINH: + fun = ASINH_FUN; + break; + case SLMATH_ATANH: + fun = ATANH_FUN; + break; + case SLMATH_ACOSH: + fun = ACOSH_FUN; + break; + + case SLMATH_CONJ: + case SLMATH_REAL: + for (i = 0; i < na; i++) + b[i] = a[i]; + return 1; + case SLMATH_IMAG: + for (i = 0; i < na; i++) + b[i] = 0.0; + return 1; + } + + for (i = 0; i < na; i++) + b[i] = (float) (*fun) ((double) a[i]); + + return 1; +} + +static int generic_math_op (int op, + unsigned char type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + double *b; + unsigned int i; + SLang_To_Double_Fun_Type to_double; + double (*fun) (double); + unsigned int da; + char *a; + + if (NULL == (to_double = SLarith_get_to_double_fun (type, &da))) + return 0; + + b = (double *) bp; + a = (char *) ap; + + switch (op) + { + default: + return 0; + + case SLMATH_SINH: + fun = sinh; + break; + case SLMATH_COSH: + fun = cosh; + break; + case SLMATH_TANH: + fun = tanh; + break; + case SLMATH_TAN: + fun = tan; + break; + case SLMATH_ASIN: + fun = asin; + break; + case SLMATH_ACOS: + fun = acos; + break; + case SLMATH_ATAN: + fun = atan; + break; + case SLMATH_EXP: + fun = exp; + break; + case SLMATH_LOG: + fun = log; + break; + case SLMATH_LOG10: + fun = log10; + break; + case SLMATH_SQRT: + fun = sqrt; + break; + case SLMATH_SIN: + fun = sin; + break; + case SLMATH_COS: + fun = cos; + break; + + case SLMATH_ASINH: + fun = ASINH_FUN; + break; + case SLMATH_ATANH: + fun = ATANH_FUN; + break; + case SLMATH_ACOSH: + fun = ACOSH_FUN; + break; + + + case SLMATH_CONJ: + case SLMATH_REAL: + for (i = 0; i < na; i++) + { + b[i] = to_double((VOID_STAR) a); + a += da; + } + return 1; + + case SLMATH_IMAG: + for (i = 0; i < na; i++) + b[i] = 0.0; + return 1; + } + + for (i = 0; i < na; i++) + { + b[i] = (*fun) (to_double ((VOID_STAR) a)); + a += da; + } + + return 1; +} + +#if SLANG_HAS_COMPLEX +static int complex_math_op_result (int op, unsigned char a, unsigned char *b) +{ + (void) a; + switch (op) + { + default: + *b = SLANG_COMPLEX_TYPE; + break; + + case SLMATH_REAL: + case SLMATH_IMAG: + *b = SLANG_DOUBLE_TYPE; + break; + } + return 1; +} + +static int complex_math_op (int op, + unsigned char type, VOID_STAR ap, unsigned int na, + VOID_STAR bp) +{ + double *a, *b; + unsigned int i; + unsigned int na2 = na * 2; + double *(*fun) (double *, double *); + + (void) type; + a = (double *) ap; + b = (double *) bp; + + switch (op) + { + default: + return 0; + + case SLMATH_REAL: + for (i = 0; i < na; i++) + b[i] = a[2 * i]; + return 1; + + case SLMATH_IMAG: + for (i = 0; i < na; i++) + b[i] = a[2 * i + 1]; + return 1; + + case SLMATH_CONJ: + for (i = 0; i < na2; i += 2) + { + b[i] = a[i]; + b[i+1] = -a[i+1]; + } + return 1; + + case SLMATH_ATANH: + fun = SLcomplex_atanh; + break; + case SLMATH_ACOSH: + fun = SLcomplex_acosh; + break; + case SLMATH_ASINH: + fun = SLcomplex_asinh; + break; + case SLMATH_EXP: + fun = SLcomplex_exp; + break; + case SLMATH_LOG: + fun = SLcomplex_log; + break; + case SLMATH_LOG10: + fun = SLcomplex_log10; + break; + case SLMATH_SQRT: + fun = SLcomplex_sqrt; + break; + case SLMATH_SIN: + fun = SLcomplex_sin; + break; + case SLMATH_COS: + fun = SLcomplex_cos; + break; + case SLMATH_SINH: + fun = SLcomplex_sinh; + break; + case SLMATH_COSH: + fun = SLcomplex_cosh; + break; + case SLMATH_TANH: + fun = SLcomplex_tanh; + break; + case SLMATH_TAN: + fun = SLcomplex_tan; + break; + case SLMATH_ASIN: + fun = SLcomplex_asin; + break; + case SLMATH_ACOS: + fun = SLcomplex_acos; + break; + case SLMATH_ATAN: + fun = SLcomplex_atan; + break; + } + + for (i = 0; i < na2; i += 2) + (void) (*fun) (b + i, a + i); + + return 1; +} +#endif + +static SLang_DConstant_Type DConst_Table [] = +{ + MAKE_DCONSTANT("E", 2.718281828459045), + MAKE_DCONSTANT("PI", 3.14159265358979323846264338327950288), + SLANG_END_DCONST_TABLE +}; + +static SLang_Math_Unary_Type SLmath_Table [] = +{ + MAKE_MATH_UNARY("sinh", SLMATH_SINH), + MAKE_MATH_UNARY("asinh", SLMATH_ASINH), + MAKE_MATH_UNARY("cosh", SLMATH_COSH), + MAKE_MATH_UNARY("acosh", SLMATH_ACOSH), + MAKE_MATH_UNARY("tanh", SLMATH_TANH), + MAKE_MATH_UNARY("atanh", SLMATH_ATANH), + MAKE_MATH_UNARY("sin", SLMATH_SIN), + MAKE_MATH_UNARY("cos", SLMATH_COS), + MAKE_MATH_UNARY("tan", SLMATH_TAN), + MAKE_MATH_UNARY("atan", SLMATH_ATAN), + MAKE_MATH_UNARY("acos", SLMATH_ACOS), + MAKE_MATH_UNARY("asin", SLMATH_ASIN), + MAKE_MATH_UNARY("exp", SLMATH_EXP), + MAKE_MATH_UNARY("log", SLMATH_LOG), + MAKE_MATH_UNARY("sqrt", SLMATH_SQRT), + MAKE_MATH_UNARY("log10", SLMATH_LOG10), +#if SLANG_HAS_COMPLEX + MAKE_MATH_UNARY("Real", SLMATH_REAL), + MAKE_MATH_UNARY("Imag", SLMATH_IMAG), + MAKE_MATH_UNARY("Conj", SLMATH_CONJ), +#endif + SLANG_END_MATH_UNARY_TABLE +}; + +static SLang_Intrin_Fun_Type SLang_Math_Table [] = +{ + MAKE_INTRINSIC_0("polynom", math_poly, SLANG_DOUBLE_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +int SLang_init_slmath (void) +{ + unsigned char *int_types; + +#if defined(__unix__) + (void) SIGNAL (SIGFPE, math_floating_point_exception); +#endif + + int_types = _SLarith_Arith_Types; + + while (*int_types != SLANG_FLOAT_TYPE) + { + if (-1 == SLclass_add_math_op (*int_types, generic_math_op, double_math_op_result)) + return -1; + int_types++; + } + + if ((-1 == SLclass_add_math_op (SLANG_FLOAT_TYPE, float_math_op, double_math_op_result)) + || (-1 == SLclass_add_math_op (SLANG_DOUBLE_TYPE, double_math_op, double_math_op_result)) +#if SLANG_HAS_COMPLEX + || (-1 == SLclass_add_math_op (SLANG_COMPLEX_TYPE, complex_math_op, complex_math_op_result)) +#endif + ) + return -1; + + if ((-1 == SLadd_math_unary_table (SLmath_Table, "__SLMATH__")) + || (-1 == SLadd_intrin_fun_table (SLang_Math_Table, NULL)) + || (-1 == SLadd_dconstant_table (DConst_Table, NULL))) + return -1; + + return 0; +} + diff --git a/mdk-stage1/slang/slmemchr.c b/mdk-stage1/slang/slmemchr.c new file mode 100644 index 000000000..1417bc549 --- /dev/null +++ b/mdk-stage1/slang/slmemchr.c @@ -0,0 +1,47 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are fast memcpy, memset routines. When available, I + use system rouines. For msdos, I use inline assembly. */ + +/* The current versions only work in the forward direction only!! */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +char *SLmemchr(register char *p, register char c, register int n) +{ + int n2; + register char *pmax; + + pmax = p + (n - 32); + + while (p <= pmax) + { + if ((*p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c) + || (*++p == c) || (*++p == c) || (*++p == c) || (*++p == c)) + return p; + p++; + } + + n2 = n % 32; + + while (n2--) + { + if (*p == c) return p; + p++; + } + return(NULL); +} diff --git a/mdk-stage1/slang/slmemcmp.c b/mdk-stage1/slang/slmemcmp.c new file mode 100644 index 000000000..c5ed50095 --- /dev/null +++ b/mdk-stage1/slang/slmemcmp.c @@ -0,0 +1,76 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are fast memcpy, memset routines. When available, I + use system rouines. For msdos, I use inline assembly. */ + +/* The current versions only work in the forward direction only!! */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* This is an UNSIGNED comparison designed for systems that either do not have +* this function or performed a signed comparison (SunOS) +*/ +int SLmemcmp(register char *s1, register char *s2, int n) +{ + register int cmp; + register char *s1max; + + s1max = s1 + (n - 32); + + while (s1 <= s1max) + { + if (*s1 != *s2) return ((unsigned char) *s1 - (unsigned char) *s2); + if (*(s1 + 1) != *(s2 + 1)) return ((unsigned char) *(s1 + 1) - (unsigned char) *(s2 + 1)); + if (*(s1 + 2) != *(s2 + 2)) return ((unsigned char) *(s1 + 2) - (unsigned char) *(s2 + 2)); + if (*(s1 + 3) != *(s2 + 3)) return ((unsigned char) *(s1 + 3) - (unsigned char) *(s2 + 3)); + if (*(s1 + 4) != *(s2 + 4)) return ((unsigned char) *(s1 + 4) - (unsigned char) *(s2 + 4)); + if (*(s1 + 5) != *(s2 + 5)) return ((unsigned char) *(s1 + 5) - (unsigned char) *(s2 + 5)); + if (*(s1 + 6) != *(s2 + 6)) return ((unsigned char) *(s1 + 6) - (unsigned char) *(s2 + 6)); + if (*(s1 + 7) != *(s2 + 7)) return ((unsigned char) *(s1 + 7) - (unsigned char) *(s2 + 7)); + if (*(s1 + 8) != *(s2 + 8)) return ((unsigned char) *(s1 + 8) - (unsigned char) *(s2 + 8)); + if (*(s1 + 9) != *(s2 + 9)) return ((unsigned char) *(s1 + 9) - (unsigned char) *(s2 + 9)); + if (*(s1 + 10) != *(s2 + 10)) return ((unsigned char) *(s1 + 10) - (unsigned char) *(s2 + 10)); + if (*(s1 + 11) != *(s2 + 11)) return ((unsigned char) *(s1 + 11) - (unsigned char) *(s2 + 11)); + if (*(s1 + 12) != *(s2 + 12)) return ((unsigned char) *(s1 + 12) - (unsigned char) *(s2 + 12)); + if (*(s1 + 13) != *(s2 + 13)) return ((unsigned char) *(s1 + 13) - (unsigned char) *(s2 + 13)); + if (*(s1 + 14) != *(s2 + 14)) return ((unsigned char) *(s1 + 14) - (unsigned char) *(s2 + 14)); + if (*(s1 + 15) != *(s2 + 15)) return ((unsigned char) *(s1 + 15) - (unsigned char) *(s2 + 15)); + if (*(s1 + 16) != *(s2 + 16)) return ((unsigned char) *(s1 + 16) - (unsigned char) *(s2 + 16)); + if (*(s1 + 17) != *(s2 + 17)) return ((unsigned char) *(s1 + 17) - (unsigned char) *(s2 + 17)); + if (*(s1 + 18) != *(s2 + 18)) return ((unsigned char) *(s1 + 18) - (unsigned char) *(s2 + 18)); + if (*(s1 + 19) != *(s2 + 19)) return ((unsigned char) *(s1 + 19) - (unsigned char) *(s2 + 19)); + if (*(s1 + 20) != *(s2 + 20)) return ((unsigned char) *(s1 + 20) - (unsigned char) *(s2 + 20)); + if (*(s1 + 21) != *(s2 + 21)) return ((unsigned char) *(s1 + 21) - (unsigned char) *(s2 + 21)); + if (*(s1 + 22) != *(s2 + 22)) return ((unsigned char) *(s1 + 22) - (unsigned char) *(s2 + 22)); + if (*(s1 + 23) != *(s2 + 23)) return ((unsigned char) *(s1 + 23) - (unsigned char) *(s2 + 23)); + if (*(s1 + 24) != *(s2 + 24)) return ((unsigned char) *(s1 + 24) - (unsigned char) *(s2 + 24)); + if (*(s1 + 25) != *(s2 + 25)) return ((unsigned char) *(s1 + 25) - (unsigned char) *(s2 + 25)); + if (*(s1 + 26) != *(s2 + 26)) return ((unsigned char) *(s1 + 26) - (unsigned char) *(s2 + 26)); + if (*(s1 + 27) != *(s2 + 27)) return ((unsigned char) *(s1 + 27) - (unsigned char) *(s2 + 27)); + if (*(s1 + 28) != *(s2 + 28)) return ((unsigned char) *(s1 + 28) - (unsigned char) *(s2 + 28)); + if (*(s1 + 29) != *(s2 + 29)) return ((unsigned char) *(s1 + 29) - (unsigned char) *(s2 + 29)); + if (*(s1 + 30) != *(s2 + 30)) return ((unsigned char) *(s1 + 30) - (unsigned char) *(s2 + 30)); + if (*(s1 + 31) != *(s2 + 31)) return ((unsigned char) *(s1 + 31) - (unsigned char) *(s2 + 31)); + s1 += 32; s2 += 32; + } + + s1max = s1 + (n % 32); + + while (s1 < s1max) + { + cmp = (unsigned char) *s1 - (unsigned char) *s2; + if (cmp) return(cmp); + s1++; + s2++; + } + + return(0); +} diff --git a/mdk-stage1/slang/slmemcpy.c b/mdk-stage1/slang/slmemcpy.c new file mode 100644 index 000000000..e8665e4c6 --- /dev/null +++ b/mdk-stage1/slang/slmemcpy.c @@ -0,0 +1,49 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are fast memcpy, memset routines. When available, I + use system rouines. For msdos, I use inline assembly. */ + +/* The current versions only work in the forward direction only!! */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +char *SLmemcpy(char *s1, char *s2, int n) +{ +#if defined(__BORLANDC__) && defined(__MSDOS__) + asm mov ax, ds + asm mov bx, si + asm mov dx, di + asm mov cx, n + asm les di, s1 + asm lds si, s2 + asm cld + asm rep movsb + asm mov ds, ax + asm mov si, bx + asm mov di, dx + return(s1); + +#else + register char *smax, *s = s1; + int n2; + + n2 = n % 4; + smax = s + (n - 4); + while (s <= smax) + { + *s = *s2; *(s + 1) = *(s2 + 1); *(s + 2) = *(s2 + 2); *(s + 3) = *(s2 + 3); + s += 4; + s2 += 4; + } + while (n2--) *s++ = *s2++; + return(s1); +#endif +} diff --git a/mdk-stage1/slang/slmemset.c b/mdk-stage1/slang/slmemset.c new file mode 100644 index 000000000..3851663c5 --- /dev/null +++ b/mdk-stage1/slang/slmemset.c @@ -0,0 +1,39 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are fast memcpy, memset routines. When available, I + use system rouines. For msdos, I use inline assembly. */ + +/* The current versions only work in the forward direction only!! */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +void SLmemset(char *p, char space, int n) +{ +#if defined(__BORLANDC__) && defined(__MSDOS__) + asm mov al, space + asm mov dx, di + asm mov cx, n + asm les di, p + asm cld + asm rep stosb + asm mov di, dx +#else + register char *pmax; + + pmax = p + (n - 4); + n = n % 4; + while (p <= pmax) + { + *p++ = space; *p++ = space; *p++ = space; *p++= space; + } + while (n--) *p++ = space; +#endif +} diff --git a/mdk-stage1/slang/slmisc.c b/mdk-stage1/slang/slmisc.c new file mode 100644 index 000000000..ccc7a9bdf --- /dev/null +++ b/mdk-stage1/slang/slmisc.c @@ -0,0 +1,330 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#define DEBUG_MALLOC 0 + +#if DEBUG_MALLOC +# define SLREALLOC_FUN SLdebug_realloc +# define SLMALLOC_FUN SLdebug_malloc +# define SLFREE_FUN SLdebug_free +#else +# define SLREALLOC_FUN SLREALLOC +# define SLMALLOC_FUN SLMALLOC +# define SLFREE_FUN SLFREE +#endif + +/* Version information goes here since this file is always needed. */ +int SLang_Version = SLANG_VERSION; +char *SLang_Version_String = SLANG_VERSION_STRING; + +char *SLmake_string(char *str) +{ + return SLmake_nstring(str, strlen (str)); +} + +char *SLmake_nstring (char *str, unsigned int n) +{ + char *ptr; + + if (NULL == (ptr = SLmalloc(n + 1))) + { + return NULL; + } + SLMEMCPY (ptr, str, n); + ptr[n] = 0; + return(ptr); +} + +void SLmake_lut (unsigned char *lut, unsigned char *range, unsigned char reverse) +{ + register unsigned char *l = lut, *lmax = lut + 256; + int i, r1, r2; + + while (l < lmax) *l++ = reverse; + reverse = !reverse; + + r1 = *range++; + while (r1) + { + r2 = *range++; + if ((r2 == '-') && (*range != 0)) + { + r2 = *range++; + for (i = r1; i <= r2; i++) lut[i] = reverse; + r1 = *range++; + continue; + } + lut[r1] = reverse; + r1 = r2; + } +} + +char *SLmalloc (unsigned int len) +{ + char *p; + + p = (char *) SLMALLOC_FUN (len); + if (p == NULL) + SLang_Error = SL_MALLOC_ERROR; + + return p; +} + +void SLfree (char *p) +{ + if (p != NULL) SLFREE_FUN (p); +} + +char *SLrealloc (char *p, unsigned int len) +{ + if (len == 0) + { + SLfree (p); + return NULL; + } + + if (p == NULL) p = SLmalloc (len); + else + { + p = (char *)SLREALLOC_FUN (p, len); + if (p == NULL) + SLang_Error = SL_MALLOC_ERROR; + } + return p; +} + +char *SLcalloc (unsigned int nelems, unsigned int len) +{ + char *p; + + len = nelems * len; + p = SLmalloc (len); + if (p != NULL) SLMEMSET (p, 0, len); + return p; +} + +/* p and ch may point to the same buffer */ +char *_SLexpand_escaped_char(char *p, char *ch) +{ + int i = 0; + int max = 0, num, base = 0; + char ch1; + + ch1 = *p++; + + switch (ch1) + { + default: num = ch1; break; + case 'n': num = '\n'; break; + case 't': num = '\t'; break; + case 'v': num = '\v'; break; + case 'b': num = '\b'; break; + case 'r': num = '\r'; break; + case 'f': num = '\f'; break; + case 'E': case 'e': num = 27; break; + case 'a': num = 7; + break; + + /* octal */ + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + max = '7'; + base = 8; i = 2; num = ch1 - '0'; + break; + + case 'd': /* decimal -- S-Lang extension */ + base = 10; + i = 3; + max = '9'; + num = 0; + break; + + case 'x': /* hex */ + base = 16; + max = '9'; + i = 2; + num = 0; + break; + } + + while (i--) + { + ch1 = *p; + + if ((ch1 <= max) && (ch1 >= '0')) + { + num = base * num + (ch1 - '0'); + } + else if (base == 16) + { + ch1 |= 0x20; + if ((ch1 < 'a') || ((ch1 > 'f'))) break; + num = base * num + 10 + (ch1 - 'a'); + } + else break; + p++; + } + + *ch = (char) num; + return p; +} + +/* s and t could represent the same space */ +void SLexpand_escaped_string (register char *s, register char *t, + register char *tmax) +{ + char ch; + + while (t < tmax) + { + ch = *t++; + if (ch == '\\') + { + t = _SLexpand_escaped_char (t, &ch); + } + *s++ = ch; + } + *s = 0; +} + +int SLextract_list_element (char *list, unsigned int nth, char delim, + char *elem, unsigned int buflen) +{ + char *el, *elmax; + char ch; + + while (nth > 0) + { + while ((0 != (ch = *list)) && (ch != delim)) + list++; + + if (ch == 0) return -1; + + list++; + nth--; + } + + el = elem; + elmax = el + (buflen - 1); + + while ((0 != (ch = *list)) && (ch != delim) && (el < elmax)) + *el++ = *list++; + *el = 0; + + return 0; +} + +#ifndef HAVE_VSNPRINTF +int _SLvsnprintf (char *buf, unsigned int buflen, char *fmt, va_list ap) +{ +#if 1 + unsigned int len; + + /* On some systems vsprintf returns useless information. So, punt */ + vsprintf (buf, fmt, ap); + len = strlen (buf); + if (len >= buflen) + { + SLang_exit_error ("\ +Your system lacks the vsnprintf system call and vsprintf overflowed a buffer.\n\ +The integrity of this program has been violated.\n"); + return EOF; /* NOT reached */ + } + return (int)len; +#else + int status; + + status = vsprintf (buf, fmt, ap); + if (status >= (int) buflen) + { + /* If we are lucky, we will get this far. The real solution is to + * provide a working version of vsnprintf + */ + SLang_exit_error ("\ +Your system lacks the vsnprintf system call and vsprintf overflowed a buffer.\n\ +The integrity of this program has been violated.\n"); + return EOF; /* NOT reached */ + } + return status; +#endif +} +#endif + +#ifndef HAVE_SNPRINTF +int _SLsnprintf (char *buf, unsigned int buflen, char *fmt, ...) +{ + int status; + + va_list ap; + + va_start (ap, fmt); + status = _SLvsnprintf (buf, buflen, fmt, ap); + va_end (ap); + + return status; +} +#endif + +typedef struct _Cleanup_Function_Type +{ + struct _Cleanup_Function_Type *next; + void (*f)(void); +} +Cleanup_Function_Type; + +static Cleanup_Function_Type *Cleanup_Function_List; + +static void cleanup_slang (void) +{ + while (Cleanup_Function_List != NULL) + { + Cleanup_Function_Type *next = Cleanup_Function_List->next; + (*Cleanup_Function_List->f)(); + SLFREE_FUN ((char *) Cleanup_Function_List); + Cleanup_Function_List = next; + } +} + +#ifndef HAVE_ATEXIT +# ifdef HAVE_ON_EXIT +static void on_exit_cleanup_slang (int arg_unused) +{ + (void) arg_unused; + cleanup_slang (); +} +# endif +#endif + +int SLang_add_cleanup_function (void (*f)(void)) +{ + Cleanup_Function_Type *l; + + l = (Cleanup_Function_Type *) SLMALLOC_FUN (sizeof (Cleanup_Function_Type)); + if (l == NULL) + return -1; + + l->f = f; + l->next = Cleanup_Function_List; + + if (Cleanup_Function_List == NULL) + { +#ifdef HAVE_ATEXIT + (void) atexit (cleanup_slang); +#else +# ifdef HAVE_ON_EXIT + (void) on_exit (on_exit_cleanup_slang, 0); +# endif +#endif + } + Cleanup_Function_List = l; + return 0; +} + diff --git a/mdk-stage1/slang/slnspace.c b/mdk-stage1/slang/slnspace.c new file mode 100644 index 000000000..174ba7c81 --- /dev/null +++ b/mdk-stage1/slang/slnspace.c @@ -0,0 +1,242 @@ +/* -*- mode: C; mode: fold; -*- */ +/* slnspace.c --- Name Space implementation */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static SLang_NameSpace_Type *Namespace_Tables; + +static SLang_NameSpace_Type *find_name_table (char *name) +{ + SLang_NameSpace_Type *table_list; + + table_list = Namespace_Tables; + while (table_list != NULL) + { + if (0 == strcmp (table_list->name, name)) + break; + table_list = table_list->next; + } + return table_list; +} + +SLang_NameSpace_Type *_SLns_find_namespace (char *name) +{ + SLang_NameSpace_Type *table_list; + + table_list = Namespace_Tables; + while (table_list != NULL) + { + if ((table_list->namespace_name != NULL) + && (0 == strcmp (table_list->namespace_name, name))) + break; + table_list = table_list->next; + } + return table_list; +} + +SLang_NameSpace_Type *_SLns_allocate_namespace (char *name, unsigned int size) +{ + SLang_NameSpace_Type *table_list; + SLang_Name_Type **nt; + + if (NULL != (table_list = find_name_table (name))) + return table_list; + + if (NULL == (name = SLang_create_slstring (name))) + return NULL; + + if (NULL == (table_list = (SLang_NameSpace_Type *) + SLmalloc (sizeof (SLang_NameSpace_Type)))) + { + SLang_free_slstring (name); + return NULL; + } + + if (NULL == (nt = (SLang_Name_Type **) SLmalloc (sizeof (SLang_Name_Type *) * size))) + { + SLang_free_slstring (name); + SLfree ((char *)table_list); + return NULL; + } + + memset ((char *)nt, 0, size * sizeof (SLang_Name_Type *)); + memset ((char *) table_list, 0, sizeof (SLang_NameSpace_Type)); + + table_list->name = name; + table_list->table = nt; + table_list->table_size = size; + + table_list->next = Namespace_Tables; + Namespace_Tables = table_list; + + return table_list; +} + +int _SLns_set_namespace_name (SLang_NameSpace_Type *t, char *name) +{ + SLang_NameSpace_Type *t1; + + t1 = _SLns_find_namespace (name); + if (t1 == NULL) + t1 = t; + + if ((t != t1) || (*name == 0)) + { + SLang_verror (SL_INTRINSIC_ERROR, "Namespace \"%s\" already exists", + name); + return -1; + } + + if (NULL == (name = SLang_create_slstring (name))) + return -1; + + SLang_free_slstring (t->namespace_name); /* NULL ok */ + t->namespace_name = name; + + return 0; +} + +SLang_Array_Type *_SLnspace_apropos (SLang_NameSpace_Type *ns, char *pat, unsigned int what) +{ + SLang_Array_Type *at; + unsigned int table_size; + SLang_Name_Type *t, **table; + int num_matches; + unsigned int i; + SLRegexp_Type rexp; + unsigned char rbuf[512]; + unsigned int two; + + at = NULL; + + if ((ns == NULL) + || ((table = ns->table) == NULL)) + return NULL; + + memset ((char *) &rexp, 0, sizeof (SLRegexp_Type)); + rexp.case_sensitive = 1; + rexp.buf = rbuf; + rexp.buf_len = sizeof (rbuf); + rexp.pat = (unsigned char *)pat; + + if (0 != SLang_regexp_compile (&rexp)) + { + SLang_verror (SL_INVALID_PARM, "Invalid regular expression: %s", pat); + return NULL; + } + + table_size = ns->table_size; + + two = 2; + while (two != 0) + { + two--; + + num_matches = 0; + for (i = 0; i < table_size; i++) + { + t = table[i]; + while (t != NULL) + { + unsigned int flags; + char *name = t->name; + + switch (t->name_type) + { + case SLANG_GVARIABLE: + flags = 8; + break; + + case SLANG_ICONSTANT: + case SLANG_DCONSTANT: + case SLANG_RVARIABLE: + case SLANG_IVARIABLE: + flags = 4; + break; + + case SLANG_INTRINSIC: + case SLANG_MATH_UNARY: + case SLANG_APP_UNARY: + flags = 1; + break; + + case SLANG_FUNCTION: + flags = 2; + break; + + default: + flags = 0; + break; + } + + if ((flags & what) + && (NULL != SLang_regexp_match ((unsigned char *)name, strlen (name), &rexp))) + { + if (at != NULL) + { + if (-1 == SLang_set_array_element (at, &num_matches, (VOID_STAR)&name)) + goto return_error; + } + num_matches++; + } + t = t->next; + } + } + + if (at == NULL) + { + at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num_matches, 1); + if (at == NULL) + goto return_error; + } + } + + return at; + + return_error: + SLang_free_array (at); + return NULL; +} + +SLang_NameSpace_Type *SLns_create_namespace (char *namespace_name) +{ + SLang_NameSpace_Type *ns; + static int num; + char name[64]; + + if (namespace_name == NULL) + namespace_name = "Global"; + + ns = _SLns_find_namespace (namespace_name); + if (ns != NULL) + return ns; + + sprintf (name, " *** internal ns <%d> *** ", num); + + if (NULL == (ns = _SLns_allocate_namespace (name, SLSTATIC_HASH_TABLE_SIZE))) + return NULL; + + num++; + if (-1 == _SLns_set_namespace_name (ns, namespace_name)) + { + SLns_delete_namespace (ns); + return NULL; + } + + return ns; +} + +void SLns_delete_namespace (SLang_NameSpace_Type *ns) +{ + (void) ns; + /* V2.0 */ +} diff --git a/mdk-stage1/slang/slospath.c b/mdk-stage1/slang/slospath.c new file mode 100644 index 000000000..644931e81 --- /dev/null +++ b/mdk-stage1/slang/slospath.c @@ -0,0 +1,73 @@ +/* Pathname intrinsic functions */ +/* Copyright (c) 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static void path_concat (char *a, char *b) +{ + SLang_push_malloced_string (SLpath_dircat (a,b)); +} + +static void path_extname (char *path) +{ +#ifdef VMS + char *p; +#endif + + path = SLpath_extname (path); +#ifndef VMS + SLang_push_string (path); +#else + p = strchr (path, ';'); + if (p == NULL) + (void)SLang_push_string (p); + else + (void)SLang_push_malloced_string (SLmake_nstring (path, (unsigned int)(p - path))); +#endif +} + +static void path_basename (char *path) +{ + (void) SLang_push_string (SLpath_basename (path)); +} + +static void path_dirname (char *path) +{ + (void) SLang_push_malloced_string (SLpath_dirname (path)); +} + +static void path_sans_extname (char *path) +{ + (void) SLang_push_malloced_string (SLpath_pathname_sans_extname (path)); +} + + + +static SLang_Intrin_Fun_Type Path_Name_Table [] = +{ + MAKE_INTRINSIC_SS("path_concat", path_concat, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_extname", path_extname, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_dirname", path_dirname, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_basename", path_basename, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_sans_extname", path_sans_extname, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("path_is_absolute", SLpath_is_absolute_path, SLANG_INT_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +int SLang_init_ospath (void) +{ + if (-1 == SLadd_intrin_fun_table(Path_Name_Table, "__OSPATH__")) + return -1; + + return 0; +} + + diff --git a/mdk-stage1/slang/slpack.c b/mdk-stage1/slang/slpack.c new file mode 100644 index 000000000..53ef63643 --- /dev/null +++ b/mdk-stage1/slang/slpack.c @@ -0,0 +1,785 @@ +/* Pack objects as a binary string */ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include <ctype.h> + +#include "slang.h" +#include "_slang.h" + +#ifndef isdigit +# define isdigit(c) (((c)>='0')&&((c)<= '9')) +#endif +#ifndef isspace +# define isspace(c) (((c)==' ') || ((c)=='\t') || ((c)=='\n')) +#endif + +/* format description: + * + * s = string (null padded) + * S = string (space padded) + * c = signed char + * C = unsigned char + * h = short + * H = unsigned short + * i = int + * I = unsigned int + * l = long + * L = unsigned long + * j = 16 bit signed integer (short) + * J = 16 bit unsigned integer (short) + * k = 32 bit signed integer (long) + * K = 32 bit unsigned integer (long) + * f = float (native format) + * F = 32 bit double + * d = double (native format) + * D = 64 bit double + * x = null pad byte + * > = big-endian mode + * < = little-endian mode + * = = native mode + */ + +#define NATIVE_ORDER 0 +#define BIGENDIAN_ORDER 1 +#define LILENDIAN_ORDER 2 +static int Native_Byte_Order = NATIVE_ORDER; + +typedef struct +{ + char format_type; + unsigned char data_type; + unsigned int repeat; + unsigned int sizeof_type; + char pad; + int byteorder; + int is_scalar; +} +Format_Type; + +static int get_int_type_for_size (unsigned int size, unsigned char *s, unsigned char *u) +{ + if (sizeof (int) == size) + { + if (s != NULL) *s = SLANG_INT_TYPE; + if (u != NULL) *u = SLANG_UINT_TYPE; + return 0; + } + + if (sizeof (short) == size) + { + if (s != NULL) *s = SLANG_SHORT_TYPE; + if (u != NULL) *u = SLANG_USHORT_TYPE; + return 1; + } + + if (sizeof (long) == size) + { + if (s != NULL) *s = SLANG_LONG_TYPE; + if (u != NULL) *u = SLANG_ULONG_TYPE; + return 1; + } + + if (s != NULL) *s = 0; + if (u != NULL) *u = 0; + SLang_verror (SL_NOT_IMPLEMENTED, + "This OS does not support a %u byte int", size); + return -1; +} + +static int get_float_type_for_size (unsigned int size, unsigned char *s) +{ + if (sizeof (float) == size) + { + *s = SLANG_FLOAT_TYPE; + return 0; + } + + if (sizeof (double) == size) + { + *s = SLANG_DOUBLE_TYPE; + return 0; + } + + SLang_verror (SL_NOT_IMPLEMENTED, + "This OS does not support a %u byte float", size); + return -1; +} + +static int parse_a_format (char **format, Format_Type *ft) +{ + char *f; + char ch; + unsigned repeat; + + f = *format; + + while (((ch = *f++) != 0) + && isspace (ch)) + ; + + switch (ch) + { + default: + ft->byteorder = NATIVE_ORDER; + break; + + case '=': + ft->byteorder = NATIVE_ORDER; + ch = *f++; + break; + + case '>': + ft->byteorder = BIGENDIAN_ORDER; + ch = *f++; + break; + + case '<': + ft->byteorder = LILENDIAN_ORDER; + ch = *f++; + break; + } + + if (ch == 0) + { + f--; + *format = f; + return 0; + } + + ft->format_type = ch; + ft->repeat = 1; + + if (isdigit (*f)) + { + repeat = (unsigned int) (*f - '0'); + f++; + + while (isdigit (*f)) + { + unsigned int repeat10 = 10 * repeat + (unsigned int)(*f - '0'); + + /* Check overflow */ + if (repeat != repeat10 / 10) + { + SLang_verror (SL_OVERFLOW, + "Repeat count too large in [un]pack format"); + return -1; + } + repeat = repeat10; + f++; + } + ft->repeat = repeat; + } + + *format = f; + + ft->is_scalar = 1; + ft->pad = 0; + + switch (ft->format_type) + { + default: + SLang_verror (SL_NOT_IMPLEMENTED, + "[un]pack format character '%c' not supported", ft->format_type); + return -1; + + case 'D': + ft->sizeof_type = 8; + if (-1 == get_float_type_for_size (8, &ft->data_type)) + return -1; + break; + + case 'd': + ft->data_type = SLANG_DOUBLE_TYPE; + ft->sizeof_type = sizeof (double); + break; + + case 'F': + ft->sizeof_type = 4; + if (-1 == get_float_type_for_size (4, &ft->data_type)) + return -1; + break; + case 'f': + ft->data_type = SLANG_FLOAT_TYPE; + ft->sizeof_type = sizeof (float); + break; + + case 'h': + ft->data_type = SLANG_SHORT_TYPE; + ft->sizeof_type = sizeof (short); + break; + case 'H': + ft->data_type = SLANG_USHORT_TYPE; + ft->sizeof_type = sizeof (unsigned short); + break; + case 'i': + ft->data_type = SLANG_INT_TYPE; + ft->sizeof_type = sizeof (int); + break; + case 'I': + ft->data_type = SLANG_UINT_TYPE; + ft->sizeof_type = sizeof (unsigned int); + break; + case 'l': + ft->data_type = SLANG_LONG_TYPE; + ft->sizeof_type = sizeof (long); + break; + case 'L': + ft->data_type = SLANG_ULONG_TYPE; + ft->sizeof_type = sizeof (unsigned long); + break; + + /* 16 bit ints */ + case 'j': + ft->sizeof_type = 2; + if (-1 == get_int_type_for_size (2, &ft->data_type, NULL)) + return -1; + break; + case 'J': + ft->sizeof_type = 2; + if (-1 == get_int_type_for_size (2, NULL, &ft->data_type)) + return -1; + break; + + /* 32 bit ints */ + case 'k': + ft->sizeof_type = 4; + if (-1 == get_int_type_for_size (4, &ft->data_type, NULL)) + return -1; + break; + case 'K': + ft->sizeof_type = 4; + if (-1 == get_int_type_for_size (4, NULL, &ft->data_type)) + return -1; + break; + + case 'x': + ft->sizeof_type = 1; + ft->data_type = 0; + break; + + case 'c': + ft->sizeof_type = 1; + ft->data_type = SLANG_CHAR_TYPE; + break; + + case 'C': + ft->data_type = SLANG_UCHAR_TYPE; + ft->sizeof_type = 1; + break; + + case 'S': + case 'A': + ft->pad = ' '; + case 'a': + case 's': + ft->data_type = SLANG_BSTRING_TYPE; + ft->sizeof_type = 1; + ft->is_scalar = 0; + break; + } + return 1; +} + +static int compute_size_for_format (char *format, unsigned int *num_bytes) +{ + unsigned int size; + Format_Type ft; + int status; + + *num_bytes = size = 0; + + while (1 == (status = parse_a_format (&format, &ft))) + size += ft.repeat * ft.sizeof_type; + + *num_bytes = size; + return status; +} + +static void byte_swap64 (unsigned char *ss, unsigned int n) /*{{{*/ +{ + unsigned char *p, *pmax, ch; + + if (n == 0) return; + p = (unsigned char *) ss; + pmax = p + 8 * n; + while (p < pmax) + { + ch = *p; + *p = *(p + 7); + *(p + 7) = ch; + + ch = *(p + 6); + *(p + 6) = *(p + 1); + *(p + 1) = ch; + + ch = *(p + 5); + *(p + 5) = *(p + 2); + *(p + 2) = ch; + + ch = *(p + 4); + *(p + 4) = *(p + 3); + *(p + 3) = ch; + + p += 8; + } +} + +/*}}}*/ +static void byte_swap32 (unsigned char *ss, unsigned int n) /*{{{*/ +{ + unsigned char *p, *pmax, ch; + + p = (unsigned char *) ss; + pmax = p + 4 * n; + while (p < pmax) + { + ch = *p; + *p = *(p + 3); + *(p + 3) = ch; + + ch = *(p + 1); + *(p + 1) = *(p + 2); + *(p + 2) = ch; + p += 4; + } +} + +/*}}}*/ +static void byte_swap16 (unsigned char *p, unsigned int nread) /*{{{*/ +{ + unsigned char *pmax, ch; + + pmax = p + 2 * nread; + while (p < pmax) + { + ch = *p; + *p = *(p + 1); + *(p + 1) = ch; + p += 2; + } +} + +/*}}}*/ + +static int byteswap (int order, unsigned char *b, unsigned int size, unsigned int num) +{ + if (Native_Byte_Order == order) + return 0; + + switch (size) + { + case 2: + byte_swap16 (b, num); + break; + case 4: + byte_swap32 (b, num); + break; + case 8: + byte_swap64 (b, num); + break; + default: + return -1; + } + + return 0; +} + +static void check_native_byte_order (void) +{ + unsigned short x; + + if (Native_Byte_Order != NATIVE_ORDER) + return; + + x = 0xFF; + if (*(unsigned char *)&x == 0xFF) + Native_Byte_Order = LILENDIAN_ORDER; + else + Native_Byte_Order = BIGENDIAN_ORDER; +} + +static SLang_BString_Type * +pack_according_to_format (char *format, unsigned int nitems) +{ + unsigned int size, num; + unsigned char *buf, *b; + SLang_BString_Type *bs; + Format_Type ft; + + buf = NULL; + + if (-1 == compute_size_for_format (format, &size)) + goto return_error; + + if (NULL == (buf = (unsigned char *) SLmalloc (size + 1))) + goto return_error; + + b = buf; + + while (1 == parse_a_format (&format, &ft)) + { + unsigned char *ptr; + unsigned int repeat; + + repeat = ft.repeat; + if (ft.data_type == 0) + { + memset ((char *) b, ft.pad, repeat); + b += repeat; + continue; + } + + if (ft.is_scalar) + { + unsigned char *bstart; + num = repeat; + + bstart = b; + while (repeat != 0) + { + unsigned int nelements; + SLang_Array_Type *at; + + if (nitems == 0) + { + SLang_verror (SL_INVALID_PARM, + "Not enough items for pack format"); + goto return_error; + } + + if (-1 == SLang_pop_array_of_type (&at, ft.data_type)) + goto return_error; + + nelements = at->num_elements; + if (repeat < nelements) + nelements = repeat; + repeat -= nelements; + + nelements = nelements * ft.sizeof_type; + memcpy ((char *)b, (char *)at->data, nelements); + + b += nelements; + SLang_free_array (at); + nitems--; + } + + if (ft.byteorder != NATIVE_ORDER) + byteswap (ft.byteorder, bstart, ft.sizeof_type, num); + + continue; + } + + /* Otherwise we have a string */ + if (-1 == SLang_pop_bstring (&bs)) + goto return_error; + + ptr = SLbstring_get_pointer (bs, &num); + if (repeat < num) num = repeat; + memcpy ((char *)b, (char *)ptr, num); + b += num; + repeat -= num; + memset ((char *)b, ft.pad, repeat); + SLbstring_free (bs); + b += repeat; + nitems--; + } + + *b = 0; + bs = SLbstring_create_malloced (buf, size, 0); + if (bs == NULL) + goto return_error; + + SLdo_pop_n (nitems); + return bs; + + return_error: + SLdo_pop_n (nitems); + if (buf != NULL) + SLfree ((char *) buf); + + return NULL; +} + +void _SLpack (void) +{ + SLang_BString_Type *bs; + char *fmt; + int nitems; + + check_native_byte_order (); + + nitems = SLang_Num_Function_Args; + if (nitems <= 0) + { + SLang_verror (SL_SYNTAX_ERROR, + "pack: not enough arguments"); + return; + } + + if ((-1 == SLreverse_stack (nitems)) + || (-1 == SLang_pop_slstring (&fmt))) + bs = NULL; + else + { + bs = pack_according_to_format (fmt, (unsigned int)nitems - 1); + SLang_free_slstring (fmt); + } + + SLang_push_bstring (bs); + SLbstring_free (bs); +} + +void _SLunpack (char *format, SLang_BString_Type *bs) +{ + Format_Type ft; + unsigned char *b; + unsigned int len; + unsigned int num_bytes; + + check_native_byte_order (); + + if (-1 == compute_size_for_format (format, &num_bytes)) + return; + + b = SLbstring_get_pointer (bs, &len); + if (b == NULL) + return; + + if (len < num_bytes) + { + SLang_verror (SL_INVALID_PARM, + "unpack format %s is too large for input string", + format); + return; + } + + while (1 == parse_a_format (&format, &ft)) + { + char *str, *s; + + if (ft.repeat == 0) + continue; + + if (ft.data_type == 0) + { /* skip padding */ + b += ft.repeat; + continue; + } + + if (ft.is_scalar) + { + SLang_Array_Type *at; + int dims; + + if (ft.repeat == 1) + { + SLang_Class_Type *cl; + + cl = _SLclass_get_class (ft.data_type); + memcpy ((char *)cl->cl_transfer_buf, (char *)b, ft.sizeof_type); + if (ft.byteorder != NATIVE_ORDER) + byteswap (ft.byteorder, (unsigned char *)cl->cl_transfer_buf, ft.sizeof_type, 1); + + if (-1 == (cl->cl_apush (ft.data_type, cl->cl_transfer_buf))) + return; + b += ft.sizeof_type; + continue; + } + + dims = (int) ft.repeat; + at = SLang_create_array (ft.data_type, 0, NULL, &dims, 1); + if (at == NULL) + return; + + num_bytes = ft.repeat * ft.sizeof_type; + memcpy ((char *)at->data, (char *)b, num_bytes); + if (ft.byteorder != NATIVE_ORDER) + byteswap (ft.byteorder, (unsigned char *)at->data, ft.sizeof_type, ft.repeat); + + if (-1 == SLang_push_array (at, 1)) + return; + + b += num_bytes; + continue; + } + + len = ft.repeat; + str = SLmalloc (len + 1); + if (str == NULL) + return; + + memcpy ((char *) str, (char *)b, len); + str [len] = 0; + + if (ft.pad == ' ') + { + unsigned int new_len; + + s = str + len; + while (s > str) + { + s--; + if ((*s != ' ') && (*s != 0)) + { + s++; + break; + } + *s = 0; + } + new_len = (unsigned int) (s - str); + + if (new_len != len) + { + s = SLrealloc (str, new_len + 1); + if (s == NULL) + { + SLfree (str); + return; + } + str = s; + len = new_len; + } + } + + /* Avoid a bstring if possible */ + s = SLmemchr (str, 0, len); + if (s == NULL) + { + if (-1 == SLang_push_malloced_string (str)) + return; + } + else + { + SLang_BString_Type *new_bs; + + new_bs = SLbstring_create_malloced ((unsigned char *)str, len, 1); + if (new_bs == NULL) + return; + + if (-1 == SLang_push_bstring (new_bs)) + { + SLfree (str); + return; + } + SLbstring_free (new_bs); + } + + b += ft.repeat; + } +} + +unsigned int _SLpack_compute_size (char *format) +{ + unsigned int n; + + n = 0; + (void) compute_size_for_format (format, &n); + return n; +} + +void _SLpack_pad_format (char *format) +{ + unsigned int len, max_len; + Format_Type ft; + char *buf, *b; + + check_native_byte_order (); + + /* Just check the syntax */ + if (-1 == compute_size_for_format (format, &max_len)) + return; + + /* This should be sufficient to handle any needed xyy padding characters. + * I cannot see how this will be overrun + */ + max_len = 4 * (strlen (format) + 1); + if (NULL == (buf = SLmalloc (max_len + 1))) + return; + + b = buf; + len = 0; + while (1 == parse_a_format (&format, &ft)) + { + struct { char a; short b; } s_h; + struct { char a; int b; } s_i; + struct { char a; long b; } s_l; + struct { char a; float b; } s_f; + struct { char a; double b; } s_d; + unsigned int pad; + + if (ft.repeat == 0) + continue; + + if (ft.data_type == 0) + { /* pad */ + sprintf (b, "x%u", ft.repeat); + b += strlen (b); + len += ft.repeat; + continue; + } + + switch (ft.data_type) + { + default: + case SLANG_STRING_TYPE: + case SLANG_BSTRING_TYPE: + case SLANG_CHAR_TYPE: + case SLANG_UCHAR_TYPE: + pad = 0; + break; + + case SLANG_SHORT_TYPE: + case SLANG_USHORT_TYPE: + pad = ((unsigned int) ((char *)&s_h.b - (char *)&s_h.a)); + break; + + case SLANG_INT_TYPE: + case SLANG_UINT_TYPE: + pad = ((unsigned int) ((char *)&s_i.b - (char *)&s_i.a)); + break; + + case SLANG_LONG_TYPE: + case SLANG_ULONG_TYPE: + pad = ((unsigned int) ((char *)&s_l.b - (char *)&s_l.a)); + break; + + case SLANG_FLOAT_TYPE: + pad = ((unsigned int) ((char *)&s_f.b - (char *)&s_f.a)); + break; + + case SLANG_DOUBLE_TYPE: + pad = ((unsigned int) ((char *)&s_d.b - (char *)&s_d.a)); + break; + } + + /* Pad to a length that is an integer multiple of pad. */ + if (pad) + pad = pad * ((len + pad - 1)/pad) - len; + + if (pad) + { + sprintf (b, "x%u", pad); + b += strlen (b); + len += pad; + } + + *b++ = ft.format_type; + if (ft.repeat > 1) + { + sprintf (b, "%u", ft.repeat); + b += strlen (b); + } + + len += ft.repeat * ft.sizeof_type; + } + *b = 0; + + (void) SLang_push_malloced_string (buf); +} diff --git a/mdk-stage1/slang/slparse.c b/mdk-stage1/slang/slparse.c new file mode 100644 index 000000000..bc709d1fb --- /dev/null +++ b/mdk-stage1/slang/slparse.c @@ -0,0 +1,1970 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static SLang_Load_Type *LLT; +int _SLang_Compile_Line_Num_Info; + +static void free_token (_SLang_Token_Type *t) +{ + register unsigned int nrefs = t->num_refs; + + if (nrefs == 0) + return; + + if (nrefs == 1) + { + if (t->free_sval_flag) + { + if (t->type == BSTRING_TOKEN) + SLbstring_free (t->v.b_val); + else + _SLfree_hashed_string (t->v.s_val, strlen (t->v.s_val), t->hash); + t->v.s_val = NULL; + } + } + + t->num_refs = nrefs - 1; +} + +static void init_token (_SLang_Token_Type *t) +{ + memset ((char *) t, 0, sizeof (_SLang_Token_Type)); +#if _SLANG_HAS_DEBUG_CODE + t->line_number = -1; +#endif +} + +/* Allow room for one push back of a token. This is necessary for + * multiple assignment. + */ +static unsigned int Use_Next_Token; +static _SLang_Token_Type Next_Token; +#if _SLANG_HAS_DEBUG_CODE +static int Last_Line_Number = -1; +#endif + +static int unget_token (_SLang_Token_Type *ctok) +{ + if (SLang_Error) + return -1; + if (Use_Next_Token != 0) + { + _SLparse_error ("unget_token failed", ctok, 0); + return -1; + } + + Use_Next_Token++; + Next_Token = *ctok; + init_token (ctok); + return 0; +} + +static int get_token (_SLang_Token_Type *ctok) +{ + if (ctok->num_refs) + free_token (ctok); + + if (Use_Next_Token) + { + Use_Next_Token--; + *ctok = Next_Token; + return ctok->type; + } + + return _SLget_token (ctok); +} + +static int compile_token (_SLang_Token_Type *t) +{ +#if _SLANG_HAS_DEBUG_CODE + if (_SLang_Compile_Line_Num_Info + && (t->line_number != Last_Line_Number) + && (t->line_number != -1)) + { + _SLang_Token_Type tok; + tok.type = LINE_NUM_TOKEN; + tok.v.long_val = Last_Line_Number = t->line_number; + (*_SLcompile_ptr) (&tok); + } +#endif + (*_SLcompile_ptr) (t); + return 0; +} + +typedef struct +{ +#define USE_PARANOID_MAGIC 0 +#if USE_PARANOID_MAGIC + unsigned long magic; +#endif + _SLang_Token_Type *stack; + unsigned int len; + unsigned int size; +} +Token_List_Type; + +#define MAX_TOKEN_LISTS 16 +static Token_List_Type Token_List_Stack [MAX_TOKEN_LISTS]; +static unsigned int Token_List_Stack_Depth = 0; +static Token_List_Type *Token_List = NULL; + +static void init_token_list (Token_List_Type *t) +{ + t->size = 0; + t->len = 0; + t->stack = NULL; +#if USE_PARANOID_MAGIC + t->magic = 0xABCDEF12; +#endif +} + +static void free_token_list (Token_List_Type *t) +{ + _SLang_Token_Type *s; + + if (t == NULL) + return; +#if USE_PARANOID_MAGIC + if (t->magic != 0xABCDEF12) + { + SLang_doerror ("Magic error."); + return; + } +#endif + s = t->stack; + if (s != NULL) + { + _SLang_Token_Type *smax = s + t->len; + while (s != smax) + { + if (s->num_refs) free_token (s); + s++; + } + + SLfree ((char *) t->stack); + } + + memset ((char *) t, 0, sizeof (Token_List_Type)); +} + +static Token_List_Type *push_token_list (void) +{ + if (Token_List_Stack_Depth == MAX_TOKEN_LISTS) + { + _SLparse_error ("Token list stack size exceeded", NULL, 0); + return NULL; + } + + Token_List = Token_List_Stack + Token_List_Stack_Depth; + Token_List_Stack_Depth++; + init_token_list (Token_List); + return Token_List; +} + +static int pop_token_list (int do_free) +{ + if (Token_List_Stack_Depth == 0) + { + if (SLang_Error == 0) + _SLparse_error ("Token list stack underflow", NULL, 0); + return -1; + } + Token_List_Stack_Depth--; + + if (do_free) free_token_list (Token_List); + + if (Token_List_Stack_Depth != 0) + Token_List = Token_List_Stack + (Token_List_Stack_Depth - 1); + else + Token_List = NULL; + + return 0; +} + +static int check_token_list_space (Token_List_Type *t, unsigned int delta_size) +{ + _SLang_Token_Type *st; + unsigned int len; +#if USE_PARANOID_MAGIC + if (t->magic != 0xABCDEF12) + { + SLang_doerror ("Magic error."); + return -1; + } +#endif + len = t->len + delta_size; + if (len <= t->size) return 0; + + if (delta_size < 4) + { + delta_size = 4; + len = t->len + delta_size; + } + + st = (_SLang_Token_Type *) SLrealloc((char *) t->stack, + len * sizeof(_SLang_Token_Type)); + if (st == NULL) + { + _SLparse_error ("Malloc error", NULL, 0); + return -1; + } + + memset ((char *) (st + t->len), 0, delta_size); + + t->stack = st; + t->size = len; + return 0; +} + +static int append_token (_SLang_Token_Type *t) +{ + if (-1 == check_token_list_space (Token_List, 1)) + return -1; + + Token_List->stack [Token_List->len] = *t; + Token_List->len += 1; + t->num_refs = 0; /* stealing it */ + return 0; +} + +static int append_token_of_type (unsigned char t) +{ + _SLang_Token_Type *tok; + + if (-1 == check_token_list_space (Token_List, 1)) + return -1; + + /* The memset when the list was created ensures that the other fields + * are properly initialized. + */ + tok = Token_List->stack + Token_List->len; + init_token (tok); + tok->type = t; + Token_List->len += 1; + return 0; +} + +static _SLang_Token_Type *get_last_token (void) +{ + unsigned int len; + + if ((Token_List == NULL) + || (0 == (len = Token_List->len))) + return NULL; + + len--; + return Token_List->stack + len; +} + +/* This function does NOT free the list. */ +static int compile_token_list_with_fun (int dir, Token_List_Type *list, + int (*f)(_SLang_Token_Type *)) +{ + _SLang_Token_Type *t0, *t1; + + if (list == NULL) + return -1; + + if (f == NULL) + f = compile_token; + + t0 = list->stack; + t1 = t0 + list->len; + + if (dir < 0) + { + /* backwards */ + + while ((SLang_Error == 0) && (t1 > t0)) + { + t1--; + (*f) (t1); + } + return 0; + } + + /* forward */ + while ((SLang_Error == 0) && (t0 < t1)) + { + (*f) (t0); + t0++; + } + return 0; +} + +static int compile_token_list (void) +{ + if (Token_List == NULL) + return -1; + + compile_token_list_with_fun (1, Token_List, NULL); + pop_token_list (1); + return 0; +} + +/* Take all elements in the list from pos2 to the end and exchange them + * with the elements at pos1, e.g., + * ...ABCDEabc ==> ...abcABCDE + * where pos1 denotes A and pos2 denotes a. + */ +static int token_list_element_exchange (unsigned int pos1, unsigned int pos2) +{ + _SLang_Token_Type *s, *s1, *s2; + unsigned int len, nloops; + + if (Token_List == NULL) + return -1; + + s = Token_List->stack; + len = Token_List->len; + + if ((s == NULL) || (len == 0) + || (pos2 >= len)) + return -1; + + /* This may not be the most efficient algorithm but the number to swap + * is most-likely going to be small, e.g, 3 + * The algorithm is to rotate the list. The particular rotation + * direction was chosen to make insert_token fast. + * It works like: + * @ ABCabcde --> BCabcdeA --> CabcdeAB --> abcdefAB + * which is optimal for Abcdef sequence produced by function calls. + * + * Profiling indicates that nloops is almost always 1, whereas the inner + * loop can loop many times (e.g., 9 times). + */ + + s2 = s + (len - 1); + s1 = s + pos1; + nloops = pos2 - pos1; + + while (nloops) + { + _SLang_Token_Type save; + + s = s1; + save = *s; + + while (s < s2) + { + *s = *(s + 1); + s++; + } + *s = save; + + nloops--; + } + return 0; +} + +#if 0 +static int insert_token (_SLang_Token_Type *t, unsigned int pos) +{ + if (-1 == append_token (t)) + return -1; + + return token_list_element_exchange (pos, Token_List->len - 1); +} +#endif +static void compile_token_of_type (unsigned char t) +{ + _SLang_Token_Type tok; + +#if _SLANG_HAS_DEBUG_CODE + tok.line_number = -1; +#endif + tok.type = t; + compile_token(&tok); +} + +static void statement (_SLang_Token_Type *); +static void compound_statement (_SLang_Token_Type *); +static void expression_with_parenthesis (_SLang_Token_Type *); +static void handle_semicolon (_SLang_Token_Type *); +static void statement_list (_SLang_Token_Type *); +static void variable_list (_SLang_Token_Type *, unsigned char); +static void struct_declaration (_SLang_Token_Type *); +static void define_function_args (_SLang_Token_Type *); +static void typedef_definition (_SLang_Token_Type *); +static void function_args_expression (_SLang_Token_Type *, int); +static void expression (_SLang_Token_Type *); +static void expression_with_commas (_SLang_Token_Type *, int); +static void simple_expression (_SLang_Token_Type *); +static void unary_expression (_SLang_Token_Type *); +static void postfix_expression (_SLang_Token_Type *); +static int check_for_lvalue (unsigned char, _SLang_Token_Type *); +/* static void primary_expression (_SLang_Token_Type *); */ +static void block (_SLang_Token_Type *); +static void inline_array_expression (_SLang_Token_Type *); +static void array_index_expression (_SLang_Token_Type *); +static void do_multiple_assignment (_SLang_Token_Type *); +static void try_multiple_assignment (_SLang_Token_Type *); +#if 0 +static void not_implemented (char *what) +{ + char err [256]; + sprintf (err, "Expression not implemented: %s", what); + _SLparse_error (err, NULL, 0); +} +#endif +static void rpn_parse_line (_SLang_Token_Type *tok) +{ + do + { + /* multiple RPN tokens possible when the file looks like: + * . <end of line> + * . <end of line> + */ + if (tok->type != RPN_TOKEN) + compile_token (tok); + free_token (tok); + } + while (EOF_TOKEN != _SLget_rpn_token (tok)); +} + +static int get_identifier_token (_SLang_Token_Type *tok) +{ + if (IDENT_TOKEN == get_token (tok)) + return IDENT_TOKEN; + + _SLparse_error ("Expecting identifier", tok, 0); + return tok->type; +} + +static void define_function (_SLang_Token_Type *ctok, unsigned char type) +{ + _SLang_Token_Type fname; + + switch (type) + { + case STATIC_TOKEN: + type = DEFINE_STATIC_TOKEN; + break; + + case PUBLIC_TOKEN: + type = DEFINE_PUBLIC_TOKEN; + break; + + case PRIVATE_TOKEN: + type = DEFINE_PRIVATE_TOKEN; + } + + init_token (&fname); + if (IDENT_TOKEN != get_identifier_token (&fname)) + { + free_token (&fname); + return; + } + + compile_token_of_type(OPAREN_TOKEN); + get_token (ctok); + define_function_args (ctok); + compile_token_of_type(FARG_TOKEN); + + if (ctok->type == OBRACE_TOKEN) + compound_statement(ctok); + + else if (ctok->type != SEMICOLON_TOKEN) + { + _SLparse_error("Expecting {", ctok, 0); + free_token (&fname); + return; + } + + fname.type = type; + compile_token (&fname); + free_token (&fname); +} + +/* statement: + * compound-statement + * if ( expression ) statement + * if ( expression ) statement else statement + * !if ( expression ) statement + * loop ( expression ) statement + * _for ( expression ) statement + * foreach ( expression ) statement + * foreach (expression ) using (expression-list) statement + * while ( expression ) statement + * do statement while (expression) ; + * for ( expressionopt ; expressionopt ; expressionopt ) statement + * ERROR_BLOCK statement + * EXIT_BLOCK statement + * USER_BLOCK0 statement + * USER_BLOCK1 statement + * USER_BLOCK2 statement + * USER_BLOCK3 statement + * USER_BLOCK4 statement + * forever statement + * break ; + * continue ; + * return expressionopt ; + * variable variable-list ; + * struct struct-decl ; + * define identifier function-args ; + * define identifier function-args compound-statement + * switch ( expression ) statement + * rpn-line + * at-line + * push ( expression ) + * ( expression ) = expression ; + * expression ; + * expression : + */ + +/* Note: This function does not return with a new token. It is up to the + * calling routine to handle that. + */ +static void statement (_SLang_Token_Type *ctok) +{ + unsigned char type; + + if (SLang_Error) + return; + + LLT->parse_level += 1; + + switch (ctok->type) + { + case OBRACE_TOKEN: + compound_statement (ctok); + break; + + case IF_TOKEN: + case IFNOT_TOKEN: + type = ctok->type; + get_token (ctok); + expression_with_parenthesis (ctok); + block (ctok); + + if (ELSE_TOKEN != get_token (ctok)) + { + compile_token_of_type (type); + unget_token (ctok); + break; + } + get_token (ctok); + block (ctok); + if (type == IF_TOKEN) type = ELSE_TOKEN; else type = NOTELSE_TOKEN; + compile_token_of_type (type); + break; + + /* case IFNOT_TOKEN: */ + case LOOP_TOKEN: + case _FOR_TOKEN: + type = ctok->type; + get_token (ctok); + expression_with_parenthesis (ctok); + block (ctok); + compile_token_of_type (type); + break; + + case FOREACH_TOKEN: + get_token (ctok); + expression_with_parenthesis (ctok); + + if (NULL == push_token_list ()) + break; + + append_token_of_type (ARG_TOKEN); + if (ctok->type == USING_TOKEN) + { + if (OPAREN_TOKEN != get_token (ctok)) + { + _SLparse_error ("Expected 'using ('", ctok, 0); + break; + } + get_token (ctok); + function_args_expression (ctok, 0); + } + append_token_of_type (EARG_TOKEN); + + compile_token_list (); + + block (ctok); + compile_token_of_type (FOREACH_TOKEN); + break; + + case WHILE_TOKEN: + get_token (ctok); + compile_token_of_type (OBRACE_TOKEN); + expression_with_parenthesis (ctok); + compile_token_of_type (CBRACE_TOKEN); + block (ctok); + compile_token_of_type (WHILE_TOKEN); + break; + + case DO_TOKEN: + get_token (ctok); + block (ctok); + + if (WHILE_TOKEN != get_token (ctok)) + { + _SLparse_error("Expecting while", ctok, 0); + break; + } + + get_token (ctok); + + compile_token_of_type (OBRACE_TOKEN); + expression_with_parenthesis (ctok); + compile_token_of_type (CBRACE_TOKEN); + compile_token_of_type (DOWHILE_TOKEN); + handle_semicolon (ctok); + break; + + case FOR_TOKEN: + + /* Look for (exp_opt ; exp_opt ; exp_opt ) */ + + if (OPAREN_TOKEN != get_token (ctok)) + { + _SLparse_error("Expecting (.", ctok, 0); + break; + } + + if (NULL == push_token_list ()) + break; + + append_token_of_type (OBRACE_TOKEN); + if (SEMICOLON_TOKEN != get_token (ctok)) + { + expression (ctok); + if (ctok->type != SEMICOLON_TOKEN) + { + _SLparse_error("Expecting ;", ctok, 0); + break; + } + } + append_token_of_type (CBRACE_TOKEN); + + append_token_of_type (OBRACE_TOKEN); + if (SEMICOLON_TOKEN != get_token (ctok)) + { + expression (ctok); + if (ctok->type != SEMICOLON_TOKEN) + { + _SLparse_error("Expecting ;", ctok, 0); + break; + } + } + append_token_of_type (CBRACE_TOKEN); + + append_token_of_type (OBRACE_TOKEN); + if (CPAREN_TOKEN != get_token (ctok)) + { + expression (ctok); + if (ctok->type != CPAREN_TOKEN) + { + _SLparse_error("Expecting ).", ctok, 0); + break; + } + } + append_token_of_type (CBRACE_TOKEN); + + compile_token_list (); + + get_token (ctok); + block (ctok); + compile_token_of_type (FOR_TOKEN); + break; + + case ERRBLK_TOKEN: + case EXITBLK_TOKEN: + case USRBLK0_TOKEN: + case USRBLK1_TOKEN: + case USRBLK2_TOKEN: + case USRBLK3_TOKEN: + case USRBLK4_TOKEN: + case FOREVER_TOKEN: + type = ctok->type; + get_token (ctok); + block (ctok); + compile_token_of_type (type); + break; + + case BREAK_TOKEN: + case CONT_TOKEN: + compile_token_of_type (ctok->type); + get_token (ctok); + handle_semicolon (ctok); + break; + + case RETURN_TOKEN: + if (SEMICOLON_TOKEN != get_token (ctok)) + { + if (NULL == push_token_list ()) + break; + + expression (ctok); + + if (ctok->type != SEMICOLON_TOKEN) + { + _SLparse_error ("Expecting ;", ctok, 0); + break; + } + compile_token_list (); + } + compile_token_of_type (RETURN_TOKEN); + handle_semicolon (ctok); + break; + + case STATIC_TOKEN: + case PRIVATE_TOKEN: + case PUBLIC_TOKEN: + type = ctok->type; + get_token (ctok); + if (ctok->type == VARIABLE_TOKEN) + { + get_token (ctok); + variable_list (ctok, type); + handle_semicolon (ctok); + break; + } + if (ctok->type == DEFINE_TOKEN) + { + define_function (ctok, type); + break; + } + _SLparse_error ("Expecting 'variable' or 'define'", ctok, 0); + break; + + case VARIABLE_TOKEN: + get_token (ctok); + variable_list (ctok, OBRACKET_TOKEN); + handle_semicolon (ctok); + break; + + case TYPEDEF_TOKEN: + get_token (ctok); + if (NULL == push_token_list ()) + break; + typedef_definition (ctok); + compile_token_list (); + + handle_semicolon (ctok); + break; + + case DEFINE_TOKEN: + define_function (ctok, DEFINE_TOKEN); + break; + + case SWITCH_TOKEN: + get_token (ctok); + expression_with_parenthesis (ctok); + + while ((SLang_Error == 0) + && (OBRACE_TOKEN == ctok->type)) + { + compile_token_of_type (OBRACE_TOKEN); + compound_statement (ctok); + compile_token_of_type (CBRACE_TOKEN); + get_token (ctok); + } + compile_token_of_type (SWITCH_TOKEN); + unget_token (ctok); + break; + + case EOF_TOKEN: + break; +#if 0 + case PUSH_TOKEN: + get_token (ctok); + expression_list_with_parenthesis (ctok); + handle_semicolon (ctok); + break; +#endif + + case SEMICOLON_TOKEN: + handle_semicolon (ctok); + break; + + case RPN_TOKEN: + if (POUND_TOKEN == get_token (ctok)) + _SLcompile_byte_compiled (); + else if (ctok->type != EOF_TOKEN) + rpn_parse_line (ctok); + break; + + case OPAREN_TOKEN: /* multiple assignment */ + try_multiple_assignment (ctok); + if (ctok->type == COLON_TOKEN) + compile_token_of_type (COLON_TOKEN); + else handle_semicolon (ctok); + break; + + default: + + if (NULL == push_token_list ()) + break; + + expression (ctok); + compile_token_list (); + + if (ctok->type == COLON_TOKEN) + compile_token_of_type (COLON_TOKEN); + else handle_semicolon (ctok); + break; + } + + LLT->parse_level -= 1; +} + +static void block (_SLang_Token_Type *ctok) +{ + compile_token_of_type (OBRACE_TOKEN); + statement (ctok); + compile_token_of_type (CBRACE_TOKEN); +} + +/* + * statement-list: + * statement + * statement-list statement + */ +static void statement_list (_SLang_Token_Type *ctok) +{ + while ((SLang_Error == 0) + && (ctok->type != CBRACE_TOKEN) + && (ctok->type != EOF_TOKEN)) + { + statement(ctok); + get_token (ctok); + } +} + +/* compound-statement: + * { statement-list } + */ +static void compound_statement (_SLang_Token_Type *ctok) +{ + /* ctok->type is OBRACE_TOKEN here */ + get_token (ctok); + statement_list(ctok); + if (CBRACE_TOKEN != ctok->type) + { + _SLparse_error ("Expecting '}'", ctok, 0); + return; + } +} + +/* This function is only called from statement. */ +static void expression_with_parenthesis (_SLang_Token_Type *ctok) +{ + if (ctok->type != OPAREN_TOKEN) + { + _SLparse_error("Expecting (", ctok, 0); + return; + } + + if (NULL == push_token_list ()) + return; + + get_token (ctok); + expression (ctok); + + if (ctok->type != CPAREN_TOKEN) + _SLparse_error("Expecting )", ctok, 0); + + compile_token_list (); + + get_token (ctok); +} + +static void handle_semicolon (_SLang_Token_Type *ctok) +{ + if ((ctok->type == SEMICOLON_TOKEN) + || (ctok->type == EOF_TOKEN)) + return; + + _SLparse_error ("Expecting ;", ctok, 0); +} + +void _SLparse_start (SLang_Load_Type *llt) +{ + _SLang_Token_Type ctok; + SLang_Load_Type *save_llt; + unsigned int save_use_next_token; + _SLang_Token_Type save_next_token; + Token_List_Type *save_list; +#if _SLANG_HAS_DEBUG_CODE + int save_last_line_number = Last_Line_Number; + + Last_Line_Number = -1; +#endif + save_use_next_token = Use_Next_Token; + save_next_token = Next_Token; + save_list = Token_List; + save_llt = LLT; + LLT = llt; + + init_token (&Next_Token); + Use_Next_Token = 0; + init_token (&ctok); + get_token (&ctok); + + llt->parse_level = 0; + statement_list (&ctok); + + if ((SLang_Error == 0) + && (ctok.type != EOF_TOKEN)) + _SLparse_error ("Parse ended prematurely", &ctok, 0); + + + if (SLang_Error) + { + if (SLang_Error < 0) /* severe error */ + save_list = NULL; + + while (Token_List != save_list) + { + if (-1 == pop_token_list (1)) + break; /* ??? when would this happen? */ + } + } + + free_token (&ctok); + LLT = save_llt; + if (Use_Next_Token) + free_token (&Next_Token); + Use_Next_Token = save_use_next_token; + Next_Token = save_next_token; +#if _SLANG_HAS_DEBUG_CODE + Last_Line_Number = save_last_line_number; +#endif +} + +/* variable-list: + * variable-decl + * variable-decl variable-list + * + * variable-decl: + * identifier + * identifier = simple-expression + */ +static void variable_list (_SLang_Token_Type *name_token, unsigned char variable_type) +{ + int declaring; + _SLang_Token_Type tok; + + if (name_token->type != IDENT_TOKEN) + { + _SLparse_error ("Expecting a variable name", name_token, 0); + return; + } + + declaring = 0; + do + { + if (declaring == 0) + { + declaring = 1; + compile_token_of_type (variable_type); + } + + compile_token (name_token); + + init_token (&tok); + if (ASSIGN_TOKEN == get_token (&tok)) + { + compile_token_of_type (CBRACKET_TOKEN); + declaring = 0; + + get_token (&tok); + + push_token_list (); + simple_expression (&tok); + compile_token_list (); + + name_token->type = _SCALAR_ASSIGN_TOKEN; + compile_token (name_token); + } + + free_token (name_token); + *name_token = tok; + } + while ((name_token->type == COMMA_TOKEN) + && (IDENT_TOKEN == get_token (name_token))); + + if (declaring) compile_token_of_type (CBRACKET_TOKEN); +} + +/* struct-declaration: + * struct { struct-field-list }; + * + * struct-field-list: + * struct-field-name , struct-field-list + * struct-field-name + * + * Generates code: "field-name-1" ... "field-name-N" N STRUCT_TOKEN + */ +static void struct_declaration (_SLang_Token_Type *ctok) +{ + int n; + _SLang_Token_Type num_tok; + + if (ctok->type != OBRACE_TOKEN) + { + _SLparse_error ("Expecting {", ctok, 0); + return; + } + + n = 0; + while (IDENT_TOKEN == get_token (ctok)) + { + n++; + ctok->type = STRING_TOKEN; + append_token (ctok); + if (COMMA_TOKEN != get_token (ctok)) + break; + } + + if (ctok->type != CBRACE_TOKEN) + { + _SLparse_error ("Expecting }", ctok, 0); + return; + } + if (n == 0) + { + _SLparse_error ("struct requires at least 1 field", ctok, 0); + return; + } + + init_token (&num_tok); + num_tok.type = INT_TOKEN; + num_tok.v.long_val = n; + append_token (&num_tok); + append_token_of_type (STRUCT_TOKEN); + + get_token (ctok); +} + +/* struct-declaration: + * typedef struct { struct-field-list } Type_Name; + * + * struct-field-list: + * struct-field-name , struct-field-list + * struct-field-name + * + * Generates code: "field-name-1" ... "field-name-N" N STRUCT_TOKEN typedef + */ +static void typedef_definition (_SLang_Token_Type *t) +{ + + if (t->type != STRUCT_TOKEN) + { + _SLparse_error ("Expecting `struct'", t, 0); + return; + } + get_token (t); + + struct_declaration (t); + if (t->type != IDENT_TOKEN) + { + _SLparse_error ("Expecting identifier", t, 0); + return; + } + + t->type = STRING_TOKEN; + append_token (t); + append_token_of_type (TYPEDEF_TOKEN); + + get_token (t); +} + +/* function-args: + * ( args-dec-opt ) + * + * args-decl-opt: + * identifier + * args-decl , identifier + */ +static void define_function_args (_SLang_Token_Type *ctok) +{ + if (CPAREN_TOKEN == get_token (ctok)) + { + get_token (ctok); + return; + } + + compile_token_of_type(OBRACKET_TOKEN); + + while ((SLang_Error == 0) + && (ctok->type == IDENT_TOKEN)) + { + compile_token (ctok); + if (COMMA_TOKEN != get_token (ctok)) + break; + + get_token (ctok); + } + + if (CPAREN_TOKEN != ctok->type) + { + _SLparse_error("Expecting )", ctok, 0); + return; + } + compile_token_of_type(CBRACKET_TOKEN); + + get_token (ctok); +} + +void try_multiple_assignment (_SLang_Token_Type *ctok) +{ + /* This is called with ctok->type == OPAREN_TOKEN. We have no idea + * what follows this. There are various possibilities such as: + * @ () = x; + * @ ( expression ) = x; + * @ ( expression ) ; + * @ ( expression ) OP expression; + * @ ( expression ) [expression] = expression; + * and only the first two constitute a multiple assignment. The last + * two forms create the difficulty. + * + * Here is the plan. First parse (expression) and then check next token. + * If it is an equal operator, then it will be parsed as a multiple + * assignment. In fact, that is the easy part. + * + * The hard part stems from the fact that by parsing (expression), we + * have effectly truncated the parse if (expression) is part of a binary + * or unary expression. Somehow, the parsing must be resumed. The trick + * here is to use a dummy literal that generates no code: NO_OP_LITERAL + * Using it, we just call 'expression' and proceed. + */ + + if (NULL == push_token_list ()) + return; + + get_token (ctok); + + if (ctok->type != CPAREN_TOKEN) + { + expression_with_commas (ctok, 1); + if (ctok->type != CPAREN_TOKEN) + { + _SLparse_error ("Expecting )", ctok, 0); + return; + } + } + + switch (get_token (ctok)) + { + case ASSIGN_TOKEN: + case PLUSEQS_TOKEN: + case MINUSEQS_TOKEN: + case TIMESEQS_TOKEN: + case DIVEQS_TOKEN: + case BOREQS_TOKEN: + case BANDEQS_TOKEN: + do_multiple_assignment (ctok); + pop_token_list (1); + break; + + default: + unget_token (ctok); + ctok->type = NO_OP_LITERAL; + expression (ctok); + compile_token_list (); + break; + } +} + +/* Note: expression never gets compiled directly. Rather, it gets + * appended to the token list and then compiled by a calling + * routine. + */ + +/* expression: + * simple_expression + * simple-expression , expression + * <none> + */ +static void expression_with_commas (_SLang_Token_Type *ctok, int save_comma) +{ + while (SLang_Error == 0) + { + if (ctok->type != COMMA_TOKEN) + { + if (ctok->type == CPAREN_TOKEN) + return; + + simple_expression (ctok); + + if (ctok->type != COMMA_TOKEN) + break; + } + if (save_comma) append_token (ctok); + get_token (ctok); + } +} + +static void expression (_SLang_Token_Type *ctok) +{ + expression_with_commas (ctok, 0); +} + +/* priority levels of binary operations */ +static unsigned char Binop_Level[] = +{ +/* ADD_TOKEN */ 2, +/* SUB_TOKEN */ 2, +/* MUL_TOKEN */ 1, +/* DIV_TOKEN */ 1, +/* LT_TOKEN */ 4, +/* LE_TOKEN */ 4, +/* GT_TOKEN */ 4, +/* GE_TOKEN */ 4, +/* EQ_TOKEN */ 5, +/* NE_TOKEN */ 5, +/* AND_TOKEN */ 9, +/* OR_TOKEN */ 10, +/* MOD_TOKEN */ 1, +/* BAND_TOKEN */ 6, +/* SHL_TOKEN */ 3, +/* SHR_TOKEN */ 3, +/* BXOR_TOKEN */ 7, +/* BOR_TOKEN */ 8, +/* POUND_TOKEN */ 1 /* Matrix Multiplication */ +}; + +/* % Note: simple-expression groups operators OP1 at same level. The + * % actual implementation will not do this. + * simple-expression: + * unary-expression + * binary-expression BINARY-OP unary-expression + * andelse xxelse-expression-list + * orelse xxelse-expression-list + * + * xxelse-expression-list: + * { expression } + * xxelse-expression-list { expression } + * binary-expression: + * unary-expression + * unary-expression BINARY-OP binary-expression + */ +static void simple_expression (_SLang_Token_Type *ctok) +{ + unsigned char type; + unsigned char op_stack [64]; + unsigned char level_stack [64]; + unsigned char level; + unsigned int op_num; + + switch (ctok->type) + { + case ANDELSE_TOKEN: + case ORELSE_TOKEN: + type = ctok->type; + if (OBRACE_TOKEN != get_token (ctok)) + { + _SLparse_error ("Expecting '{'", ctok, 0); + return; + } + + while (ctok->type == OBRACE_TOKEN) + { + append_token (ctok); + get_token (ctok); + expression (ctok); + if (CBRACE_TOKEN != ctok->type) + { + _SLparse_error("Expecting }", ctok, 0); + return; + } + append_token (ctok); + get_token (ctok); + } + append_token_of_type (type); + return; + + /* avoid unary-expression if possible */ + case STRING_TOKEN: + append_token (ctok); + get_token (ctok); + break; + + default: + unary_expression (ctok); + break; + } + + if (SEMICOLON_TOKEN == (type = ctok->type)) + return; + + op_num = 0; + + while ((SLang_Error == 0) + && (IS_BINARY_OP(type))) + { + level = Binop_Level[type - FIRST_BINARY_OP]; + + while ((op_num > 0) && (level_stack [op_num - 1] <= level)) + append_token_of_type (op_stack [--op_num]); + + if (op_num >= sizeof (op_stack) - 1) + { + _SLparse_error ("Binary op stack overflow", ctok, 0); + return; + } + + op_stack [op_num] = type; + level_stack [op_num] = level; + op_num++; + + get_token (ctok); + unary_expression (ctok); + type = ctok->type; + } + + while (op_num > 0) + append_token_of_type(op_stack[--op_num]); +} + +/* unary-expression: + * postfix-expression + * ++ postfix-expression + * -- postfix-expression + * case unary-expression + * OP3 unary-expression + * (OP3: + - ~ & not @) + * + * Note: This grammar permits: case case case WHATEVER + */ +static void unary_expression (_SLang_Token_Type *ctok) +{ + unsigned char save_unary_ops [16]; + unsigned int num_unary_ops; + unsigned char type; + _SLang_Token_Type *last_token; + + num_unary_ops = 0; + while (SLang_Error == 0) + { + type = ctok->type; + + switch (type) + { + case PLUSPLUS_TOKEN: + case MINUSMINUS_TOKEN: + get_token (ctok); + postfix_expression (ctok); + check_for_lvalue (type, NULL); + goto out_of_switch; + + case ADD_TOKEN: + get_token (ctok); /* skip it-- it's unary here */ + break; + + case SUB_TOKEN: + (void) get_token (ctok); + if (IS_INTEGER_TOKEN (ctok->type)) + { + ctok->v.long_val = -ctok->v.long_val; + break; + } + + if (num_unary_ops == 16) + goto stack_overflow_error; + save_unary_ops [num_unary_ops++] = CHS_TOKEN; + break; + + case DEREF_TOKEN: + case BNOT_TOKEN: + case NOT_TOKEN: + case CASE_TOKEN: + if (num_unary_ops == 16) + goto stack_overflow_error; + + save_unary_ops [num_unary_ops++] = type; + get_token (ctok); + break; + + /* Try to avoid ->postfix_expression->primary_expression + * subroutine calls. + */ + case STRING_TOKEN: + append_token (ctok); + get_token (ctok); + goto out_of_switch; + + default: + postfix_expression (ctok); + goto out_of_switch; + } + } + + out_of_switch: + if (num_unary_ops == 0) + return; + + if ((DEREF_TOKEN == save_unary_ops[num_unary_ops - 1]) + && (NULL != (last_token = get_last_token ())) + && (IS_ASSIGN_TOKEN(last_token->type))) + { + /* FIXME: Priority=medium + * This needs generalized so that things like @a.y = 1 will work properly. + */ + if ((num_unary_ops != 1) + || (last_token->type != _SCALAR_ASSIGN_TOKEN)) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "Only derefence assignments to simple variables are possible"); + return; + } + + last_token->type += (_DEREF_ASSIGN_TOKEN - _SCALAR_ASSIGN_TOKEN); + return; + } + + while (num_unary_ops) + { + num_unary_ops--; + append_token_of_type (save_unary_ops [num_unary_ops]); + } + return; + + stack_overflow_error: + _SLparse_error ("Too many unary operators.", ctok, 0); +} + +static int combine_namespace_tokens (_SLang_Token_Type *a, _SLang_Token_Type *b) +{ + char *sa, *sb, *sc; + unsigned int lena, lenb; + unsigned long hash; + + /* This is somewhat of a hack. Combine the TWO identifier names + * (NAMESPACE) and (name) into the form NAMESPACE->name. Then when the + * byte compiler compiles the object it will not be found. It will then + * check for this hack and make the appropriate namespace lookup. + */ + + sa = a->v.s_val; + sb = b->v.s_val; + + lena = strlen (sa); + lenb = strlen (sb); + + sc = SLmalloc (lena + lenb + 3); + if (sc == NULL) + return -1; + + strcpy (sc, sa); + strcpy (sc + lena, "->"); + strcpy (sc + lena + 2, sb); + + sb = _SLstring_make_hashed_string (sc, lena + lenb + 2, &hash); + SLfree (sc); + if (sb == NULL) + return -1; + + /* I can free this string because no other token should be referencing it. + * (num_refs == 1). + */ + _SLfree_hashed_string (sa, lena, a->hash); + a->v.s_val = sb; + a->hash = hash; + + return 0; +} + +static void append_identifier_token (_SLang_Token_Type *ctok) +{ + _SLang_Token_Type *last_token; + + append_token (ctok); + + if (NAMESPACE_TOKEN != get_token (ctok)) + return; + + if (IDENT_TOKEN != get_token (ctok)) + { + _SLparse_error ("Expecting name-space identifier", ctok, 0); + return; + } + + last_token = get_last_token (); + if (-1 == combine_namespace_tokens (last_token, ctok)) + return; + + (void) get_token (ctok); +} + +static int get_identifier_expr_token (_SLang_Token_Type *ctok) +{ + _SLang_Token_Type next_token; + + if (IDENT_TOKEN != get_identifier_token (ctok)) + return -1; + + init_token (&next_token); + if (NAMESPACE_TOKEN != get_token (&next_token)) + { + unget_token (&next_token); + return IDENT_TOKEN; + } + + if (IDENT_TOKEN != get_identifier_token (&next_token)) + { + free_token (&next_token); + return -1; + } + + if (-1 == combine_namespace_tokens (ctok, &next_token)) + { + free_token (&next_token); + return -1; + } + free_token (&next_token); + return IDENT_TOKEN; +} + +/* postfix-expression: + * primary-expression + * postfix-expression [ expression ] + * postfix-expression ( function-args-expression ) + * postfix-expression . identifier + * postfix-expression ^ unary-expression + * postfix-expression ++ + * postfix-expression -- + * postfix-expression = simple-expression + * postfix-expression += simple-expression + * postfix-expression -= simple-expression + * + * primary-expression: + * literal + * identifier-expr + * ( expression_opt ) + * [ inline-array-expression ] + * &identifier-expr + * struct-definition + * __tmp(identifier-expr) + * + * identifier-expr: + * identifier + * identifier->identifier + */ +static void postfix_expression (_SLang_Token_Type *ctok) +{ + unsigned int start_pos, end_pos; + unsigned char type; + + if (Token_List == NULL) + return; + + start_pos = Token_List->len; + + switch (ctok->type) + { + case IDENT_TOKEN: + append_identifier_token (ctok); + break; + + case CHAR_TOKEN: + case SHORT_TOKEN: + case INT_TOKEN: + case LONG_TOKEN: + case UCHAR_TOKEN: + case USHORT_TOKEN: + case UINT_TOKEN: + case ULONG_TOKEN: + case STRING_TOKEN: + case BSTRING_TOKEN: +#ifdef SLANG_HAS_FLOAT + case DOUBLE_TOKEN: + case FLOAT_TOKEN: +#endif +#ifdef SLANG_HAS_COMPLEX + case COMPLEX_TOKEN: +#endif + append_token (ctok); + get_token (ctok); + break; + + case OPAREN_TOKEN: + if (CPAREN_TOKEN != get_token (ctok)) + { + expression (ctok); + if (ctok->type != CPAREN_TOKEN) + _SLparse_error("Expecting )", ctok, 0); + } + get_token (ctok); + break; + + case BAND_TOKEN: + if (IDENT_TOKEN != get_identifier_expr_token (ctok)) + break; + + ctok->type = _REF_TOKEN; + append_token (ctok); + get_token (ctok); + break; + + case OBRACKET_TOKEN: + get_token (ctok); + inline_array_expression (ctok); + break; + + case NO_OP_LITERAL: + /* This token was introduced by try_multiple_assignment. There, + * a new token_list was pushed and (expression) was evaluated. + * NO_OP_LITERAL represents the result of expression. However, + * we need to tweak the start_pos variable to point to the beginning + * of the token list to complete the equivalence. + */ + start_pos = 0; + get_token (ctok); + break; + + case STRUCT_TOKEN: + get_token (ctok); + struct_declaration (ctok); + break; + + case TMP_TOKEN: + get_token (ctok); + if (ctok->type == OPAREN_TOKEN) + { + if (IDENT_TOKEN == get_identifier_expr_token (ctok)) + { + ctok->type = TMP_TOKEN; + append_token (ctok); + get_token (ctok); + if (ctok->type == CPAREN_TOKEN) + { + get_token (ctok); + break; + } + } + } + _SLparse_error ("Expecting form __tmp(NAME)", ctok, 0); + break; + + default: + if (IS_INTERNAL_FUNC(ctok->type)) + { + append_token (ctok); + get_token (ctok); + } + else + _SLparse_error("Expecting a PRIMARY", ctok, 0); + } + + while (SLang_Error == 0) + { + end_pos = Token_List->len; + type = ctok->type; + switch (type) + { + case OBRACKET_TOKEN: /* X[args] ==> [args] X ARRAY */ + get_token (ctok); + append_token_of_type (ARG_TOKEN); + if (ctok->type != CBRACKET_TOKEN) + array_index_expression (ctok); + + if (ctok->type != CBRACKET_TOKEN) + { + _SLparse_error ("Expecting ']'", ctok, 0); + return; + } + get_token (ctok); + /* append_token_of_type (EARG_TOKEN); -- ARRAY_TOKEN implicitely does this */ + token_list_element_exchange (start_pos, end_pos); + append_token_of_type (ARRAY_TOKEN); + break; + + case OPAREN_TOKEN: + /* f(args) ==> args f */ + if (CPAREN_TOKEN != get_token (ctok)) + { + function_args_expression (ctok, 1); + token_list_element_exchange (start_pos, end_pos); + } + else get_token (ctok); + break; + + case DOT_TOKEN: + /* S.a ==> "a" S DOT + * This means that if S is X[b], then X[b].a ==> a b X ARRAY DOT + * and f(a).X[b].c ==> "c" b "X" a f . ARRAY . + * Also, f(a).X[b] = g(x); ==> x g b "X" a f . + */ + if (IDENT_TOKEN != get_identifier_token (ctok)) + return; + + ctok->type = DOT_TOKEN; + append_token (ctok); + get_token (ctok); + break; + + case PLUSPLUS_TOKEN: + case MINUSMINUS_TOKEN: + check_for_lvalue (type, NULL); + get_token (ctok); + break; + + case ASSIGN_TOKEN: + case PLUSEQS_TOKEN: + case MINUSEQS_TOKEN: + case TIMESEQS_TOKEN: + case DIVEQS_TOKEN: + case BOREQS_TOKEN: + case BANDEQS_TOKEN: + check_for_lvalue (type, NULL); + get_token (ctok); + simple_expression (ctok); + token_list_element_exchange (start_pos, end_pos); + break; + + case POW_TOKEN: + get_token (ctok); + unary_expression (ctok); + append_token_of_type (POW_TOKEN); + break; + + default: + return; + } + } +} + +static void function_args_expression (_SLang_Token_Type *ctok, int handle_num_args) +{ + unsigned char last_type, this_type; + + if (handle_num_args) append_token_of_type (ARG_TOKEN); + + last_type = COMMA_TOKEN; + + while (SLang_Error == 0) + { + this_type = ctok->type; + + switch (this_type) + { + case COMMA_TOKEN: + if (last_type == COMMA_TOKEN) + append_token_of_type (_NULL_TOKEN); + get_token (ctok); + break; + + case CPAREN_TOKEN: + if (last_type == COMMA_TOKEN) + append_token_of_type (_NULL_TOKEN); + if (handle_num_args) append_token_of_type (EARG_TOKEN); + get_token (ctok); + return; + + default: + simple_expression (ctok); + if ((ctok->type != COMMA_TOKEN) + && (ctok->type != CPAREN_TOKEN)) + { + _SLparse_error ("Expecting ')'", ctok, 0); + break; + } + } + last_type = this_type; + } +} + +static int check_for_lvalue (unsigned char eqs_type, _SLang_Token_Type *ctok) +{ + unsigned char type; + + if ((ctok == NULL) + && (NULL == (ctok = get_last_token ()))) + return -1; + + type = ctok->type; + + eqs_type -= ASSIGN_TOKEN; + + if (type == IDENT_TOKEN) + eqs_type += _SCALAR_ASSIGN_TOKEN; + else if (type == ARRAY_TOKEN) + eqs_type += _ARRAY_ASSIGN_TOKEN; + else if (type == DOT_TOKEN) + eqs_type += _STRUCT_ASSIGN_TOKEN; + else + { + _SLparse_error ("Expecting LVALUE", ctok, 0); + return -1; + } + + ctok->type = eqs_type; + return 0; +} + +static void array_index_expression (_SLang_Token_Type *ctok) +{ + unsigned int num_commas; + + num_commas = 0; + while (1) + { + switch (ctok->type) + { + case COLON_TOKEN: + if (num_commas) + _SLparse_error ("Misplaced ':'", ctok, 0); + return; + + case TIMES_TOKEN: + append_token_of_type (_INLINE_WILDCARD_ARRAY_TOKEN); + get_token (ctok); + break; + + case COMMA_TOKEN: + _SLparse_error ("Misplaced ','", ctok, 0); + return; + + default: + simple_expression (ctok); + } + + if (ctok->type != COMMA_TOKEN) + return; + num_commas++; + get_token (ctok); + } +} + +/* inline-array-expression: + * array_index_expression + * simple_expression : simple_expression + * simple_expression : simple_expression : simple_expression + */ +static void inline_array_expression (_SLang_Token_Type *ctok) +{ + int num_colons = 0; + + append_token_of_type (ARG_TOKEN); + + if (ctok->type == COLON_TOKEN) /* [:...] */ + append_token_of_type (_NULL_TOKEN); + else if (ctok->type != CBRACKET_TOKEN) + array_index_expression (ctok); + + if (ctok->type == COLON_TOKEN) + { + num_colons++; + if ((COLON_TOKEN == get_token (ctok)) + || (ctok->type == CBRACKET_TOKEN)) + append_token_of_type (_NULL_TOKEN); + else + simple_expression (ctok); + + if (ctok->type == COLON_TOKEN) + { + num_colons++; + get_token (ctok); + simple_expression (ctok); + } + } + + if (ctok->type != CBRACKET_TOKEN) + { + _SLparse_error ("Expecting ']'", ctok, 0); + return; + } + + /* append_token_of_type (EARG_TOKEN); */ + if (num_colons) + append_token_of_type (_INLINE_IMPLICIT_ARRAY_TOKEN); + else + append_token_of_type (_INLINE_ARRAY_TOKEN); + get_token (ctok); +} + +static void do_multiple_assignment (_SLang_Token_Type *ctok) +{ + _SLang_Token_Type *s; + unsigned int i, k, len; + unsigned char assign_type; + + assign_type = ctok->type; + + /* The LHS token list has already been pushed. Here we do the RHS + * so push to another token list, process it, then come back to + * LHS for assignment. + */ + if (NULL == push_token_list ()) + return; + + get_token (ctok); + expression (ctok); + compile_token_list (); + + if (SLang_Error) + return; + + /* Finally compile the LHS of the assignment expression + * that has been saved. + */ + s = Token_List->stack; + len = Token_List->len; + + if (len == 0) + { + compile_token_of_type (POP_TOKEN); + return; + } + + while (len > 0) + { + /* List is of form: + * a , b, c d e, f , g , , , h , + * The missing expressions will be replaced by a POP + * ,,a + */ + + /* Start from back looking for a COMMA */ + k = len - 1; + if (s[k].type == COMMA_TOKEN) + { + compile_token_of_type (POP_TOKEN); + len = k; + continue; + } + + if (-1 == check_for_lvalue (assign_type, s + k)) + return; + + i = 0; + while (1) + { + if (s[k].type == COMMA_TOKEN) + { + i = k + 1; + break; + } + + if (k == 0) + break; + + k--; + } + + while (i < len) + { + compile_token (s + i); + i++; + } + + len = k; + } + + if (s[0].type == COMMA_TOKEN) + compile_token_of_type (POP_TOKEN); +} + diff --git a/mdk-stage1/slang/slpath.c b/mdk-stage1/slang/slpath.c new file mode 100644 index 000000000..831bd34df --- /dev/null +++ b/mdk-stage1/slang/slpath.c @@ -0,0 +1,344 @@ +/* Pathname and filename functions */ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#ifdef HAVE_IO_H +# include <io.h> +#endif + +#include <sys/types.h> +#include <sys/stat.h> +#include <signal.h> +#include <time.h> + +#include <errno.h> +#include <string.h> + +#include "slang.h" +#include "_slang.h" + +/* In this file, all file names are assumed to be specified in the Unix + * format, or in the native format. + * + * Aboout VMS: + * VMS pathnames are a mess. In general, they look like + * node::device:[dir.dir]file.ext;version + * and I do not know of a well-defined Unix representation for them. So, + * I am going to punt and encourage users to stick to the native + * representation. + */ + +#if defined(IBMPC_SYSTEM) +# define PATH_SEP '\\' +# define DRIVE_SPECIFIER ':' +# define SEARCH_PATH_DELIMITER ';' +# define THIS_DIR_STRING "." +#else +# if defined(VMS) +# define PATH_SEP ']' +# define DRIVE_SPECIFIER ':' +# define SEARCH_PATH_DELIMITER ' ' +# define THIS_DIR_STRING "[]" /* Is this correct?? */ +# else +# define PATH_SEP '/' +# define UNIX_PATHNAMES_OK +# define SEARCH_PATH_DELIMITER ':' +# define THIS_DIR_STRING "." +# endif +#endif + +#ifdef UNIX_PATHNAMES_OK +# define IS_PATH_SEP(x) ((x) == PATH_SEP) +#else +# define IS_PATH_SEP(x) (((x) == PATH_SEP) || ((x) == '/')) +#endif + +/* If file is /a/b/c/basename, this function returns a pointer to basename */ +char *SLpath_basename (char *file) +{ + char *b; + + if (file == NULL) return NULL; + b = file + strlen (file); + + while (b != file) + { + b--; + if (IS_PATH_SEP(*b)) + return b + 1; +#ifdef DRIVE_SPECIFIER + if (*b == DRIVE_SPECIFIER) + return b + 1; +#endif + } + + return b; +} + +/* Returns a malloced string */ +char *SLpath_pathname_sans_extname (char *file) +{ + char *b; + + file = SLmake_string (file); + if (file == NULL) + return NULL; + + b = file + strlen (file); + + while (b != file) + { + b--; + if (*b == '.') + { + *b = 0; + return file; + } + } + + return file; +} + +/* If path looks like: A/B/C/D/whatever, it returns A/B/C/D as a malloced + * string. + */ +char *SLpath_dirname (char *file) +{ + char *b; + + if (file == NULL) return NULL; + b = file + strlen (file); + + while (b != file) + { + b--; + if (IS_PATH_SEP(*b)) + { + if (b == file) b++; + break; + } + +#ifdef DRIVE_SPECIFIER + if (*b == DRIVE_SPECIFIER) + { + b++; + break; + } +#endif + } + + if (b == file) + return SLmake_string (THIS_DIR_STRING); + + return SLmake_nstring (file, (unsigned int) (b - file)); +} + +/* Note: VMS filenames also contain version numbers. The caller will have + * to deal with that. + * + * The extension includes the '.'. If no extension is present, "" is returned. + */ +char *SLpath_extname (char *file) +{ + char *b; + + if (NULL == (file = SLpath_basename (file))) + return NULL; + + b = file + strlen (file); + while (b != file) + { + b--; + if (*b == '.') + return b; + } + + if (*b == '.') + return b; + + /* Do not return a literal "" */ + return file + strlen (file); +} + +#ifdef IBMPC_SYSTEM +static void convert_slashes (char *f) +{ + while (*f) + { + if (*f == '/') *f = PATH_SEP; + f++; + } +} +#endif + +int SLpath_is_absolute_path (char *name) +{ +#ifdef UNIX_PATHNAMES_OK + return (*name == '/'); +#else + if (IS_PATH_SEP (*name)) + return 1; + +# ifdef DRIVE_SPECIFIER + /* Look for a drive specifier */ + while (*name) + { + if (*name == DRIVE_SPECIFIER) + return 1; + + name++; + } +# endif + + return 0; +#endif +} + +/* This returns a MALLOCED string */ +char *SLpath_dircat (char *dir, char *name) +{ + unsigned int len, dirlen; + char *file; +#ifndef VMS + int requires_fixup; +#endif + + if (name == NULL) + name = ""; + + if ((dir == NULL) || (SLpath_is_absolute_path (name))) + dir = ""; + + /* Both VMS and MSDOS have default directories associated with each drive. + * That is, the meaning of something like C:X depends upon more than just + * the syntax of the string. Since this concept has more power under VMS + * it will be honored here. However, I am going to treat C:X as C:\X + * under MSDOS. + * + * Note!!! + * VMS has problems of its own regarding path names, so I am simply + * going to strcat. Hopefully the VMS RTL is smart enough to deal with + * the result. + */ + dirlen = strlen (dir); +#ifndef VMS + requires_fixup = (dirlen && (0 == IS_PATH_SEP(dir[dirlen - 1]))); +#endif + + len = dirlen + strlen (name) + 2; + if (NULL == (file = SLmalloc (len))) + return NULL; + + strcpy (file, dir); + +#ifndef VMS + if (requires_fixup) + file[dirlen++] = PATH_SEP; +#endif + + strcpy (file + dirlen, name); + +#if defined(IBMPC_SYSTEM) + convert_slashes (file); +#endif + + return file; +} + +int SLpath_file_exists (char *file) +{ + struct stat st; + int m; + +#if defined(__os2__) && !defined(S_IFMT) +/* IBM VA3 doesn't declare S_IFMT */ +# define S_IFMT (S_IFDIR | S_IFCHR | S_IFREG) +#endif + +#ifdef _S_IFDIR +# ifndef S_IFDIR +# define S_IFDIR _S_IFDIR +# endif +#endif + +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +#endif + + if (file == NULL) + return -1; + + if (stat(file, &st) < 0) return 0; + m = st.st_mode; + + if (S_ISDIR(m)) return (2); + return 1; +} + +char *SLpath_find_file_in_path (char *path, char *name) +{ + unsigned int max_path_len; + unsigned int this_path_len; + char *file, *dir; + char *p; + unsigned int nth; + + if ((path == NULL) || (*path == 0) + || (name == NULL) || (*name == 0)) + return NULL; + + max_path_len = 0; + this_path_len = 0; + p = path; + while (*p != 0) + { + if (*p++ == SEARCH_PATH_DELIMITER) + { + if (this_path_len > max_path_len) max_path_len = this_path_len; + this_path_len = 0; + } + else this_path_len++; + } + if (this_path_len > max_path_len) max_path_len = this_path_len; + max_path_len++; + + if (NULL == (dir = SLmalloc (max_path_len))) + return NULL; + + nth = 0; + while (-1 != SLextract_list_element (path, nth, SEARCH_PATH_DELIMITER, + dir, max_path_len)) + { + nth++; + if (*dir == 0) + continue; + + if (NULL == (file = SLpath_dircat (dir, name))) + { + SLfree (dir); + return NULL; + } + + if (1 == SLpath_file_exists (file)) + { + SLfree (dir); + return file; + } + + SLfree (file); + } + + SLfree (dir); + return NULL; +} + diff --git a/mdk-stage1/slang/slposdir.c b/mdk-stage1/slang/slposdir.c new file mode 100644 index 000000000..33799e574 --- /dev/null +++ b/mdk-stage1/slang/slposdir.c @@ -0,0 +1,1057 @@ +/* file intrinsics for S-Lang */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if defined(__unix__) || (defined (__os2__) && defined (__EMX__)) +# include <sys/types.h> +#endif + +#ifdef HAVE_IO_H +# include <io.h> /* for chmod */ +#endif + +#if defined(__BORLANDC__) +# include <process.h> +# include <dos.h> +#endif + +#ifdef HAVE_FCNTL_H +# include <fcntl.h> +#endif +#ifdef HAVE_SYS_FCNTL_H +# include <sys/fcntl.h> +#endif + +#ifdef __unix__ +# include <sys/file.h> +#endif + +#if defined(__BORLANDC__) +# include <dir.h> +#endif + +#if defined(_MSC_VER) +# include <io.h> +#endif + +#if defined(__DECC) && defined(VMS) +# include <unixio.h> +# include <unixlib.h> +#endif + +#ifdef VMS +# include <stat.h> +#else +# include <sys/stat.h> +#endif + +#if defined(VMS) +# define USE_LISTDIR_INTRINSIC 0 +#else +# define USE_LISTDIR_INTRINSIC 1 +#endif + +#if USE_LISTDIR_INTRINSIC + +#if defined(__WIN32__) +# include <windows.h> +#else +# if defined(__OS2__) && defined(__IBMC__) +# define INCL_DOS +# define INCL_ERRORS +# include <os2.h> +# include <direct.h> +# include <ctype.h> +# else +# ifdef HAVE_DIRENT_H +# include <dirent.h> +# else +# ifdef HAVE_DIRECT_H +# include <direct.h> +# else +# define dirent direct +# define NEED_D_NAMLEN +# if HAVE_SYS_NDIR_H +# include <sys/ndir.h> +# endif +# if HAVE_SYS_DIR_H +# include <sys/dir.h> +# endif +# if HAVE_NDIR_H +# include <ndir.h> +# endif +# endif +# endif +# endif +#endif + +#endif /* USE_LISTDIR_INTRINSIC */ + +#include <errno.h> + +#include "slang.h" +#include "_slang.h" + +static int push_stat_struct (struct stat *st, int opt_attrs) +{ + char *field_names [12]; + unsigned char field_types[12]; + VOID_STAR field_values [12]; + int int_values [12]; + unsigned int i; + + field_names [0] = "st_dev"; int_values [0] = (int) st->st_dev; + field_names [1] = "st_ino"; int_values [1] = (int) st->st_ino; + field_names [2] = "st_mode"; int_values [2] = (int) st->st_mode; + field_names [3] = "st_nlink"; int_values [3] = (int) st->st_nlink; + field_names [4] = "st_uid"; int_values [4] = (int) st->st_uid; + field_names [5] = "st_gid"; int_values [5] = (int) st->st_gid; + field_names [6] = "st_rdev"; int_values [6] = (int) st->st_rdev; + field_names [7] = "st_size"; int_values [7] = (int) st->st_size; + field_names [8] = "st_atime"; int_values [8] = (int) st->st_atime; + field_names [9] = "st_mtime"; int_values [9] = (int) st->st_mtime; + field_names [10] = "st_ctime"; int_values [10] = (int) st->st_ctime; + + field_names [11] = "st_opt_attrs"; int_values[11] = opt_attrs; + + for (i = 0; i < 12; i++) + { + field_types [i] = SLANG_INT_TYPE; + field_values [i] = (VOID_STAR) (int_values + i); + } + + return SLstruct_create_struct (12, field_names, field_types, field_values); +} + +static void stat_cmd (char *file) +{ + struct stat st; + int status; + int opt_attrs; + + status = stat (file, &st); + +#if defined(__MSDOS__) || defined(__WIN32__) + if (status == -1) + { + unsigned int len = strlen (file); + if (len && ((file[len-1] == '\\') || (file[len-1] == '/'))) + { + file = SLmake_nstring (file, len-1); + if (file == NULL) + return; + + status = stat (file, &st); + SLfree (file); + } + } +#endif + if (status == -1) + { + _SLerrno_errno = errno; + SLang_push_null (); + return; + } + +#ifdef __WIN32__ + opt_attrs = GetFileAttributes (file); +#else + opt_attrs = 0; +#endif + + push_stat_struct (&st, opt_attrs); +} + +static void lstat_cmd (char *file) +{ +#ifdef HAVE_LSTAT + struct stat st; + int opt_attrs; + + if (-1 == lstat (file, &st)) + { + _SLerrno_errno = errno; + SLang_push_null (); + return; + } + +#ifdef __WIN32__ + opt_attrs = GetFileAttributes (file); +#else + opt_attrs = 0; +#endif + + push_stat_struct (&st, opt_attrs); +#else + stat_cmd (file); +#endif +} + +/* Well, it appears that on some systems, these are not defined. Here I + * provide them. These are derived from the Linux stat.h file. + */ + +#ifdef __os2__ +# ifdef __IBMC__ +/* IBM VA3 doesn't declare S_IFMT */ +# define S_IFMT (S_IFDIR | S_IFCHR | S_IFREG) +# endif +#endif + +#ifndef S_ISLNK +# ifdef S_IFLNK +# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) 0 +# endif +#endif + +#ifndef S_ISREG +# ifdef S_IFREG +# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +# else +# define S_ISREG(m) 0 +# endif +#endif + +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +#endif + +#ifndef S_ISCHR +# ifdef S_IFCHR +# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +# else +# define S_ISCHR(m) 0 +# endif +#endif + +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) 0 +# endif +#endif + +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) 0 +# endif +#endif + +#ifndef S_ISSOCK +# ifdef S_IFSOCK +# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) +# else +# define S_ISSOCK(m) 0 +# endif +#endif + +static char stat_is_cmd (char *what, int *mode_ptr) +{ + int ret; + int st_mode = *mode_ptr; + + if (!strcmp (what, "sock")) ret = S_ISSOCK(st_mode); + else if (!strcmp (what, "fifo")) ret = S_ISFIFO(st_mode); + else if (!strcmp (what, "blk")) ret = S_ISBLK(st_mode); + else if (!strcmp (what, "chr")) ret = S_ISCHR(st_mode); + else if (!strcmp (what, "dir")) ret = S_ISDIR(st_mode); + else if (!strcmp (what, "reg")) ret = S_ISREG(st_mode); + else if (!strcmp (what, "lnk")) ret = S_ISLNK(st_mode); + else + { + SLang_verror (SL_INVALID_PARM, "stat_is: Unrecognized type: %s", what); + return -1; + } + + return (char) (ret != 0); +} + +#ifdef HAVE_READLINK +static void readlink_cmd (char *s) +{ + char buf[2048]; + int n; + + n = readlink (s, buf, sizeof (buf)-1); + if (n == -1) + { + _SLerrno_errno = errno; + s = NULL; + } + else + { + buf[n] = 0; + s = buf; + } + + (void) SLang_push_string (s); +} +#endif + +static int chmod_cmd (char *file, int *mode) +{ + if (-1 == chmod(file, (mode_t) *mode)) + { + _SLerrno_errno = errno; + return -1; + } + return 0; +} + +#ifdef HAVE_CHOWN +static int chown_cmd (char *file, int *owner, int *group) +{ + int ret; + + if (-1 == (ret = chown(file, (uid_t) *owner, (gid_t) *group))) + _SLerrno_errno = errno; + return ret; +} +#endif + +/* add trailing slash to dir */ +static void fixup_dir (char *dir) +{ +#ifndef VMS + int n; + + if ((n = strlen(dir)) > 1) + { + n--; +#if defined(IBMPC_SYSTEM) + if ( dir[n] != '/' && dir[n] != '\\' ) + strcat(dir, "\\" ); +#else + if (dir[n] != '/' ) + strcat(dir, "/" ); +#endif + } +#endif /* !VMS */ +} + +static void slget_cwd (void) +{ + char cwd[1024]; + char *p; + +#ifndef HAVE_GETCWD + p = getwd (cwd); +#else +# if defined (__EMX__) + p = _getcwd2(cwd, 1022); /* includes drive specifier */ +# else + p = getcwd(cwd, 1022); /* djggp includes drive specifier */ +# endif +#endif + + if (p == NULL) + { + _SLerrno_errno = errno; + SLang_push_null (); + return; + } + +#ifndef VMS +#ifdef __GO32__ + /* You never know about djgpp since it favors unix */ + { + char ch; + p = cwd; + while ((ch = *p) != 0) + { + if (ch == '/') *p = '\\'; + p++; + } + } +#endif + fixup_dir (cwd); +#endif + SLang_push_string (cwd); +} + +static int chdir_cmd (char *s) +{ + int ret; + + while (-1 == (ret = chdir (s))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +} + +#ifdef VMS +static int remove_cmd (char *); +/* If the file looks like xxx, then change it to xxx.dir. If + * it looks like A:[B.xxx] then change it to A:[B]xxx.dir. + */ + +static char *vms_convert_dirspec_to_vms_dir (char *str) +{ + char *s; + char *version; + unsigned int len; + char *dot; + + len = strlen (str); + + version = strchr (str, ';'); + if (version == NULL) + version = str + len; + /* version points to the version of the input string */ + + + if (NULL == (s = SLmalloc (len + 8)))/* allow extra space to work with */ + return NULL; + + len = (unsigned int) (version - str); + strncpy (s, str, len); + s[len] = 0; + str = s; + + /* Lowercase the whole thing */ + while (*s != 0) + { + *s = LOWER_CASE(*s); + s++; + } + + if ((s > str) + && (s[-1] != ']')) + { + if ((s >= str + 4) + && (0 == strcmp (s - 4, ".dir"))) + s -= 4; + goto add_dir_version; + } + + /* Check for one of two possibilities: + * + * dev:[x] --> dev:x + * dev:[a.x] --> dev:[a]x + */ + + if (NULL == (dot = strchr (str, '.'))) + { + /* First possibility */ + if (NULL == (s = strchr (str, '['))) + return str; /* let someone else figure this out */ + while (s[1] != ']') + { + s[0] = s[1]; + s++; + } + *s = 0; + goto add_dir_version; + } + + while (NULL != (s = strchr (dot + 1, '.'))) + dot = s; + + *dot = ']'; + s = str + (len - 1); + + /* Drop */ + + add_dir_version: + strcpy (s, ".dir"); + strcpy (s+4, version); + return str; +} +#endif + +static int rmdir_cmd (char *s) +{ +#ifdef VMS + int status; + + if (NULL == (s = vms_convert_dirspec_to_vms_dir (s))) + return -1; + + status = remove_cmd (s); + SLfree (s); + + return status; + +#else + int ret; + + while (-1 == (ret = rmdir (s))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +#endif +} + +static int remove_cmd (char *s) +{ + int ret; +#ifdef VMS +# define REMOVE delete +#else +# ifdef REAL_UNIX_SYSTEM +# define REMOVE unlink +# else +# define REMOVE remove +# endif +#endif + + while (-1 == (ret = REMOVE (s))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +} + +static int rename_cmd (char *oldpath, char *newpath) +{ + int ret; + while (-1 == (ret = rename (oldpath, newpath))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +} + +static int mkdir_cmd (char *s, int *mode_ptr) +{ + int ret; + + (void) mode_ptr; + errno = 0; + +#if defined (__MSDOS__) && !defined(__GO32__) +# define MKDIR(x,y) mkdir(x) +#else +# if defined (__os2__) && !defined (__EMX__) +# define MKDIR(x,y) mkdir(x) +# else +# if defined (__WIN32__) && !defined (__CYGWIN32__) +# define MKDIR(x,y) mkdir(x) +# else +# define MKDIR mkdir +# endif +# endif +#endif + + while (-1 == (ret = MKDIR(s, *mode_ptr))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + break; + } + return ret; +} + +#ifdef HAVE_MKFIFO +static int mkfifo_cmd (char *path, int *mode) +{ + if (-1 == mkfifo (path, *mode)) + { + _SLerrno_errno = errno; + return -1; + } + return 0; +} +#endif + +#if USE_LISTDIR_INTRINSIC + +static void free_dir_list (char **list, unsigned int num) +{ + unsigned int i; + + if (list == NULL) + return; + + for (i = 0; i < num; i++) + SLang_free_slstring (list[i]); + SLfree ((char *) list); +} + +#if defined(__WIN32__) || defined(__os2__) && defined(__IBMC__) +static int build_dirlist (char *file, char *opt, char ***listp, unsigned int *nump, unsigned int *maxnum) +{ +# ifdef __WIN32__ + DWORD status; + HANDLE h; + WIN32_FIND_DATA fd; +# else + APIRET rc; + FILESTATUS3 status; + HDIR h; + FILEFINDBUF3 fd; + ULONG cFileNames; +# endif + char *pat; + unsigned int len; + char **list; + unsigned int num; + unsigned int max_num; + int hok; + + /* If an option is present, assume ok to list hidden files. Later + * I will formalize this. + */ + hok = (opt != NULL); + +# ifdef __WIN32__ + status = GetFileAttributes (file); +# else + rc = DosQueryPathInfo(file, FIL_STANDARD, &status, sizeof(FILESTATUS3)); +# endif + + +# ifdef __WIN32__ + if (status == (DWORD)-1) + { + _SLerrno_errno = ENOENT; + return -1; + } + if (0 == (status & FILE_ATTRIBUTE_DIRECTORY)) + { + _SLerrno_errno = ENOTDIR; + return -1; + } +# else + if ((rc != 0) || (status.attrFile & FILE_DIRECTORY) == 0) + { + /* ENOTDIR isn't defined in VA3. */ + _SLerrno_errno = ENOENT; + return -1; + } +# endif + + len = strlen (file); + pat = SLmalloc (len + 3); + if (pat == NULL) + return -1; + + strcpy (pat, file); + file = pat; + while (*file != 0) + { + if (*file == '/') *file = '\\'; + file++; + } + + if (len && (pat[len-1] != '\\')) + { + pat[len] = '\\'; + len++; + } + pat[len++] = '*'; + pat[len] = 0; + + num = 0; + max_num = 50; + list = (char **)SLmalloc (max_num * sizeof(char *)); + if (list == NULL) + { + SLfree (pat); + return -1; + } + +# ifdef __WIN32__ + h = FindFirstFile(pat, &fd); + if (h == INVALID_HANDLE_VALUE) + { + if (ERROR_NO_MORE_FILES != GetLastError()) + { + SLfree (pat); + SLfree ((char *)list); + return -1; + } + } +# else + h = HDIR_CREATE; + cFileNames = 1; + rc = DosFindFirst(pat, &h, FILE_READONLY | FILE_DIRECTORY | + FILE_ARCHIVED, &fd, sizeof(fd), &cFileNames, FIL_STANDARD); + if (rc != 0) + { + if (rc != ERROR_NO_MORE_FILES) + { + SLfree (pat); + SLfree ((char *)list); + return -1; + } + } +# endif + else while (1) + { + /* Do not include hidden files in the list. Also, do not + * include "." and ".." entries. + */ +#ifdef __WIN32__ + file = fd.cFileName; +#else + file = fd.achName; +#endif + if ( +#ifdef __WIN32__ + (hok || (0 == (fd.dwFileAttributes & FILE_ATTRIBUTE_HIDDEN))) +#else + (hok || (0 == (fd.attrFile & FILE_HIDDEN))) +#endif + && ((*file != '.') + || ((0 != strcmp (file, ".")) + && (0 != strcmp (file, ".."))))) + { + if (num == max_num) + { + char **new_list; + + max_num += 100; + new_list = (char **)SLrealloc ((char *)list, max_num * sizeof (char *)); + if (new_list == NULL) + goto return_error; + + list = new_list; + } + + file = SLang_create_slstring (file); + if (file == NULL) + goto return_error; + + list[num] = file; + num++; + } + +#ifdef __WIN32__ + if (FALSE == FindNextFile(h, &fd)) + { + if (ERROR_NO_MORE_FILES == GetLastError()) + { + FindClose (h); + break; + } + + _SLerrno_errno = errno; + FindClose (h); + goto return_error; + } +#else + cFileNames = 1; + rc = DosFindNext(h, &fd, sizeof(fd), &cFileNames); + if (rc != 0) + { + if (rc == ERROR_NO_MORE_FILES) + { + DosFindClose (h); + break; + } + + _SLerrno_errno = errno; + DosFindClose (h); + goto return_error; + } +#endif + } + + SLfree (pat); + *maxnum = max_num; + *nump = num; + *listp = list; + return 0; + + return_error: + free_dir_list (list, num); + SLfree (pat); + return -1; +} + +#else /* NOT __WIN32__ */ + +static int build_dirlist (char *dir, char *opt, char ***listp, unsigned int *nump, unsigned int *maxnum) +{ + DIR *dp; + struct dirent *ep; + unsigned int num_files; + unsigned int max_num_files; + char **list; + + (void) opt; + + if (NULL == (dp = opendir (dir))) + { + _SLerrno_errno = errno; + return -1; + } + + num_files = max_num_files = 0; + list = NULL; + while (NULL != (ep = readdir (dp))) + { + unsigned int len; + char *name; + + name = ep->d_name; +# ifdef NEED_D_NAMLEN + len = ep->d_namlen; +# else + len = strlen (name); +# endif + if ((*name == '.') && (len <= 2)) + { + if (len == 1) continue; + if (name [1] == '.') continue; + } + + if (num_files == max_num_files) + { + char **new_list; + + max_num_files += 100; + if (NULL == (new_list = (char **) SLrealloc ((char *)list, max_num_files * sizeof(char *)))) + goto return_error; + + list = new_list; + } + + if (NULL == (list[num_files] = SLang_create_nslstring (name, len))) + goto return_error; + + num_files++; + } + + closedir (dp); + *nump = num_files; + *maxnum = max_num_files; + *listp = list; + return 0; + + return_error: + if (dp != NULL) + closedir (dp); + free_dir_list (list, num_files); + return -1; +} +# endif /* NOT __WIN32__ */ + +static void listdir_cmd (char *dir, char *opt) +{ + SLang_Array_Type *at; + unsigned int num_files; + unsigned int max_num_files; + int inum_files; + char **list; + + if (-1 == build_dirlist (dir, opt, &list, &num_files, &max_num_files)) + { + SLang_push_null (); + return; + } + /* If max_num_files == 0, then num_files == 0 and list == NULL. + * The realloc step below will malloc list for us. + */ + if (num_files + 1 < max_num_files) + { + char **new_list; + if (NULL == (new_list = (char **) SLrealloc ((char *)list, (num_files + 1)* sizeof(char*)))) + { + free_dir_list (list, num_files); + SLang_push_null (); + return; + } + list = new_list; + } + + inum_files = (int) num_files; + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) list, &inum_files, 1))) + { + free_dir_list (list, num_files); + SLang_push_null (); + return; + } + + /* Allow the array to free this list if push fails */ + if (-1 == SLang_push_array (at, 1)) + SLang_push_null (); +} + +static void listdir_cmd_wrap (void) +{ + char *s, *sopt; + + sopt = NULL; + switch (SLang_Num_Function_Args) + { + case 2: + if (-1 == SLang_pop_slstring (&sopt)) + return; + case 1: + if (-1 == SLang_pop_slstring (&s)) + { + SLang_free_slstring (sopt); + return; + } + break; + default: + SLang_verror (SL_INVALID_PARM, "usage: listdir (string, [opt-string]"); + return; + } + + listdir_cmd (s, sopt); + SLang_free_slstring (s); + SLang_free_slstring (sopt); +} + +#endif /* USE_LISTDIR_INTRINSIC */ + +#ifdef HAVE_UMASK +static int umask_cmd (int *u) +{ + return umask (*u); +} +#endif + +static SLang_Intrin_Fun_Type PosixDir_Name_Table [] = +{ +#ifdef HAVE_READLINK + MAKE_INTRINSIC_S("readlink", readlink_cmd, SLANG_VOID_TYPE), +#endif + MAKE_INTRINSIC_S("lstat_file", lstat_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("stat_file", stat_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SI("stat_is", stat_is_cmd, SLANG_CHAR_TYPE), +#ifdef HAVE_MKFIFO + MAKE_INTRINSIC_SI("mkfifo", mkfifo_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_CHOWN + MAKE_INTRINSIC_SII("chown", chown_cmd, SLANG_INT_TYPE), +#endif + MAKE_INTRINSIC_SI("chmod", chmod_cmd, SLANG_INT_TYPE), +#ifdef HAVE_UMASK + MAKE_INTRINSIC_I("umask", umask_cmd, SLANG_INT_TYPE), +#endif + MAKE_INTRINSIC_0("getcwd", slget_cwd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SI("mkdir", mkdir_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("chdir", chdir_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("rmdir", rmdir_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("remove", remove_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SS("rename", rename_cmd, SLANG_INT_TYPE), +#if USE_LISTDIR_INTRINSIC + MAKE_INTRINSIC("listdir", listdir_cmd_wrap, SLANG_VOID_TYPE, 0), +#endif + SLANG_END_INTRIN_FUN_TABLE +}; + +static SLang_IConstant_Type PosixDir_Consts [] = +{ +#ifndef S_IRWXU +# define S_IRWXU 00700 +#endif + MAKE_ICONSTANT("S_IRWXU", S_IRWXU), +#ifndef S_IRUSR +# define S_IRUSR 00400 +#endif + MAKE_ICONSTANT("S_IRUSR", S_IRUSR), +#ifndef S_IWUSR +# define S_IWUSR 00200 +#endif + MAKE_ICONSTANT("S_IWUSR", S_IWUSR), +#ifndef S_IXUSR +# define S_IXUSR 00100 +#endif + MAKE_ICONSTANT("S_IXUSR", S_IXUSR), +#ifndef S_IRWXG +# define S_IRWXG 00070 +#endif + MAKE_ICONSTANT("S_IRWXG", S_IRWXG), +#ifndef S_IRGRP +# define S_IRGRP 00040 +#endif + MAKE_ICONSTANT("S_IRGRP", S_IRGRP), +#ifndef S_IWGRP +# define S_IWGRP 00020 +#endif + MAKE_ICONSTANT("S_IWGRP", S_IWGRP), +#ifndef S_IXGRP +# define S_IXGRP 00010 +#endif + MAKE_ICONSTANT("S_IXGRP", S_IXGRP), +#ifndef S_IRWXO +# define S_IRWXO 00007 +#endif + MAKE_ICONSTANT("S_IRWXO", S_IRWXO), +#ifndef S_IROTH +# define S_IROTH 00004 +#endif + MAKE_ICONSTANT("S_IROTH", S_IROTH), +#ifndef S_IWOTH +# define S_IWOTH 00002 +#endif + MAKE_ICONSTANT("S_IWOTH", S_IWOTH), +#ifndef S_IXOTH +# define S_IXOTH 00001 +#endif + MAKE_ICONSTANT("S_IXOTH", S_IXOTH), +#ifdef __WIN32__ + MAKE_ICONSTANT("FILE_ATTRIBUTE_ARCHIVE", FILE_ATTRIBUTE_ARCHIVE), + MAKE_ICONSTANT("FILE_ATTRIBUTE_COMPRESSED", FILE_ATTRIBUTE_COMPRESSED), + MAKE_ICONSTANT("FILE_ATTRIBUTE_NORMAL", FILE_ATTRIBUTE_NORMAL), + MAKE_ICONSTANT("FILE_ATTRIBUTE_DIRECTORY", FILE_ATTRIBUTE_DIRECTORY), + MAKE_ICONSTANT("FILE_ATTRIBUTE_HIDDEN", FILE_ATTRIBUTE_HIDDEN), + MAKE_ICONSTANT("FILE_ATTRIBUTE_READONLY", FILE_ATTRIBUTE_READONLY), + MAKE_ICONSTANT("FILE_ATTRIBUTE_SYSTEM", FILE_ATTRIBUTE_SYSTEM), + MAKE_ICONSTANT("FILE_ATTRIBUTE_TEMPORARY", FILE_ATTRIBUTE_TEMPORARY), +#endif + SLANG_END_ICONST_TABLE +}; + +static int Initialized; + +int SLang_init_posix_dir (void) +{ + if (Initialized) + return 0; + + if ((-1 == SLadd_intrin_fun_table(PosixDir_Name_Table, "__POSIX_DIR__")) + || (-1 == SLadd_iconstant_table (PosixDir_Consts, NULL)) + || (-1 == _SLerrno_init ())) + return -1; + + Initialized = 1; + + return 0; +} + diff --git a/mdk-stage1/slang/slposio.c b/mdk-stage1/slang/slposio.c new file mode 100644 index 000000000..ab1e9f689 --- /dev/null +++ b/mdk-stage1/slang/slposio.c @@ -0,0 +1,568 @@ +/* This module implements an interface to posix system calls */ +/* file stdio intrinsics for S-Lang */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if defined(__unix__) || (defined (__os2__) && defined (__EMX__)) +# include <sys/types.h> +#endif + +#ifdef HAVE_FCNTL_H +# include <fcntl.h> +#endif +#ifdef HAVE_SYS_FCNTL_H +# include <sys/fcntl.h> +#endif + +#ifdef __unix__ +# include <sys/file.h> +#endif + +#ifdef HAVE_IO_H +# include <io.h> +#endif + +#if defined(__BORLANDC__) +# include <dir.h> +#endif + +#if defined(__DECC) && defined(VMS) +# include <unixio.h> +# include <unixlib.h> +#endif + +#ifdef VMS +# include <stat.h> +#else +# include <sys/stat.h> +#endif + +#include <errno.h> + +#include "slang.h" +#include "_slang.h" + +struct _SLFile_FD_Type +{ + char *name; + unsigned int num_refs; /* reference counting */ + int fd; + SLang_MMT_Type *stdio_mmt; /* fdopen'd stdio object */ + + /* methods */ + int (*close)(int); + int (*read) (int, char *, unsigned int *); + int (*write)(int, char *, unsigned int *); +}; + +static int close_method (int fd) +{ + return close (fd); +} + +static int write_method (int fd, char *buf, unsigned int *nump) +{ + int num; + + if (-1 == (num = write (fd, buf, *nump))) + { + *nump = 0; + return -1; + } + + *nump = (unsigned int) num; + return 0; +} + +static int read_method (int fd, char *buf, unsigned int *nump) +{ + int num; + + num = read (fd, buf, *nump); + if (num == -1) + { + *nump = 0; + return -1; + } + *nump = (unsigned int) num; + return 0; +} + +static int check_fd (int fd) +{ + if (fd == -1) + { +#ifdef EBADF + _SLerrno_errno = EBADF; +#endif + return -1; + } + + return 0; +} + +static int posix_close (SLFile_FD_Type *f) +{ + if (-1 == check_fd (f->fd)) + return -1; + + if ((f->close != NULL) + && (-1 == f->close (f->fd))) + { + _SLerrno_errno = errno; + return -1; + } + + if (f->stdio_mmt != NULL) + { + SLang_free_mmt (f->stdio_mmt); + f->stdio_mmt = NULL; + } + + f->fd = -1; + return 0; +} + +/* Usage: Uint write (f, buf); */ +static void posix_write (SLFile_FD_Type *f, SLang_BString_Type *bstr) +{ + unsigned int len; + char *p; + + if ((-1 == check_fd (f->fd)) + || (NULL == (p = (char *)SLbstring_get_pointer (bstr, &len)))) + { + SLang_push_integer (-1); + return; + } + + if (-1 == f->write (f->fd, p, &len)) + { + _SLerrno_errno = errno; + SLang_push_integer (-1); + return; + } + + (void) SLang_push_uinteger (len); +} + +/* Usage: nn = read (f, &buf, n); */ +static void posix_read (SLFile_FD_Type *f, SLang_Ref_Type *ref, unsigned int *nbytes) +{ + unsigned int len; + char *b; + SLang_BString_Type *bstr; + + b = NULL; + + len = *nbytes; + if ((-1 == check_fd (f->fd)) + || (NULL == (b = SLmalloc (len + 1)))) + goto return_error; + + if (-1 == f->read (f->fd, b, &len)) + { + _SLerrno_errno = errno; + goto return_error; + } + + if (len != *nbytes) + { + char *b1 = SLrealloc (b, len + 1); + if (b1 == NULL) + goto return_error; + b = b1; + } + + bstr = SLbstring_create_malloced ((unsigned char *) b, len, 0); + if (bstr != NULL) + { + if ((-1 != SLang_assign_to_ref (ref, SLANG_BSTRING_TYPE, (VOID_STAR)&bstr)) + && (-1 != SLang_push_uinteger (len))) + return; + + SLbstring_free (bstr); + b = NULL; + /* drop */ + } + + return_error: + if (b != NULL) SLfree ((char *)b); + (void) SLang_assign_to_ref (ref, SLANG_NULL_TYPE, NULL); + (void) SLang_push_integer (-1); +} + +SLFile_FD_Type *SLfile_create_fd (char *name, int fd) +{ + SLFile_FD_Type *f; + + if (NULL == (f = (SLFile_FD_Type *) SLmalloc (sizeof (SLFile_FD_Type)))) + return NULL; + + memset ((char *) f, 0, sizeof (SLFile_FD_Type)); + if (NULL == (f->name = SLang_create_slstring (name))) + { + SLfree ((char *)f); + return NULL; + } + + f->fd = fd; + f->num_refs = 1; + + f->close = close_method; + f->read = read_method; + f->write = write_method; + + return f; +} + +SLFile_FD_Type *SLfile_dup_fd (SLFile_FD_Type *f0) +{ + SLFile_FD_Type *f; + int fd0, fd; + + if (f0 == NULL) + return NULL; + fd0 = f0->fd; + if (-1 == check_fd (fd0)) + return NULL; + + while (-1 == (fd = dup (fd0))) + { +#ifdef EINTR + if (errno == EINTR) + continue; +#endif + _SLerrno_errno = errno; + return NULL; + } + + if (NULL == (f = SLfile_create_fd (f0->name, fd))) + { + f0->close (fd); + return NULL; + } + + return f; +} + +int SLfile_get_fd (SLFile_FD_Type *f, int *fd) +{ + if (f == NULL) + return -1; + + *fd = f->fd; + if (-1 == check_fd (*fd)) + return -1; + + return 0; +} + +void SLfile_free_fd (SLFile_FD_Type *f) +{ + if (f == NULL) + return; + + if (f->num_refs > 1) + { + f->num_refs -= 1; + return; + } + + if (f->fd != -1) + { + if (f->close != NULL) + (void) f->close (f->fd); + + f->fd = -1; + } + + if (f->stdio_mmt != NULL) + SLang_free_mmt (f->stdio_mmt); + + SLfree ((char *) f); +} + +static int pop_string_int (char **s, int *i) +{ + *s = NULL; + if ((-1 == SLang_pop_integer (i)) + || (-1 == SLang_pop_slstring (s))) + return -1; + + return 0; +} + +static int pop_string_int_int (char **s, int *a, int *b) +{ + *s = NULL; + if ((-1 == SLang_pop_integer (b)) + || (-1 == pop_string_int (s, a))) + return -1; + + return 0; +} + +static void posix_open (void) +{ + char *file; + int mode, flags; + SLFile_FD_Type *f; + + switch (SLang_Num_Function_Args) + { + case 3: + if (-1 == pop_string_int_int (&file, &flags, &mode)) + { + SLang_push_null (); + return; + } + break; + + case 2: + default: + if (-1 == pop_string_int (&file, &flags)) + return; + mode = 0777; + break; + } + + f = SLfile_create_fd (file, -1); + if (f == NULL) + { + SLang_free_slstring (file); + SLang_push_null (); + return; + } + SLang_free_slstring (file); + + if (-1 == (f->fd = open (f->name, flags, mode))) + { + _SLerrno_errno = errno; + SLfile_free_fd (f); + SLang_push_null (); + return; + } + + if (-1 == SLfile_push_fd (f)) + SLang_push_null (); + SLfile_free_fd (f); +} + +static void posix_fileno (void) +{ + FILE *fp; + SLang_MMT_Type *mmt; + int fd; + SLFile_FD_Type *f; + char *name; + + if (-1 == SLang_pop_fileptr (&mmt, &fp)) + { + SLang_push_null (); + return; + } + name = SLang_get_name_from_fileptr (mmt); + fd = fileno (fp); + + f = SLfile_create_fd (name, fd); + if (f != NULL) + f->close = NULL; /* prevent fd from being closed + * when it goes out of scope + */ + SLang_free_mmt (mmt); + + if (-1 == SLfile_push_fd (f)) + SLang_push_null (); + SLfile_free_fd (f); +} + +static void posix_fdopen (SLFile_FD_Type *f, char *mode) +{ + if (f->stdio_mmt == NULL) + { + if (-1 == _SLstdio_fdopen (f->name, f->fd, mode)) + return; + + if (NULL == (f->stdio_mmt = SLang_pop_mmt (SLANG_FILE_PTR_TYPE))) + return; + } + + (void) SLang_push_mmt (f->stdio_mmt); +} + +static long posix_lseek (SLFile_FD_Type *f, long ofs, int whence) +{ + long status; + + if (-1 == (status = lseek (f->fd, ofs, whence))) + _SLerrno_errno = errno; + + return status; +} + +static int posix_isatty (void) +{ + int ret; + SLFile_FD_Type *f; + + if (SLang_peek_at_stack () == SLANG_FILE_PTR_TYPE) + { + SLang_MMT_Type *mmt; + FILE *fp; + + if (-1 == SLang_pop_fileptr (&mmt, &fp)) + return 0; /* invalid descriptor */ + + ret = isatty (fileno (fp)); + SLang_free_mmt (mmt); + return ret; + } + + if (-1 == SLfile_pop_fd (&f)) + return 0; + + ret = isatty (f->fd); + SLfile_free_fd (f); + + return ret; +} + +static void posix_dup (SLFile_FD_Type *f) +{ + if ((NULL == (f = SLfile_dup_fd (f))) + || (-1 == SLfile_push_fd (f))) + SLang_push_null (); + + SLfile_free_fd (f); +} + +#define I SLANG_INT_TYPE +#define V SLANG_VOID_TYPE +#define F SLANG_FILE_FD_TYPE +#define B SLANG_BSTRING_TYPE +#define R SLANG_REF_TYPE +#define U SLANG_UINT_TYPE +#define S SLANG_STRING_TYPE +#define L SLANG_LONG_TYPE +static SLang_Intrin_Fun_Type Fd_Name_Table [] = +{ + MAKE_INTRINSIC_0("fileno", posix_fileno, V), + MAKE_INTRINSIC_0("isatty", posix_isatty, I), + MAKE_INTRINSIC_0("open", posix_open, V), + MAKE_INTRINSIC_3("read", posix_read, V, F, R, U), + MAKE_INTRINSIC_3("lseek", posix_lseek, L, F, L, I), + MAKE_INTRINSIC_2("fdopen", posix_fdopen, V, F, S), + MAKE_INTRINSIC_2("write", posix_write, V, F, B), + MAKE_INTRINSIC_1("dup_fd", posix_dup, V, F), + MAKE_INTRINSIC_1("close", posix_close, I, F), + SLANG_END_INTRIN_FUN_TABLE +}; +#undef I +#undef V +#undef F +#undef B +#undef R +#undef S +#undef L +#undef U + +static SLang_IConstant_Type PosixIO_Consts [] = +{ +#ifdef O_RDONLY + MAKE_ICONSTANT("O_RDONLY", O_RDONLY), +#endif +#ifdef O_WRONLY + MAKE_ICONSTANT("O_WRONLY", O_WRONLY), +#endif +#ifdef O_RDWR + MAKE_ICONSTANT("O_RDWR", O_RDWR), +#endif +#ifdef O_APPEND + MAKE_ICONSTANT("O_APPEND", O_APPEND), +#endif +#ifdef O_CREAT + MAKE_ICONSTANT("O_CREAT", O_CREAT), +#endif +#ifdef O_EXCL + MAKE_ICONSTANT("O_EXCL", O_EXCL), +#endif +#ifdef O_NOCTTY + MAKE_ICONSTANT("O_NOCTTY", O_NOCTTY), +#endif +#ifdef O_NONBLOCK + MAKE_ICONSTANT("O_NONBLOCK", O_NONBLOCK), +#endif +#ifdef O_TRUNC + MAKE_ICONSTANT("O_TRUNC", O_TRUNC), +#endif +#ifndef O_BINARY +# define O_BINARY 0 +#endif + MAKE_ICONSTANT("O_BINARY", O_BINARY), +#ifndef O_TEXT +# define O_TEXT 0 +#endif + MAKE_ICONSTANT("O_TEXT", O_TEXT), + + SLANG_END_ICONST_TABLE +}; + +int SLfile_push_fd (SLFile_FD_Type *f) +{ + if (f == NULL) + return SLang_push_null (); + + f->num_refs += 1; + + if (0 == SLclass_push_ptr_obj (SLANG_FILE_FD_TYPE, (VOID_STAR) f)) + return 0; + + f->num_refs -= 1; + + return -1; +} + +int SLfile_pop_fd (SLFile_FD_Type **f) +{ + return SLclass_pop_ptr_obj (SLANG_FILE_FD_TYPE, (VOID_STAR *) f); +} + +static void destroy_fd_type (unsigned char type, VOID_STAR ptr) +{ + (void) type; + SLfile_free_fd (*(SLFile_FD_Type **) ptr); +} + +static int fd_push (unsigned char type, VOID_STAR v) +{ + (void) type; + return SLfile_push_fd (*(SLFile_FD_Type **)v); +} + +int SLang_init_posix_io (void) +{ + SLang_Class_Type *cl; + + if (NULL == (cl = SLclass_allocate_class ("FD_Type"))) + return -1; + cl->cl_destroy = destroy_fd_type; + (void) SLclass_set_push_function (cl, fd_push); + + if (-1 == SLclass_register_class (cl, SLANG_FILE_FD_TYPE, sizeof (SLFile_FD_Type), SLANG_CLASS_TYPE_PTR)) + return -1; + + if ((-1 == SLadd_intrin_fun_table(Fd_Name_Table, "__POSIXIO__")) + || (-1 == SLadd_iconstant_table (PosixIO_Consts, NULL)) + || (-1 == _SLerrno_init ())) + return -1; + + return 0; +} + diff --git a/mdk-stage1/slang/slprepr.c b/mdk-stage1/slang/slprepr.c new file mode 100644 index 000000000..358eeb874 --- /dev/null +++ b/mdk-stage1/slang/slprepr.c @@ -0,0 +1,427 @@ +/* Copyright (c) 1996, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/*--------------------------------*-C-*---------------------------------* + * File: slprepr.c + * + * preprocessing routines + */ +/*{{{ notes: */ +/* + * various preprocessing tokens supported + * + * #ifdef TOKEN1 TOKEN2 ... + * - True if any of TOKEN1 TOKEN2 ... are defined + * + * #ifndef TOKEN1 TOKEN2 ... + * - True if none of TOKEN1 TOKEN2 ... are defined + * + * #iftrue + * #ifnfalse + * - always True + * + * #iffalse + * #ifntrue + * - always False + * + * #if$ENV + * - True if the enviroment variable ENV is set + * + * #ifn$ENV + * - True if the enviroment variable ENV is not set + * + * #if$ENV TOKEN1 TOKEN2 ... + * - True if the contents of enviroment variable ENV match + * any of TOKEN1 TOKEN2 ... + * + * #ifn$ENV TOKEN1 TOKEN2 ... + * - True if the contents of enviroment variable ENV do not match + * any of TOKEN1 TOKEN2 ... + * + * NB: For $ENV, the tokens may contain wildcard characters: + * '?' - match any single character + * '*' - match any number of characters + * + * #elif... + * #else + * #endif + * + * + * mj olesen + *----------------------------------------------------------------------*/ +/*}}}*/ +/*{{{ includes: */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" +/*}}}*/ + +int (*SLprep_exists_hook) (char *, char); +int (*_SLprep_eval_hook) (char *); + +/*{{{ SLprep_open_prep (), SLprep_close_prep () */ +int SLprep_open_prep (SLPreprocess_Type *pt) +{ + pt->this_level = 0; + pt->exec_level = 0; + pt->prev_exec_level = 0; + pt->comment_char = '%'; + pt->preprocess_char = '#'; + pt->flags = 0; + return 0; +} + +void SLprep_close_prep (SLPreprocess_Type *pt) +{ + (void) pt; +} +/*}}}*/ + +/*{{{ SLwildcard () */ +/*----------------------------------------------------------------------* + * Does `string' match `pattern' ? + * + * '*' in pattern matches any sub-string (including the null string) + * '?' matches any single char. + * + * Code taken from that donated by Paul Hudson <paulh@harlequin.co.uk> + * to the fvwm project. + * It is public domain, no strings attached. No guarantees either. + *----------------------------------------------------------------------*/ +static int SLwildcard (char *pattern, char *string) +{ + if (pattern == NULL || *pattern == '\0' || !strcmp (pattern, "*")) + return 1; + else if (string == NULL) + return 0; + + while (*pattern && *string) switch (*pattern) + { + case '?': + /* match any single character */ + pattern++; + string++; + break; + + case '*': + /* see if rest of pattern matches any trailing */ + /* substring of the string. */ + if (*++pattern == '\0') + return 1; /* trailing * must match rest */ + + while (*string) + { + if (SLwildcard (pattern, string)) return 1; + string++; + } + return 0; + + /* break; */ + + default: + if (*pattern == '\\') + { + if (*++pattern == '\0') + pattern--; /* don't skip trailing backslash */ + } + if (*pattern++ != *string++) return 0; + break; + } + + return ((*string == '\0') + && ((*pattern == '\0') || !strcmp (pattern, "*"))); +} +/*}}}*/ + +#if defined(__16_BIT_SYSTEM__) +# define MAX_DEFINES 10 +#else +# define MAX_DEFINES 128 +#endif + +/* The extra one is for NULL termination */ +char *_SLdefines [MAX_DEFINES + 1]; + +int SLdefine_for_ifdef (char *s) /*{{{*/ +{ + unsigned int i; + + for (i = 0; i < MAX_DEFINES; i++) + { + char *s1 = _SLdefines [i]; + + if (s1 == s) + return 0; /* already defined (hashed string) */ + + if (s1 != NULL) + continue; + + s = SLang_create_slstring (s); + if (s == NULL) + return -1; + + _SLdefines[i] = s; + return 0; + } + return -1; +} +/*}}}*/ + +/*{{{ static functions */ +static int is_any_defined(char *buf, char comment) /*{{{*/ +{ + char *sys; + unsigned int i; + + while (1) + { + register char ch; + + /* Skip whitespace */ + while (((ch = *buf) == ' ') || (ch == '\t')) + buf++; + + if ((ch == '\n') || (ch == 0) || (ch == comment)) + return 0; + + i = 0; + while (NULL != (sys = _SLdefines [i++])) + { + unsigned int n; + + if (*sys != ch) + continue; + + n = strlen (sys); + if (0 == strncmp (buf, sys, n)) + { + char ch1 = *(buf + n); + + if ((ch1 == '\n') || (ch1 == 0) || + (ch1 == ' ') || (ch1 == '\t') || (ch1 == comment)) + return 1; + } + } + + /* Skip past word */ + while (((ch = *buf) != ' ') + && (ch != '\n') + && (ch != 0) + && (ch != '\t') + && (ch != comment)) + buf++; + } +} +/*}}}*/ + +static unsigned char *tokenize (unsigned char *buf, char *token, unsigned int len) +{ + register char *token_end; + + token_end = token + (len - 1); /* allow room for \0 */ + + while ((token < token_end) && (*buf > ' ')) + *token++ = *buf++; + + if (*buf > ' ') return NULL; /* token too long */ + + *token = '\0'; + + while ((*buf == ' ') || (*buf == '\t')) buf++; + + return buf; +} + +static int is_env_defined (char *buf, char comment) /*{{{*/ +{ + char * env, token [32]; + + if ((*buf <= ' ') || (*buf == comment)) return 0; /* no token */ + + if (NULL == (buf = (char *) tokenize ((unsigned char *) buf, + token, sizeof (token)))) + return 0; + + if (NULL == (env = getenv (token))) + return 0; /* ENV not defined */ + + if ((*buf == '\0') || (*buf == '\n') || (*buf == comment)) + return 1; /* no tokens, but getenv() worked */ + + do + { + buf = (char *) tokenize ((unsigned char *) buf, token, sizeof (token)); + if (buf == NULL) return 0; + + if (SLwildcard (token, env)) + return 1; + } + while (*buf && (*buf != '\n') && (*buf != comment)); + + return 0; +} +/*}}}*/ +/*}}}*/ + +int SLprep_line_ok (char *buf, SLPreprocess_Type *pt) /*{{{*/ +{ + int level, prev_exec_level, exec_level; + + if ((buf == NULL) || (pt == NULL)) return 1; + + if (*buf != pt->preprocess_char) + { + if (pt->this_level != pt->exec_level) + return 0; + + if (*buf == '\n') return pt->flags & SLPREP_BLANK_LINES_OK; + if (*buf == pt->comment_char) return pt->flags & SLPREP_COMMENT_LINES_OK; + + return 1; + } + + level = pt->this_level; + exec_level = pt->exec_level; + prev_exec_level = pt->prev_exec_level; + + buf++; + + /* Allow '#!' to pass. This could be a shell script with something + like '#! /local/bin/slang' */ + if ((*buf == '!') && (pt->preprocess_char == '#')) + return 0; + + /* Allow whitespace as in '# ifdef' */ + while ((*buf == ' ') || (*buf == '\t')) buf++; + if (*buf < 'a') return (level == exec_level); + + if (!strncmp(buf, "endif", 5)) + { + if (level == exec_level) + { + exec_level--; + prev_exec_level = exec_level; + } + level--; + if (level < prev_exec_level) prev_exec_level = level; + goto done; + } + + if ((buf[0] == 'e') && (buf[1] == 'l')) /* else, elifdef, ... */ + { + if ((level == exec_level + 1) + && (prev_exec_level != level)) + { + /* We are in position to execute */ + buf += 2; + if ((buf[0] == 's') && (buf[1] == 'e')) + { + /* "else" */ + exec_level = level; + goto done; + } + + /* drop through to ifdef testing. First set variable + * to values appropriate for ifdef testing. + */ + level--; /* now == to exec level */ + } + else + { + if (level == exec_level) + { + exec_level--; + } + goto done; + } + } + + if ((buf[0] == 'i') && (buf[1] == 'f')) + { + int truth; + + if (level != exec_level) + { + /* Not interested */ + level++; + goto done; + } + + level++; + + buf += 2; + if (buf[0] == 'n') + { + truth = 0; + buf++; + } + else truth = 1; + + if (!strncmp (buf, "def", 3)) + truth = (truth == is_any_defined(buf + 3, pt->comment_char)); + + else if (!strncmp (buf, "false", 5)) + truth = !truth; + + else if (*buf == '$') + truth = (truth == is_env_defined (buf + 1, pt->comment_char)); + + else if (!strncmp (buf, "exists", 6) + && (SLprep_exists_hook != NULL)) + truth = (truth == (*SLprep_exists_hook)(buf + 6, pt->comment_char)); + + else if (!strncmp (buf, "eval", 4) + && (_SLprep_eval_hook != NULL)) + truth = (truth == (*_SLprep_eval_hook) (buf + 4)); + + else if (0 != strncmp (buf, "true", 4)) + return 1; /* let it bomb */ + + if (truth) + { + exec_level = level; + prev_exec_level = exec_level; + } + } + else return 1; /* let it bomb. */ + + done: + + if (exec_level < 0) return 1; + + pt->this_level = level; + pt->exec_level = exec_level; + pt->prev_exec_level = prev_exec_level; + return 0; +} +/*}}}*/ + +/*{{{ main() - for testing only */ +#if 0 +int main () +{ + char buf[1024]; + SLPreprocess_Type pt; + + SLprep_open_prep (&pt); + + SLdefine_for_ifdef ("UNIX"); + + while (NULL != fgets (buf, sizeof (buf) - 1, stdin)) + { + if (SLprep_line_ok (buf, &pt)) + { + fputs (buf, stdout); + } + } + + SLprep_close_prep (&pt); + return 0; +} +#endif +/*}}}*/ diff --git a/mdk-stage1/slang/slproc.c b/mdk-stage1/slang/slproc.c new file mode 100644 index 000000000..8b266f28f --- /dev/null +++ b/mdk-stage1/slang/slproc.c @@ -0,0 +1,155 @@ +/* Process specific system calls */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#ifdef HAVE_IO_H +# include <io.h> /* for chmod */ +#endif + +#ifdef HAVE_PROCESS_H +# include <process.h> /* for getpid */ +#endif + +#if defined(__BORLANDC__) +# include <dos.h> +#endif + +#include <sys/types.h> +#include <sys/stat.h> +#include <signal.h> +#include <time.h> + +#include <errno.h> + +#include "slang.h" +#include "_slang.h" + +#ifdef HAVE_KILL +static int kill_cmd (int *pid, int *sig) +{ + int ret; + + if (-1 == (ret = kill ((pid_t) *pid, *sig))) + _SLerrno_errno = errno; + return ret; +} +#endif + +static int getpid_cmd (void) +{ + return getpid (); +} + +#ifdef HAVE_GETPPID +static int getppid_cmd (void) +{ + return getppid (); +} +#endif + +#ifdef HAVE_GETGID +static int getgid_cmd (void) +{ + return getgid (); +} +#endif + +#ifdef HAVE_GETEGID +static int getegid_cmd (void) +{ + return getegid (); +} +#endif + +#ifdef HAVE_GETEUID +static int geteuid_cmd (void) +{ + return geteuid (); +} +#endif + +#ifdef HAVE_GETUID +static int getuid_cmd (void) +{ + return getuid (); +} +#endif + +#ifdef HAVE_SETGID +static int setgid_cmd (int *gid) +{ + if (0 == setgid (*gid)) + return 0; + _SLerrno_errno = errno; + return -1; +} +#endif + +#ifdef HAVE_SETPGID +static int setpgid_cmd (int *pid, int *pgid) +{ + if (0 == setpgid (*pid, *pgid)) + return 0; + _SLerrno_errno = errno; + return -1; +} +#endif + +#ifdef HAVE_SETUID +static int setuid_cmd (int *uid) +{ + if (0 == setuid (*uid)) + return 0; + _SLerrno_errno = errno; + return -1; +} +#endif + +static SLang_Intrin_Fun_Type Process_Name_Table[] = +{ + MAKE_INTRINSIC_0("getpid", getpid_cmd, SLANG_INT_TYPE), + +#ifdef HAVE_GETPPID + MAKE_INTRINSIC_0("getppid", getppid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_GETGID + MAKE_INTRINSIC_0("getgid", getgid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_GETEGID + MAKE_INTRINSIC_0("getegid", getegid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_GETEUID + MAKE_INTRINSIC_0("geteuid", geteuid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_GETUID + MAKE_INTRINSIC_0("getuid", getuid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_SETGID + MAKE_INTRINSIC_I("setgid", setgid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_SETPGID + MAKE_INTRINSIC_II("setpgid", setpgid_cmd, SLANG_INT_TYPE), +#endif +#ifdef HAVE_SETUID + MAKE_INTRINSIC_I("setuid", setuid_cmd, SLANG_INT_TYPE), +#endif + +#ifdef HAVE_KILL + MAKE_INTRINSIC_II("kill", kill_cmd, SLANG_INT_TYPE), +#endif + SLANG_END_INTRIN_FUN_TABLE +}; + +int SLang_init_posix_process (void) +{ + if ((-1 == SLadd_intrin_fun_table (Process_Name_Table, "__POSIX_PROCESS__")) + || (-1 == _SLerrno_init ())) + return -1; + return 0; +} diff --git a/mdk-stage1/slang/slregexp.c b/mdk-stage1/slang/slregexp.c new file mode 100644 index 000000000..6592a5a63 --- /dev/null +++ b/mdk-stage1/slang/slregexp.c @@ -0,0 +1,935 @@ +/* ed style regular expressions */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#define SET_BIT(b, n) b[(unsigned int) (n) >> 3] |= 1 << ((unsigned int) (n) % 8) +#define TEST_BIT(b, n) (b[(unsigned int)(n) >> 3] & (1 << ((unsigned int) (n) % 8))) +#define LITERAL 1 +#define RANGE 2 /* [...] */ +#define ANY 3 /* . */ +#define BOL 4 /* ^ */ +#define EOL 5 /* $ */ +#define NTH_MATCH 6 /* \1 \2 ... \9 */ +#define OPAREN 7 /* \( */ +#define CPAREN 0x8 /* \) */ +#define ANY_DIGIT 0x9 /* \d */ +#define BOW 0xA /* \< */ +#define EOW 0xB /* \> */ +#if 0 +#define NOT_LITERAL 0xC /* \~ */ +#endif +#define STAR 0x80 /* * */ +#define LEAST_ONCE 0x40 /* + */ +#define MAYBE_ONCE 0x20 /* ? */ +#define MANY 0x10 /* {n,m} */ +/* The rest are additions */ +#define YES_CASE (STAR | BOL) +#define NO_CASE (STAR | EOL) + +#define UPPERCASE(x) (cs ? (x) : UPPER_CASE(x)) +#define LOWERCASE(x) (cs ? (x) : LOWER_CASE(x)) + +static unsigned char Word_Chars[256]; +#define IS_WORD_CHAR(x) Word_Chars[(unsigned int) (x)] + +#if 0 +static int ctx->open_paren_number; +static char Closed_Paren_Matches[10]; + +static SLRegexp_Type *This_Reg; +static unsigned char *This_Str; +#endif + +typedef struct +{ + SLRegexp_Type *reg; + unsigned char *str; + unsigned int len; + char closed_paren_matches[10]; + int open_paren_number; +} +Re_Context_Type; + +static unsigned char *do_nth_match (Re_Context_Type *ctx, int n, unsigned char *str, unsigned char *estr) +{ + unsigned char *bpos; + + if (ctx->closed_paren_matches[n] == 0) + return NULL; + + bpos = ctx->reg->beg_matches[n] + ctx->str; + n = ctx->reg->end_matches[n]; + if (n == 0) return(str); + if (n > (int) (estr - str)) return (NULL); + + /* This needs fixed for case sensitive match */ + if (0 != strncmp((char *) str, (char *) bpos, (unsigned int) n)) return (NULL); + str += n; + return (str); +} + +/* returns pointer to the end of regexp or NULL */ +static unsigned char *regexp_looking_at (Re_Context_Type *ctx, register unsigned char *str, unsigned char *estr, unsigned char *buf, register int cs) +{ + register unsigned char p, p1; + unsigned char *save_str, *tmpstr; + int n, n0, n1; + int save_num_open; + char save_closed_matches[10]; + + p = *buf++; + + while (p != 0) + { + /* p1 = UPPERCASE(*buf); */ + /* if (str < estr) c = UPPERCASE(*str); */ + + switch((unsigned char) p) + { + case BOW: + if ((str != ctx->str) + && ((str >= estr) + || IS_WORD_CHAR(*(str - 1)) + || (0 == IS_WORD_CHAR(*str)))) return NULL; + break; + + case EOW: + if ((str < estr) + && IS_WORD_CHAR (*str)) return NULL; + break; + + case YES_CASE: cs = 1; break; + case NO_CASE: cs = 0; break; + + case OPAREN: + ctx->open_paren_number++; + ctx->reg->beg_matches[ctx->open_paren_number] = (int) (str - ctx->str); + break; + case CPAREN: + n = ctx->open_paren_number; + while (n > 0) + { + if (ctx->closed_paren_matches[n] != 0) + { + n--; + continue; + } + ctx->closed_paren_matches[n] = 1; + ctx->reg->end_matches[n] = (unsigned int) (str - (ctx->str + ctx->reg->beg_matches[n])); + break; + } + break; +#ifdef NOT_LITERAL + case NOT_LITERAL: + if ((str >= estr) || (*buf == UPPERCASE(*str))) return (NULL); + str++; buf++; + break; + + case MAYBE_ONCE | NOT_LITERAL: + save_str = str; + if ((str < estr) && (*buf != UPPERCASE(*str))) str++; + buf++; + goto match_rest; + + case NOT_LITERAL | LEAST_ONCE: /* match at least once */ + if ((str >= estr) || (UPPERCASE(*str) == UPPERCASE(*buf))) return (NULL); + str++; + /* drop */ + case STAR | NOT_LITERAL: + save_str = str; p1 = *buf; + while ((str < estr) && (UPPERCASE(*str) != p1)) str++; + buf++; + goto match_rest; + + /* this type consists of the expression + two bytes that + determine number of matches to perform */ + case MANY | NOT_LITERAL: + p1 = *buf; buf++; + n = n0 = (int) (unsigned char) *buf++; + /* minimum number to match--- could be 0 */ + n1 = (int) (unsigned char) *buf++; + /* maximum number to match */ + + while (n && (str < estr) && (p1 != *str)) + { + n--; + str++; + } + if (n) return (NULL); + + save_str = str; + n = n1 - n0; + while (n && (str < estr) && (p1 != *str)) + { + n--; + str++; + } + goto match_rest; +#endif /* NOT_LITERAL */ + case LITERAL: + if ((str >= estr) || (*buf != UPPERCASE(*str))) return (NULL); + str++; buf++; + break; + + case MAYBE_ONCE | LITERAL: + save_str = str; + if ((str < estr) && (*buf == UPPERCASE(*str))) str++; + buf++; + goto match_rest; + + case LITERAL | LEAST_ONCE: /* match at least once */ + if ((str >= estr) || (UPPERCASE(*str) != UPPERCASE(*buf))) return (NULL); + str++; + /* drop */ + case STAR | LITERAL: + save_str = str; p1 = *buf; + while ((str < estr) && (UPPERCASE(*str) == p1)) str++; + buf++; + goto match_rest; + + /* this type consists of the expression + two bytes that + determine number of matches to perform */ + case MANY | LITERAL: + p1 = *buf; buf++; + n = n0 = (int) (unsigned char) *buf++; + /* minimum number to match--- could be 0 */ + n1 = (int) (unsigned char) *buf++; + /* maximum number to match */ + + while (n && (str < estr) && (p1 == *str)) + { + n--; + str++; + } + if (n) return (NULL); + + save_str = str; + n = n1 - n0; + while (n && (str < estr) && (p1 == *str)) + { + n--; + str++; + } + goto match_rest; + + case NTH_MATCH: + if ((str = do_nth_match(ctx, (int) (unsigned char) *buf, str, estr)) == NULL) return(NULL); + buf++; + break; + + case MAYBE_ONCE | NTH_MATCH: + save_str = str; + tmpstr = do_nth_match (ctx, (int) (unsigned char) *buf, str, estr); + buf++; + if (tmpstr != NULL) + { + str = tmpstr; + goto match_rest; + } + continue; + + case LEAST_ONCE | NTH_MATCH: + if ((str = do_nth_match(ctx, (int) (unsigned char) *buf, str, estr)) == NULL) return(NULL); + /* drop */ + case STAR | NTH_MATCH: + save_str = str; + while (NULL != (tmpstr = do_nth_match(ctx, (int) (unsigned char) *buf, str, estr))) + { + str = tmpstr; + } + buf++; + goto match_rest; + + case MANY | NTH_MATCH: return(NULL); + /* needs done */ + + case RANGE: + if (str >= estr) return (NULL); + if (TEST_BIT(buf, UPPERCASE(*str)) == 0) return (NULL); + buf += 32; str++; + break; + + case MAYBE_ONCE | RANGE: + save_str = str; + if ((str < estr) && TEST_BIT(buf, UPPERCASE(*str))) str++; + buf += 32; + goto match_rest; + + case LEAST_ONCE | RANGE: + if ((str >= estr) || (0 == TEST_BIT(buf, UPPERCASE(*str)))) return NULL; + str++; + /* drop */ + case STAR | RANGE: + save_str = str; + while ((str < estr) && TEST_BIT(buf, UPPERCASE(*str))) str++; + buf += 32; + goto match_rest; + + /* The first 32 bytes correspond to the range and the two + * following bytes indicate the min and max number of matches. + */ + case MANY | RANGE: + /* minimum number to match--- could be 0 */ + n = n0 = (int) (unsigned char) *(buf + 32); + /* maximum number to match */ + n1 = (int) (unsigned char) *(buf + 33); + + while (n && (str < estr) && (TEST_BIT(buf, UPPERCASE(*str)))) + { + n--; + str++; + } + if (n) return (NULL); + save_str = str; + n = n1 - n0; + while (n && (str < estr) && (TEST_BIT(buf, UPPERCASE(*str)))) + { + n--; + str++; + } + buf += 34; /* 32 + 2 */ + goto match_rest; + + case ANY_DIGIT: + if ((str >= estr) || (*str > '9') || (*str < '0')) return (NULL); + str++; + break; + + case MAYBE_ONCE | ANY_DIGIT: + save_str = str; + if ((str < estr) && ((*str > '9') || (*str < '0'))) str++; + goto match_rest; + + case LEAST_ONCE | ANY_DIGIT: + if ((str >= estr) || ((*str > '9') || (*str < '0'))) return NULL; + str++; + /* drop */ + case STAR | ANY_DIGIT: + save_str = str; + while ((str < estr) && ((*str <= '9') && (*str >= '0'))) str++; + goto match_rest; + + case MANY | ANY_DIGIT: + /* needs finished */ + return (NULL); + + case ANY: + if ((str >= estr) || (*str == '\n')) return (NULL); + str++; + break; + + case MAYBE_ONCE | ANY: + save_str = str; + if ((str < estr) && (*str != '\n')) str++; + goto match_rest; + + case LEAST_ONCE | ANY: + if ((str >= estr) || (*str == '\n')) return (NULL); + str++; + /* drop */ + case STAR | ANY: + save_str = str; + while ((str < estr) && (*str != '\n')) str++; + goto match_rest; + + case MANY | ANY: + return (NULL); + /* needs finished */ + + case EOL: + if ((str >= estr) || (*str == '\n')) return (str); + return(NULL); + + default: return (NULL); + } + p = *buf++; + continue; + + match_rest: + if (save_str == str) + { + p = *buf++; + continue; + } + + /* if (p == EOL) + * { + * if (str < estr) return (NULL); else return (str); + * } + */ + + SLMEMCPY(save_closed_matches, ctx->closed_paren_matches, sizeof(save_closed_matches)); + save_num_open = ctx->open_paren_number; + while (str >= save_str) + { + tmpstr = regexp_looking_at (ctx, str, estr, buf, cs); + if (tmpstr != NULL) return(tmpstr); + SLMEMCPY(ctx->closed_paren_matches, save_closed_matches, sizeof(ctx->closed_paren_matches)); + ctx->open_paren_number = save_num_open; + str--; + } + return NULL; + } + if ((p != 0) && (p != EOL)) return (NULL); else return (str); +} + +static void +fixup_beg_end_matches (Re_Context_Type *ctx, SLRegexp_Type *r, unsigned char *str, unsigned char *epos) +{ + int i; + + if (str == NULL) + { + r->beg_matches[0] = -1; + r->end_matches[0] = 0; + SLMEMSET(ctx->closed_paren_matches, 0, sizeof(ctx->closed_paren_matches)); + } + else + { + r->beg_matches[0] = (int) (str - ctx->str); + r->end_matches[0] = (unsigned int) (epos - str); + } + + for (i = 1; i < 10; i++) + { + if (ctx->closed_paren_matches [i] == 0) + { + r->beg_matches[i] = -1; + r->end_matches[i] = 0; + } + } +} + +static void init_re_context (Re_Context_Type *ctx, SLRegexp_Type *reg, + unsigned char *str, unsigned int len) +{ + memset ((char *) ctx, 0, sizeof (Re_Context_Type)); + ctx->reg = reg; + ctx->str = str; + ctx->len = len; +} + +unsigned char *SLang_regexp_match(unsigned char *str, + unsigned int len, SLRegexp_Type *reg) +{ + register unsigned char c = 0, *estr = str + len; + int cs = reg->case_sensitive, lit = 0; + unsigned char *buf = reg->buf, *epos = NULL; + Re_Context_Type ctx_buf; + + if (reg->min_length > len) return NULL; + + init_re_context (&ctx_buf, reg, str, len); + + if (*buf == BOL) + { + if (NULL == (epos = regexp_looking_at (&ctx_buf, str, estr, buf + 1, cs))) + str = NULL; + + fixup_beg_end_matches (&ctx_buf, reg, str, epos); + return str; + } + + if (*buf == NO_CASE) + { + buf++; cs = 0; + } + + if (*buf == YES_CASE) + { + buf++; cs = 1; + } + + if (*buf == LITERAL) + { + lit = 1; + c = *(buf + 1); + } + else if ((*buf == OPAREN) && (*(buf + 1) == LITERAL)) + { + lit = 1; + c = *(buf + 2); + } + + while (str < estr) + { + ctx_buf.open_paren_number = 0; + memset (ctx_buf.closed_paren_matches, 0, sizeof(ctx_buf.closed_paren_matches)); + /* take care of leading chars */ + if (lit) + { + while ((str < estr) && (c != UPPERCASE(*str))) str++; + if (str >= estr) + break; /* failed */ + } + + if (NULL != (epos = regexp_looking_at(&ctx_buf, str, estr, buf, cs))) + { + fixup_beg_end_matches (&ctx_buf, reg, str, epos); + return str; + } + str++; + } + fixup_beg_end_matches (&ctx_buf, reg, NULL, epos); + return NULL; +} + +static unsigned char *convert_digit(unsigned char *pat, int *nn) +{ + int n = 0, m = 0; + unsigned char c; + while (c = (unsigned char) *pat, (c <= '9') && (c >= '0')) + { + pat++; + n = 10 * n + (c - '0'); + m++; + } + if (m == 0) + { + return (NULL); + } + *nn = n; + return pat; +} + +#define ERROR return (int) (pat - reg->pat) + +/* Returns 0 if successful or offset in pattern of error */ +int SLang_regexp_compile (SLRegexp_Type *reg) +{ + register unsigned char *buf, *ebuf, *pat; + unsigned char *last = NULL, *tmppat; + register unsigned char c; + int i, reverse = 0, n, cs; + int oparen = 0, nparen = 0; + /* substring stuff */ + int count, last_count, this_max_mm = 0, max_mm = 0, ordinary_search, + no_osearch = 0, min_length = 0; + unsigned char *mm_p = NULL, *this_mm_p = NULL; + static int already_initialized; + + reg->beg_matches[0] = reg->end_matches[0] = 0; + buf = reg->buf; + ebuf = (reg->buf + reg->buf_len) - 2; /* make some room */ + pat = reg->pat; + cs = reg->case_sensitive; + + if (already_initialized == 0) + { + SLang_init_case_tables (); +#ifdef IBMPC_SYSTEM + SLmake_lut (Word_Chars, (unsigned char *) "_0-9a-zA-Z\200-\232\240-\245\341-\353", 0); +#else + SLmake_lut (Word_Chars, (unsigned char *) "_0-9a-zA-Z\277-\326\330-\336\340-\366\370-\376", 0); +#endif + already_initialized = 1; + } + + i = 1; while (i < 10) + { + reg->beg_matches[i] = -1; + reg->end_matches[i] = 0; + i++; + } + + if (*pat == '\\') + { + if (pat[1] == 'c') + { + cs = 1; + pat += 2; + no_osearch = 1; + } + else if (pat[1] == 'C') + { + cs = 0; + pat += 2; + no_osearch = 1; + } + } + + if (*pat == '^') + { + pat++; + *buf++ = BOL; + reg->must_match_bol = 1; + } + else reg->must_match_bol = 0; + + if (cs != reg->case_sensitive) + { + if (cs) *buf++ = YES_CASE; + else *buf++ = NO_CASE; + } + + *buf = 0; + + last_count = count = 0; + while ((c = *pat++) != 0) + { + if (buf >= ebuf - 3) + { + SLang_doerror ("Pattern too large to be compiled."); + ERROR; + } + + count++; + switch (c) + { + case '$': + if (*pat != 0) goto literal_char; + *buf++ = EOL; + break; + + case '\\': + c = *pat++; + no_osearch = 1; + switch(c) + { + case 'e': c = 033; goto literal_char; + case 'n': c = '\n'; goto literal_char; + case 't': c = '\t'; goto literal_char; + case 'C': cs = 0; *buf++ = NO_CASE; break; + case 'c': cs = 1; *buf++ = YES_CASE; break; + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + c = c - '0'; + if ((int) c > nparen) ERROR; + last = buf; + *buf++ = NTH_MATCH; *buf++ = c; + break; +#ifdef NOT_LITERAL + case '~': /* slang extension */ + if ((c = *pat) == 0) ERROR; + pat++; + last = buf; + *buf++ = NOT_LITERAL; + *buf++ = c; + min_length++; + break; +#endif + case 'd': /* slang extension */ + last = buf; + *buf++ = ANY_DIGIT; + min_length++; + break; + + case '<': + last = NULL; + *buf++ = BOW; + break; + + case '>': + last = NULL; + *buf++ = EOW; + break; + + case '{': + if (last == NULL) goto literal_char; + *last |= MANY; + tmppat = convert_digit(pat, &n); + if (tmppat == NULL) ERROR; + pat = tmppat; + *buf++ = n; + + min_length += (n - 1); + + if (*pat == '\\') + { + *buf++ = n; + } + else if (*pat == ',') + { + pat++; + if (*pat == '\\') + { + n = 255; + } + else + { + tmppat = convert_digit(pat, &n); + if (tmppat == NULL) ERROR; + pat = tmppat; + if (*pat != '\\') ERROR; + } + *buf++ = n; + } + else ERROR; + last = NULL; + pat++; + if (*pat != '}') ERROR; + pat++; + break; /* case '{' */ + + case '(': + oparen++; + if (oparen > 9) ERROR; + *buf++ = OPAREN; + break; + case ')': + if (oparen == 0) ERROR; + oparen--; + nparen++; + *buf++ = CPAREN; + break; + + case 0: ERROR; + default: + goto literal_char; + } + break; + + case '[': + + *buf = RANGE; + last = buf++; + + if (buf + 32 >= ebuf) ERROR; + + for (i = 0; i < 32; i++) buf[i] = 0; + c = *pat++; + if (c == '^') + { + reverse = 1; + SET_BIT(buf, '\n'); + c = *pat++; + } + + if (c == ']') + { + SET_BIT(buf, c); + c = *pat++; + } + while (c && (c != ']')) + { + if (c == '\\') + { + c = *pat++; + switch(c) + { + case 'n': c = '\n'; break; + case 't': c = '\t'; break; + case 0: ERROR; + } + } + + if (*pat == '-') + { + pat++; + while (c < *pat) + { + if (cs == 0) + { + SET_BIT(buf, UPPERCASE(c)); + SET_BIT(buf, LOWERCASE(c)); + } + else SET_BIT(buf, c); + c++; + } + } + if (cs == 0) + { + SET_BIT(buf, UPPERCASE(c)); + SET_BIT(buf, LOWERCASE(c)); + } + else SET_BIT(buf, c); + c = *pat++; + } + if (c != ']') ERROR; + if (reverse) for (i = 0; i < 32; i++) buf[i] = buf[i] ^ 0xFF; + reverse = 0; + buf += 32; + min_length++; + break; + + case '.': + last = buf; + *buf++ = ANY; + min_length++; + break; + + case '*': + if (last == NULL) goto literal_char; + *last |= STAR; + min_length--; + last = NULL; + break; + + case '+': + if (last == NULL) goto literal_char; + *last |= LEAST_ONCE; + last = NULL; + break; + + case '?': + if (last == NULL) goto literal_char; + *last |= MAYBE_ONCE; + last = NULL; + min_length--; + break; + + literal_char: + default: + /* This is to keep track of longest substring */ + min_length++; + this_max_mm++; + if (last_count + 1 == count) + { + if (this_max_mm == 1) + { + this_mm_p = buf; + } + else if (max_mm < this_max_mm) + { + mm_p = this_mm_p; + max_mm = this_max_mm; + } + } + else + { + this_mm_p = buf; + this_max_mm = 1; + } + + last_count = count; + + last = buf; + *buf++ = LITERAL; + *buf++ = UPPERCASE(c); + } + } + *buf = 0; + /* Check for ordinary search */ + ebuf = buf; + buf = reg->buf; + + if (no_osearch) ordinary_search = 0; + else + { + ordinary_search = 1; + while (buf < ebuf) + { + if (*buf != LITERAL) + { + ordinary_search = 0; + break; + } + buf += 2; + } + } + + reg->osearch = ordinary_search; + reg->must_match_str[15] = 0; + reg->min_length = (min_length > 0) ? (unsigned int) min_length : 0; + if (ordinary_search) + { + strncpy((char *) reg->must_match_str, (char *) reg->pat, 15); + reg->must_match = 1; + return(0); + } + /* check for longest substring of pattern */ + reg->must_match = 0; + if ((mm_p == NULL) && (this_mm_p != NULL)) mm_p = this_mm_p; + if (mm_p == NULL) + { + return (0); + } + n = 15; + pat = reg->must_match_str; + buf = mm_p; + while (n--) + { + if (*buf++ != LITERAL) break; + *pat++ = *buf++; + } + *pat = 0; + if (pat != reg->must_match_str) reg->must_match = 1; + return(0); +} + +char *SLregexp_quote_string (char *re, char *buf, unsigned int buflen) +{ + char ch; + char *b, *bmax; + + if (re == NULL) return NULL; + + b = buf; + bmax = buf + buflen; + + while (b < bmax) + { + switch (ch = *re++) + { + case 0: + *b = 0; + return buf; + + case '$': + case '\\': + case '[': + case ']': + case '.': + case '^': + case '*': + case '+': + case '?': + *b++ = '\\'; + if (b == bmax) break; + /* drop */ + + default: + *b++ = ch; + } + } + return NULL; +} + +#if 0 +#define MAX_EXP 4096 +int main(int argc, char **argv) +{ + FILE *fp; + char *regexp, *file; + char expbuf[MAX_EXP], buf[512]; + SLRegexp_Type reg; + + file = argv[2]; + regexp = argv[1]; + + if (NULL == (fp = fopen(file, "r"))) + { + fprintf(stderr, "File not open\n"); + return(1); + } + + reg.buf = expbuf; + reg.buf_len = MAX_EXP; + reg.pat = regexp; + reg.case_sensitive = 1; + + if (!regexp_compile(®)) while (NULL != fgets(buf, 511, fp)) + { + if (reg.osearch) + { + if (NULL == strstr(buf, reg.pat)) continue; + } + else + { + if (reg.must_match && (NULL == strstr(buf, reg.must_match_str))) continue; + if (0 == regexp_match(buf, buf + strlen(buf), ®)) continue; + } + + fputs(buf, stdout); + } + return (0); +} +#endif diff --git a/mdk-stage1/slang/slrline.c b/mdk-stage1/slang/slrline.c new file mode 100644 index 000000000..1874be0bb --- /dev/null +++ b/mdk-stage1/slang/slrline.c @@ -0,0 +1,836 @@ +/* SLang_read_line interface --- uses SLang tty stuff */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#ifdef REAL_UNIX_SYSTEM +int SLang_RL_EOF_Char = 4; +#else +int SLang_RL_EOF_Char = 26; +#endif + +int SLang_Rline_Quit; +static SLang_RLine_Info_Type *This_RLI; + +static unsigned char Char_Widths[256]; +static void position_cursor (int); + +static void rl_beep (void) +{ + putc(7, stdout); + fflush (stdout); +} + +/* editing functions */ +static int rl_bol (void) +{ + if (This_RLI->point == 0) return 0; + This_RLI->point = 0; + return 1; +} + +static int rl_eol (void) +{ + if (This_RLI->point == This_RLI->len) return 0; + This_RLI->point = This_RLI->len; + return 1; +} + +static int rl_right (void) +{ + if (This_RLI->point == This_RLI->len) return 0; + This_RLI->point++; + return 1; +} + +static int rl_left (void) +{ + if (This_RLI->point == 0) return 0; + This_RLI->point--; + return 1; +} + +static int rl_self_insert (void) +{ + unsigned char *pmin, *p; + + if (This_RLI->len == This_RLI->buf_len) + { + rl_beep (); + return 0; + } + + pmin = This_RLI->buf + This_RLI->point; + p = This_RLI->buf + This_RLI->len; + while (p > pmin) + { + *p = *(p - 1); + p--; + } + *pmin = SLang_Last_Key_Char; + + This_RLI->len++; + This_RLI->point++; + if ((This_RLI->curs_pos + 2 >= This_RLI->edit_width) + || (This_RLI->tt_insert == NULL) + || (Char_Widths[SLang_Last_Key_Char] != 1)) return 1; + + (*This_RLI->tt_insert)((char) SLang_Last_Key_Char); + /* update screen buf */ + p = This_RLI->old_upd + (This_RLI->len - 1); + pmin = This_RLI->old_upd + (This_RLI->point - 1); + while (p > pmin) + { + *p = *(p - 1); + p--; + } + *pmin = SLang_Last_Key_Char; + return 0; +} + +int SLang_rline_insert (char *s) +{ + unsigned char *pmin, *p; + int n; + + n = strlen (s); + if (n > This_RLI->buf_len - This_RLI->len) + n = This_RLI->buf_len - This_RLI->len; + + if (n == 0) return 0; + + pmin = This_RLI->buf + This_RLI->point; + p = This_RLI->buf + (This_RLI->len - 1); + + while (p >= pmin) + { + *(p + n) = *p; + p--; + } + SLMEMCPY ((char *) pmin, s, n); + + This_RLI->len += n; + This_RLI->point += n; + return n; +} + +static int rl_deln (int n) +{ + unsigned char *pmax, *p; + + p = This_RLI->buf + This_RLI->point; + pmax = This_RLI->buf + This_RLI->len; + + if (p + n > pmax) n = (int) (pmax - p); + while (p < pmax) + { + *p = *(p + n); + p++; + } + This_RLI->len -= n; + return n; +} + +static int rl_del (void) +{ + return rl_deln(1); +} + +static int rl_quote_insert (void) +{ + int err = SLang_Error; + SLang_Error = 0; + SLang_Last_Key_Char = (*This_RLI->getkey)(); + rl_self_insert (); + if (SLang_Error == SL_USER_BREAK) SLang_Error = 0; + else SLang_Error = err; + return 1; +} + +static int rl_trim (void) +{ + unsigned char *p, *pmax, *p1; + p = This_RLI->buf + This_RLI->point; + pmax = This_RLI->buf + This_RLI->len; + + if (p == pmax) + { + if (p == This_RLI->buf) return 0; + p--; + } + + if ((*p != ' ') && (*p != '\t')) return 0; + p1 = p; + while ((p1 < pmax) && ((*p1 == ' ') || (*p1 == '\t'))) p1++; + pmax = p1; + p1 = This_RLI->buf; + + while ((p >= p1) && ((*p == ' ') || (*p == '\t'))) p--; + if (p == pmax) return 0; + p++; + + This_RLI->point = (int) (p - p1); + return rl_deln ((int) (pmax - p)); +} + +static int rl_bdel (void) +{ + if (rl_left()) return rl_del(); + return 0; +} + +static int rl_deleol (void) +{ + if (This_RLI->point == This_RLI->len) return 0; + *(This_RLI->buf + This_RLI->point) = 0; + This_RLI->len = This_RLI->point; + return 1; +} + +static int rl_delete_line (void) +{ + This_RLI->point = 0; + *(This_RLI->buf + This_RLI->point) = 0; + This_RLI->len = 0; + return 1; +} + +static int rl_enter (void) +{ + *(This_RLI->buf + This_RLI->len) = 0; + SLang_Rline_Quit = 1; + return 1; +} + +static SLKeyMap_List_Type *RL_Keymap; + +/* This update is designed for dumb terminals. It assumes only that the + * terminal can backspace via ^H, and move cursor to start of line via ^M. + * There is a hook so the user can provide a more sophisticated update if + * necessary. + */ + +static void position_cursor (int col) +{ + unsigned char *p, *pmax; + int dc; + + if (col == This_RLI->curs_pos) + { + fflush (stdout); + return; + } + + if (This_RLI->tt_goto_column != NULL) + { + (*This_RLI->tt_goto_column)(col); + This_RLI->curs_pos = col; + fflush (stdout); + return; + } + + dc = This_RLI->curs_pos - col; + if (dc < 0) + { + p = This_RLI->new_upd + This_RLI->curs_pos; + pmax = This_RLI->new_upd + col; + while (p < pmax) putc((char) *p++, stdout); + } + else + { + if (dc < col) + { + while (dc--) putc(8, stdout); + } + else + { + putc('\r', stdout); + p = This_RLI->new_upd; + pmax = This_RLI->new_upd + col; + while (p < pmax) putc((char) *p++, stdout); + } + } + This_RLI->curs_pos = col; + fflush (stdout); +} + +static void erase_eol (SLang_RLine_Info_Type *rli) +{ + unsigned char *p, *pmax; + + p = rli->old_upd + rli->curs_pos; + pmax = rli->old_upd + rli->old_upd_len; + + while (p++ < pmax) putc(' ', stdout); + + rli->curs_pos = rli->old_upd_len; +} + +static unsigned char *spit_out(SLang_RLine_Info_Type *rli, unsigned char *p) +{ + unsigned char *pmax; + position_cursor ((int) (p - rli->new_upd)); + pmax = rli->new_upd + rli->new_upd_len; + while (p < pmax) putc((char) *p++, stdout); + rli->curs_pos = rli->new_upd_len; + return pmax; +} + +static void really_update (SLang_RLine_Info_Type *rli, int new_curs_position) +{ + unsigned char *b = rli->old_upd, *p = rli->new_upd, chb, chp; + unsigned char *pmax; + + if (rli->update_hook != NULL) + { + (*rli->update_hook)(p, rli->edit_width, new_curs_position); + } + else + { + pmax = p + rli->edit_width; + while (p < pmax) + { + chb = *b++; chp = *p++; + if (chb == chp) continue; + + if (rli->old_upd_len <= rli->new_upd_len) + { + /* easy one */ + (void) spit_out (rli, p - 1); + break; + } + spit_out(rli, p - 1); + erase_eol (rli); + break; + } + position_cursor (new_curs_position); + } + + /* update finished, so swap */ + + rli->old_upd_len = rli->new_upd_len; + p = rli->old_upd; + rli->old_upd = rli->new_upd; + rli->new_upd = p; +} + +static void RLupdate (SLang_RLine_Info_Type *rli) +{ + int len, dlen, start_len = 0, prompt_len = 0, tw = 0, count; + int want_cursor_pos; + unsigned char *b, chb, *b_point, *p; + int no_echo; + + no_echo = rli->flags & SL_RLINE_NO_ECHO; + + b_point = (unsigned char *) (rli->buf + rli->point); + *(rli->buf + rli->len) = 0; + + /* expand characters for output buffer --- handle prompt first. + * Do two passes --- first to find out where to begin upon horiz + * scroll and the second to actually fill the buffer. */ + len = 0; + count = 2; /* once for prompt and once for buf */ + + b = (unsigned char *) rli->prompt; + while (count--) + { + if ((count == 0) && no_echo) + break; + + /* The prompt could be NULL */ + if (b != NULL) while ((chb = *b) != 0) + { + /* This will ensure that the screen is scrolled a third of the edit + * width each time */ + if (b_point == b) break; + dlen = Char_Widths[chb]; + if ((chb == '\t') && tw) + { + dlen = tw * ((len - prompt_len) / tw + 1) - (len - prompt_len); + } + len += dlen; + b++; + } + tw = rli->tab; + b = (unsigned char *) rli->buf; + if (count == 1) want_cursor_pos = prompt_len = len; + } + + if (len < rli->edit_width - rli->dhscroll) start_len = 0; + else if ((rli->start_column > len) + || (rli->start_column + rli->edit_width <= len)) + { + start_len = len - (rli->edit_width - rli->dhscroll); + if (start_len < 0) start_len = 0; + } + else start_len = rli->start_column; + rli->start_column = start_len; + + want_cursor_pos = len - start_len; + + /* second pass */ + p = rli->new_upd; + + len = 0; + count = 2; + b = (unsigned char *) rli->prompt; + if (b == NULL) b = (unsigned char *) ""; + + while ((len < start_len) && (*b)) + { + len += Char_Widths[*b++]; + } + + tw = 0; + if (*b == 0) + { + b = (unsigned char *) rli->buf; + while (len < start_len) + { + len += Char_Widths[*b++]; + } + tw = rli->tab; + count--; + } + + len = 0; + while (count--) + { + if ((count == 0) && (no_echo)) + break; + + while ((len < rli->edit_width) && ((chb = *b++) != 0)) + { + dlen = Char_Widths[chb]; + if (dlen == 1) *p++ = chb; + else + { + if ((chb == '\t') && tw) + { + dlen = tw * ((len + start_len - prompt_len) / tw + 1) - (len + start_len - prompt_len); + len += dlen; /* ok since dlen comes out 0 */ + if (len > rli->edit_width) dlen = len - rli->edit_width; + while (dlen--) *p++ = ' '; + dlen = 0; + } + else + { + if (dlen == 3) + { + chb &= 0x7F; + *p++ = '~'; + } + + *p++ = '^'; + if (chb == 127) *p++ = '?'; + else *p++ = chb + '@'; + } + } + len += dlen; + } + /* if (start_len > prompt_len) break; */ + tw = rli->tab; + b = (unsigned char *) rli->buf; + } + + rli->new_upd_len = (int) (p - rli->new_upd); + while (p < rli->new_upd + rli->edit_width) *p++ = ' '; + really_update (rli, want_cursor_pos); +} + +void SLrline_redraw (SLang_RLine_Info_Type *rli) +{ + unsigned char *p = rli->new_upd; + unsigned char *pmax = p + rli->edit_width; + while (p < pmax) *p++ = ' '; + rli->new_upd_len = rli->edit_width; + really_update (rli, 0); + RLupdate (rli); +} + +static int rl_eof_insert (void) +{ + if (This_RLI->len == 0) + { + SLang_Last_Key_Char = SLang_RL_EOF_Char; + /* rl_self_insert (); */ + return rl_enter (); + } + return 0; +} + +/* This is very naive. It knows very little about nesting and nothing + * about quoting. + */ +static void blink_match (SLang_RLine_Info_Type *rli) +{ + unsigned char bra, ket; + unsigned int delta_column; + unsigned char *p, *pmin; + int dq_level, sq_level; + int level; + + pmin = rli->buf; + p = pmin + rli->point; + if (pmin == p) + return; + + ket = SLang_Last_Key_Char; + switch (ket) + { + case ')': + bra = '('; + break; + case ']': + bra = '['; + break; + case '}': + bra = '{'; + break; + default: + return; + } + + level = 0; + sq_level = dq_level = 0; + + delta_column = 0; + while (p > pmin) + { + char ch; + + p--; + delta_column++; + ch = *p; + + if (ch == ket) + { + if ((dq_level == 0) && (sq_level == 0)) + level++; + } + else if (ch == bra) + { + if ((dq_level != 0) || (sq_level != 0)) + continue; + + level--; + if (level == 0) + { + rli->point -= delta_column; + RLupdate (rli); + (*rli->input_pending)(10); + rli->point += delta_column; + RLupdate (rli); + break; + } + if (level < 0) + break; + } + else if (ch == '"') dq_level = !dq_level; + else if (ch == '\'') sq_level = !sq_level; + } +} + +int SLang_read_line (SLang_RLine_Info_Type *rli) +{ + unsigned char *p, *pmax; + SLang_Key_Type *key; + + SLang_Rline_Quit = 0; + This_RLI = rli; + p = rli->old_upd; pmax = p + rli->edit_width; + while (p < pmax) *p++ = ' '; + + /* Sanity checking */ + rli->len = strlen ((char *) rli->buf); + if (rli->len >= rli->buf_len) + { + rli->len = 0; + *rli->buf = 0; + } + if (rli->point > rli->len) rli->point = rli->len; + if (rli->point < 0) rli->point = 0; + + rli->curs_pos = rli->start_column = 0; + rli->new_upd_len = rli->old_upd_len = 0; + + This_RLI->last_fun = NULL; + if (rli->update_hook == NULL) + putc ('\r', stdout); + + RLupdate (rli); + + while (1) + { + key = SLang_do_key (RL_Keymap, (int (*)(void)) rli->getkey); + + if ((key == NULL) || (key->f.f == NULL)) + rl_beep (); + else + { + if ((SLang_Last_Key_Char == SLang_RL_EOF_Char) + && (*key->str == 2) + && (This_RLI->len == 0)) + rl_eof_insert (); + else if (key->type == SLKEY_F_INTRINSIC) + { + if ((key->f.f)()) + RLupdate (rli); + + if ((rli->flags & SL_RLINE_BLINK_MATCH) + && (rli->input_pending != NULL)) + blink_match (rli); + } + + if (SLang_Rline_Quit) + { + This_RLI->buf[This_RLI->len] = 0; + if (SLang_Error == SL_USER_BREAK) + { + SLang_Error = 0; + return -1; + } + return This_RLI->len; + } + } + if (key != NULL) + This_RLI->last_fun = key->f.f; + } +} + +static int rl_abort (void) +{ + rl_delete_line (); + return rl_enter (); +} + +/* TTY interface --- ANSI */ + +static void ansi_goto_column (int n) +{ + putc('\r', stdout); + if (n) fprintf(stdout, "\033[%dC", n); +} + +static void rl_select_line (SLang_Read_Line_Type *p) +{ + This_RLI->last = p; + strcpy ((char *) This_RLI->buf, (char *) p->buf); + This_RLI->point = This_RLI->len = strlen((char *) p->buf); +} +static int rl_next_line (void); +static int rl_prev_line (void) +{ + SLang_Read_Line_Type *prev; + + if (((This_RLI->last_fun != (FVOID_STAR) rl_prev_line) + && (This_RLI->last_fun != (FVOID_STAR) rl_next_line)) + || (This_RLI->last == NULL)) + { + prev = This_RLI->tail; + } + else prev = This_RLI->last->prev; + + if (prev == NULL) + { + rl_beep (); + return 0; + } + + rl_select_line (prev); + return 1; +} +static int rl_redraw (void) +{ + SLrline_redraw (This_RLI); + return 1; +} + +static int rl_next_line (void) +{ + SLang_Read_Line_Type *next; + + if (((This_RLI->last_fun != (FVOID_STAR) rl_prev_line) + && (This_RLI->last_fun != (FVOID_STAR) rl_next_line)) + || (This_RLI->last == NULL)) + { + rl_beep (); + return 0; + } + + next = This_RLI->last->next; + + if (next == NULL) + { + This_RLI->len = This_RLI->point = 0; + *This_RLI->buf = 0; + This_RLI->last = NULL; + } + else rl_select_line (next); + return 1; +} + +static SLKeymap_Function_Type SLReadLine_Functions[] = +{ + {"up", rl_prev_line}, + {"down", rl_next_line}, + {"bol", rl_bol}, + {"eol", rl_eol}, + {"right", rl_right}, + {"left", rl_left}, + {"self_insert", rl_self_insert}, + {"bdel", rl_bdel}, + {"del", rl_del}, + {"deleol", rl_deleol}, + {"enter", rl_enter}, + {"trim", rl_trim}, + {"quoted_insert", rl_quote_insert}, + {(char *) NULL, NULL} +}; + +int SLang_init_readline (SLang_RLine_Info_Type *rli) +{ + int ch; + char simple[2]; + + if (RL_Keymap == NULL) + { + simple[1] = 0; + if (NULL == (RL_Keymap = SLang_create_keymap ("ReadLine", NULL))) + return -1; + + RL_Keymap->functions = SLReadLine_Functions; + + /* This breaks under some DEC ALPHA compilers (scary!) */ +#ifndef __DECC + for (ch = ' '; ch < 256; ch++) + { + simple[0] = (char) ch; + SLkm_define_key (simple, (FVOID_STAR) rl_self_insert, RL_Keymap); + } +#else + ch = ' '; + while (1) + { + simple[0] = (char) ch; + SLkm_define_key (simple, (FVOID_STAR) rl_self_insert, RL_Keymap); + ch = ch + 1; + if (ch == 256) break; + } +#endif /* NOT __DECC */ + + simple[0] = SLang_Abort_Char; + SLkm_define_key (simple, (FVOID_STAR) rl_abort, RL_Keymap); + simple[0] = SLang_RL_EOF_Char; + SLkm_define_key (simple, (FVOID_STAR) rl_eof_insert, RL_Keymap); + +#ifndef IBMPC_SYSTEM + SLkm_define_key ("^[[A", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("^[[B", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("^[[C", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("^[[D", (FVOID_STAR) rl_left, RL_Keymap); + SLkm_define_key ("^[OA", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("^[OB", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("^[OC", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("^[OD", (FVOID_STAR) rl_left, RL_Keymap); +#else + SLkm_define_key ("^@H", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("^@P", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("^@M", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("^@K", (FVOID_STAR) rl_left, RL_Keymap); + SLkm_define_key ("^@S", (FVOID_STAR) rl_del, RL_Keymap); + SLkm_define_key ("^@O", (FVOID_STAR) rl_eol, RL_Keymap); + SLkm_define_key ("^@G", (FVOID_STAR) rl_bol, RL_Keymap); + + SLkm_define_key ("\xE0H", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("\xE0P", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("\xE0M", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("\xE0K", (FVOID_STAR) rl_left, RL_Keymap); + SLkm_define_key ("\xE0S", (FVOID_STAR) rl_del, RL_Keymap); + SLkm_define_key ("\xE0O", (FVOID_STAR) rl_eol, RL_Keymap); + SLkm_define_key ("\xE0G", (FVOID_STAR) rl_bol, RL_Keymap); +#endif + SLkm_define_key ("^C", (FVOID_STAR) rl_abort, RL_Keymap); + SLkm_define_key ("^E", (FVOID_STAR) rl_eol, RL_Keymap); + SLkm_define_key ("^G", (FVOID_STAR) rl_abort, RL_Keymap); + SLkm_define_key ("^I", (FVOID_STAR) rl_self_insert, RL_Keymap); + SLkm_define_key ("^A", (FVOID_STAR) rl_bol, RL_Keymap); + SLkm_define_key ("\r", (FVOID_STAR) rl_enter, RL_Keymap); + SLkm_define_key ("\n", (FVOID_STAR) rl_enter, RL_Keymap); + SLkm_define_key ("^K", (FVOID_STAR) rl_deleol, RL_Keymap); + SLkm_define_key ("^L", (FVOID_STAR) rl_deleol, RL_Keymap); + SLkm_define_key ("^V", (FVOID_STAR) rl_del, RL_Keymap); + SLkm_define_key ("^D", (FVOID_STAR) rl_del, RL_Keymap); + SLkm_define_key ("^F", (FVOID_STAR) rl_right, RL_Keymap); + SLkm_define_key ("^B", (FVOID_STAR) rl_left, RL_Keymap); + SLkm_define_key ("^?", (FVOID_STAR) rl_bdel, RL_Keymap); + SLkm_define_key ("^H", (FVOID_STAR) rl_bdel, RL_Keymap); + SLkm_define_key ("^P", (FVOID_STAR) rl_prev_line, RL_Keymap); + SLkm_define_key ("^N", (FVOID_STAR) rl_next_line, RL_Keymap); + SLkm_define_key ("^R", (FVOID_STAR) rl_redraw, RL_Keymap); + SLkm_define_key ("`", (FVOID_STAR) rl_quote_insert, RL_Keymap); + SLkm_define_key ("\033\\", (FVOID_STAR) rl_trim, RL_Keymap); + if (SLang_Error) return -1; + } + + if (rli->prompt == NULL) rli->prompt = ""; + if (rli->keymap == NULL) rli->keymap = RL_Keymap; + rli->old_upd = rli->upd_buf1; + rli->new_upd = rli->upd_buf2; + *rli->buf = 0; + rli->point = 0; + + if (rli->flags & SL_RLINE_USE_ANSI) + { + if (rli->tt_goto_column == NULL) rli->tt_goto_column = ansi_goto_column; + } + + if (Char_Widths[0] == 2) return 0; + + for (ch = 0; ch < 32; ch++) Char_Widths[ch] = 2; + for (ch = 32; ch < 256; ch++) Char_Widths[ch] = 1; + Char_Widths[127] = 2; +#ifndef IBMPC_SYSTEM + for (ch = 128; ch < 160; ch++) Char_Widths[ch] = 3; +#endif + + return 0; +} + +SLang_Read_Line_Type *SLang_rline_save_line (SLang_RLine_Info_Type *rli) +{ + SLang_Read_Line_Type *rl = NULL; + unsigned char *buf; + + if ((rli == NULL) || (rli->buf == NULL)) + return NULL; + + if (NULL == (rl = (SLang_Read_Line_Type *) SLmalloc (sizeof (SLang_Read_Line_Type))) + || (NULL == (buf = (unsigned char *) SLmake_string ((char *)rli->buf)))) + { + SLfree ((char *)rl); + return NULL; + } + rl->buf = buf; + rl->buf_len = strlen ((char *)buf); + rl->num = rl->misc = 0; + rl->next = rl->prev = NULL; + + if (rli->tail != NULL) + { + rli->tail->next = rl; + rl->prev = rli->tail; + } + rli->tail = rl; + + return rl; +} diff --git a/mdk-stage1/slang/slscanf.c b/mdk-stage1/slang/slscanf.c new file mode 100644 index 000000000..5bd93ff41 --- /dev/null +++ b/mdk-stage1/slang/slscanf.c @@ -0,0 +1,718 @@ +/* sscanf function for S-Lang */ +/* Copyright (c) 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" +#include <ctype.h> +#include <math.h> +#include <errno.h> + +#include "slang.h" +#include "_slang.h" + +static char *skip_whitespace (char *s) +{ + while (isspace (*s)) + s++; + + return s; +} + +static void init_map (unsigned char map[256], int base) +{ + memset ((char *) map, 0xFF, 256); + + map['0'] = 0; map['1'] = 1; map['2'] = 2; map['3'] = 3; + map['4'] = 4; map['5'] = 5; map['6'] = 6; map['7'] = 7; + if (base == 8) + return; + + map['8'] = 8; map['9'] = 9; + if (base == 10) + return; + + map['A'] = 10; map['B'] = 11; map['C'] = 12; map['D'] = 13; + map['E'] = 14; map['F'] = 15; map['a'] = 10; map['b'] = 11; + map['c'] = 12; map['d'] = 13; map['e'] = 14; map['f'] = 15; +} + +static char *get_sign (char *s, char *smax, int *sign) +{ + *sign = 1; + if (s + 1 < smax) + { + if (*s == '+') s++; + else if (*s == '-') + { + s++; + *sign = -1; + } + } + return s; +} + + +static int parse_long (char **sp, char *smax, long *np, + long base, unsigned char map[256]) +{ + char *s, *s0; + long n; + int sign; + + s = s0 = get_sign (*sp, smax, &sign); + + n = 0; + while (s < smax) + { + unsigned char value; + + value = map [(unsigned char) *s]; + if (value == 0xFF) + break; + + n = base * n + value; + s++; + } + + *sp = s; + if (s == s0) + return 0; + + *np = n * sign; + + return 1; +} + + +static int parse_int (char **sp, char *smax, int *np, + long base, unsigned char map[256]) +{ + long n; + int status; + + if (1 == (status = parse_long (sp, smax, &n, base, map))) + *np = (int) n; + return status; +} + +static int parse_short (char **sp, char *smax, short *np, + long base, unsigned char map[256]) +{ + long n; + int status; + + if (1 == (status = parse_long (sp, smax, &n, base, map))) + *np = (short) n; + return status; +} + +static int parse_ulong (char **sp, char *smax, unsigned long *np, + long base, unsigned char map[256]) +{ + return parse_long (sp, smax, (long *) np, base, map); +} + +static int parse_uint (char **sp, char *smax, unsigned int *np, + long base, unsigned char map[256]) +{ + return parse_int (sp, smax, (int *) np, base, map); +} + +static int parse_ushort (char **sp, char *smax, unsigned short *np, + long base, unsigned char map[256]) +{ + return parse_short (sp, smax, (short *) np, base, map); +} + +#if SLANG_HAS_FLOAT +/* + * In an ideal world, strtod would be the correct function to use. However, + * there may be problems relying on this function because some systems do + * not support and some that do get it wrong. So, I will handle the parsing + * of the string and let atof or strtod handle the arithmetic. + */ +static int parse_double (char **sp, char *smax, double *d) +{ + char *s, *s0; + int sign; + int expon; + unsigned char map[256]; + char buf[128]; + int has_leading_zeros; + char *start_pos, *sign_pos; + char *b, *bmax; + + start_pos = *sp; + s = get_sign (start_pos, smax, &sign); + if (s >= smax) + { + errno = _SLerrno_errno = EINVAL; + return 0; + } + + /* Prepare the buffer that will be passed to strtod */ + /* Allow the exponent to be 5 significant digits: E+xxxxx\0 */ + bmax = buf + (sizeof (buf) - 8); + buf[0] = '0'; buf[1] = '.'; + b = buf + 2; + + init_map (map, 10); + + /* Skip leading 0s */ + s0 = s; + while ((s < smax) && (*s == '0')) + s++; + has_leading_zeros = (s != s0); + + expon = 0; + while (s < smax) + { + unsigned char value = map [(unsigned char) *s]; + + if (value == 0xFF) + break; + + if (b < bmax) + *b++ = *s; + + expon++; + s++; + } + + if ((s < smax) && (*s == '.')) + { + s++; + if (b == buf + 2) /* nothing added yet */ + { + while ((s < smax) && (*s == '0')) + { + expon--; + s++; + } + } + + while (s < smax) + { + unsigned char value = map [(unsigned char) *s]; + + if (value == 0xFF) + break; + + if (b < bmax) + *b++ = *s; + s++; + } + } + + if ((b == buf + 2) + && (has_leading_zeros == 0)) + { + *sp = start_pos; + errno = EINVAL; + return 0; + } + + if ((s + 1 < smax) && ((*s == 'E') || (*s == 'e'))) + { + int e; + int esign; + + s0 = s; + s = get_sign (s + 1, smax, &esign); + sign_pos = s; + e = 0; + while (s < smax) + { + unsigned char value = map [(unsigned char) *s]; + if (value == 0xFF) + break; + if (e < 25000) /* avoid overflow if 16 bit */ + e = 10 * e + value; + s++; + } +#ifdef ERANGE + if (e >= 25000) + errno = ERANGE; +#endif + if (s == sign_pos) + s = s0; /* ...E-X */ + else + { + e = esign * e; + expon += e; + } + } + + if (expon != 0) + sprintf (b, "e%d", expon); + else + *b = 0; + + *sp = s; +#if HAVE_STRTOD + *d = sign * strtod (buf, NULL); +#else + *d = sign * atof (buf); +#endif + return 1; +} + +static int parse_float (char **sp, char *smax, float *d) +{ + double x; + if (1 == parse_double (sp, smax, &x)) + { + *d = (float) x; + return 1; + } + return 0; +} +#endif /* SLANG_HAS_FLOAT */ + +static int parse_string (char **sp, char *smax, char **str) +{ + char *s, *s0; + + s0 = s = *sp; + while (s < smax) + { + if (isspace (*s)) + break; + s++; + } + if (NULL == (*str = SLang_create_nslstring (s0, (unsigned int) (s - s0)))) + return -1; + + *sp = s; + return 1; +} + +static int parse_bstring (char **sp, char *smax, char **str) +{ + char *s; + + s = *sp; + if (NULL == (*str = SLang_create_nslstring (s, (unsigned int) (smax - s)))) + return -1; + + *sp = smax; + return 1; +} + +static int parse_range (char **sp, char *smax, char **fp, char **str) +{ + char *s, *s0; + char *range; + char *f; + unsigned char map[256]; + unsigned char reverse; + + /* How can one represent a range with just '^'? The naive answer is + * is [^]. However, this may be interpreted as meaning any character + * but ']' and others. Let's assume that the user will not use a range + * to match '^'. + */ + f = *fp; + /* f is a pointer to (one char after) [...]. */ + if (*f == '^') + { + f++; + reverse = 1; + } + else reverse = 0; + + s0 = f; + if (*f == ']') + f++; + + while (1) + { + char ch = *f; + + if (ch == 0) + { + SLang_verror (SL_INVALID_PARM, "Unexpected end of range in format"); + return -1; + } + if (ch == ']') + break; + f++; + } + if (NULL == (range = SLmake_nstring (s0, (unsigned int) (f - s0)))) + return -1; + *fp = f + 1; /* skip ] */ + + SLmake_lut (map, (unsigned char *) range, reverse); + SLfree (range); + + s0 = s = *sp; + while ((s < smax) && map [(unsigned char) *s]) + s++; + + if (NULL == (*str = SLang_create_nslstring (s0, (unsigned int) (s - s0)))) + return -1; + + *sp = s; + return 1; +} + + +int _SLang_sscanf (void) +{ + int num; + unsigned int num_refs; + char *format; + char *input_string, *input_string_max; + char *f, *s; + unsigned char map8[256], map10[256], map16[256]; + + if (SLang_Num_Function_Args < 2) + { + SLang_verror (SL_INVALID_PARM, "Int_Type sscanf (str, format, ...)"); + return -1; + } + + num_refs = (unsigned int) SLang_Num_Function_Args; + if (-1 == SLreverse_stack (num_refs)) + return -1; + num_refs -= 2; + + if (-1 == SLang_pop_slstring (&input_string)) + return -1; + + if (-1 == SLang_pop_slstring (&format)) + { + SLang_free_slstring (input_string); + return -1; + } + + f = format; + s = input_string; + input_string_max = input_string + strlen (input_string); + + init_map (map8, 8); + init_map (map10, 10); + init_map (map16, 16); + + num = 0; + + while (num_refs != 0) + { + SLang_Object_Type obj; + SLang_Ref_Type *ref; + char *smax; + unsigned char *map; + int base; + int no_assign; + int is_short; + int is_long; + int status; + char chf; + unsigned int width; + int has_width; + + chf = *f++; + + if (chf == 0) + { + /* Hmmm.... what is the most useful thing to do?? */ +#if 1 + break; +#else + SLang_verror (SL_INVALID_PARM, "sscanf: format not big enough for output list"); + goto return_error; +#endif + } + + if (isspace (chf)) + { + s = skip_whitespace (s); + continue; + } + + if ((chf != '%') + || ((chf = *f++) == '%')) + { + if (*s != chf) + break; + s++; + continue; + } + + no_assign = 0; + is_short = 0; + is_long = 0; + width = 0; + smax = input_string_max; + + /* Look for the flag character */ + if (chf == '*') + { + no_assign = 1; + chf = *f++; + } + + /* Width */ + has_width = isdigit (chf); + if (has_width) + { + f--; + (void) parse_uint (&f, f + strlen(f), &width, 10, map10); + chf = *f++; + } + + /* Now the type modifier */ + switch (chf) + { + case 'h': + is_short = 1; + chf = *f++; + break; + + case 'L': /* not implemented */ + case 'l': + is_long = 1; + chf = *f++; + break; + } + + status = -1; + + if ((chf != 'c') && (chf != '[')) + s = skip_whitespace (s); + + if (has_width) + { + if (width > (unsigned int) (input_string_max - s)) + width = (unsigned int) (input_string_max - s); + smax = s + width; + } + + /* Now the format descriptor */ + + map = map10; + base = 10; + + try_again: /* used by i, x, and o, conversions */ + switch (chf) + { + case 0: + SLang_verror (SL_INVALID_PARM, "sscanf: Unexpected end of format"); + goto return_error; + case 'D': + is_long = 1; + case 'd': + if (is_short) + { + obj.data_type = SLANG_SHORT_TYPE; + status = parse_short (&s, smax, &obj.v.short_val, base, map); + } + else if (is_long) + { + obj.data_type = SLANG_LONG_TYPE; + status = parse_long (&s, smax, &obj.v.long_val, base, map); + } + else + { + obj.data_type = SLANG_INT_TYPE; + status = parse_int (&s, smax, &obj.v.int_val, base, map); + } + break; + + + case 'U': + is_long = 1; + case 'u': + if (is_short) + { + obj.data_type = SLANG_USHORT_TYPE; + status = parse_ushort (&s, smax, &obj.v.ushort_val, base, map); + } + else if (is_long) + { + obj.data_type = SLANG_ULONG_TYPE; + status = parse_ulong (&s, smax, &obj.v.ulong_val, base, map); + } + else + { + obj.data_type = SLANG_INT_TYPE; + status = parse_uint (&s, smax, &obj.v.uint_val, base, map); + } + break; + + case 'I': + is_long = 1; + case 'i': + if ((s + 1 >= smax) + || (*s != 0)) + chf = 'd'; + else if (((s[1] == 'x') || (s[1] == 'X')) + && (s + 2 < smax)) + { + s += 2; + chf = 'x'; + } + else chf = 'o'; + goto try_again; + + case 'O': + is_long = 1; + case 'o': + map = map8; + base = 8; + chf = 'd'; + goto try_again; + + case 'X': + is_long = 1; + case 'x': + base = 16; + map = map16; + chf = 'd'; + goto try_again; + + case 'E': + case 'F': + is_long = 1; + case 'e': + case 'f': + case 'g': +#if SLANG_HAS_FLOAT + if (is_long) + { + obj.data_type = SLANG_DOUBLE_TYPE; + status = parse_double (&s, smax, &obj.v.double_val); + } + else + { + obj.data_type = SLANG_FLOAT_TYPE; + status = parse_float (&s, smax, &obj.v.float_val); + } +#else + SLang_verror (SL_NOT_IMPLEMENTED, + "This version of the S-Lang does not support floating point"); + status = -1; +#endif + break; + + case 's': + obj.data_type = SLANG_STRING_TYPE; + status = parse_string (&s, smax, &obj.v.s_val); + break; + + case 'c': + if (has_width == 0) + { + obj.data_type = SLANG_UCHAR_TYPE; + obj.v.uchar_val = *s++; + status = 1; + break; + } + obj.data_type = SLANG_STRING_TYPE; + status = parse_bstring (&s, smax, &obj.v.s_val); + break; + + case '[': + obj.data_type = SLANG_STRING_TYPE; + status = parse_range (&s, smax, &f, &obj.v.s_val); + break; + + case 'n': + obj.data_type = SLANG_UINT_TYPE; + obj.v.uint_val = (unsigned int) (s - input_string); + status = 1; + break; + + default: + status = -1; + SLang_verror (SL_NOT_IMPLEMENTED, "format specifier '%c' is not supported", chf); + break; + } + + if (status == 0) + break; + + if (status == -1) + goto return_error; + + if (no_assign) + { + SLang_free_object (&obj); + continue; + } + + if (-1 == SLang_pop_ref (&ref)) + { + SLang_free_object (&obj); + goto return_error; + } + + if (-1 == SLang_push (&obj)) + { + SLang_free_object (&obj); + SLang_free_ref (ref); + goto return_error; + } + + if (-1 == _SLang_deref_assign (ref)) + { + SLang_free_ref (ref); + goto return_error; + } + SLang_free_ref (ref); + + num++; + num_refs--; + } + + if (-1 == SLdo_pop_n (num_refs)) + goto return_error; + + SLang_free_slstring (format); + SLang_free_slstring (input_string); + return num; + + return_error: + /* NULLS ok */ + SLang_free_slstring (format); + SLang_free_slstring (input_string); + return -1; +} + + +# if SLANG_HAS_FLOAT + +#ifndef HAVE_STDLIB_H +/* Oh dear. Where is the prototype for atof? If not in stdlib, then + * I do not know where. Not in math.h on some systems either. + */ +extern double atof (); +#endif + +double _SLang_atof (char *s) +{ + double x; + + s = skip_whitespace (s); + errno = 0; + + if (1 != parse_double (&s, s + strlen (s), &x)) + { + if ((0 == strcmp ("NaN", s)) + || (0 == strcmp ("-Inf", s)) + || (0 == strcmp ("Inf", s))) + return atof (s); /* let this deal with it */ +#ifdef EINVAL + errno = _SLerrno_errno = EINVAL; +#endif + return 0.0; + } + if (errno) + _SLerrno_errno = errno; + return x; +} +#endif diff --git a/mdk-stage1/slang/slscroll.c b/mdk-stage1/slang/slscroll.c new file mode 100644 index 000000000..358296116 --- /dev/null +++ b/mdk-stage1/slang/slscroll.c @@ -0,0 +1,450 @@ +/* SLang Scrolling Window Routines */ +/* Copyright (c) 1996, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +static void find_window_bottom (SLscroll_Window_Type *win) +{ + unsigned int nrows; + unsigned int hidden_mask; + SLscroll_Type *bot, *cline, *last_bot; + unsigned int row; + + nrows = win->nrows; + hidden_mask = win->hidden_mask; + cline = win->current_line; + + win->window_row = row = 0; + last_bot = bot = win->top_window_line; + + while (row < nrows) + { + if (bot == cline) + win->window_row = row; + + last_bot = bot; + + if (bot == NULL) + break; + + bot = bot->next; + + if (hidden_mask) + { + while ((bot != NULL) && (bot->flags & hidden_mask)) + bot = bot->next; + } + + row++; + } + + win->bot_window_line = last_bot; +} + +static int find_top_to_recenter (SLscroll_Window_Type *win) +{ + unsigned int nrows; + unsigned int hidden_mask; + SLscroll_Type *prev, *last_prev, *cline; + + nrows = win->nrows; + cline = win->current_line; + hidden_mask = win->hidden_mask; + + nrows = nrows / 2; + + last_prev = prev = cline; + + while (nrows && (prev != NULL)) + { + nrows--; + last_prev = prev; + do + { + prev = prev->prev; + } + while (hidden_mask + && (prev != NULL) + && (prev->flags & hidden_mask)); + } + + if (prev == NULL) prev = last_prev; + + win->top_window_line = prev; + find_window_bottom (win); + + return 0; +} + +#define HAS_BORDER_CODE 1 +int SLscroll_find_top (SLscroll_Window_Type *win) +{ + unsigned int i; + SLscroll_Type *cline, *prev, *next; + SLscroll_Type *top_window_line; + unsigned int nrows; + unsigned int hidden_mask; + int scroll_mode; + unsigned int border; + + cline = win->current_line; + nrows = win->nrows; + scroll_mode = win->cannot_scroll; + border = win->border; + if (scroll_mode == 2) + border = 0; + + if ((cline == NULL) || (nrows <= 1)) + { + win->top_window_line = cline; + find_window_bottom (win); + return 0; + } + + hidden_mask = win->hidden_mask; + + /* Note: top_window_line might be a bogus pointer. This means that I cannot + * access it unless it really corresponds to a pointer in the buffer. + */ + top_window_line = win->top_window_line; + + if (top_window_line == NULL) + return find_top_to_recenter (win); + + /* Chances are that the current line is visible in the window. This means + * that the top window line should be above it. + */ + prev = cline; + + i = 0; + + while ((i < nrows) && (prev != NULL)) + { + if (prev == top_window_line) + { + SLscroll_Type *twl = top_window_line; + int dir = 0; + + if (i < border) dir = -1; else if (i + border >= nrows) dir = 1; + + if (dir) while (border) + { + if (dir < 0) twl = twl->prev; + else twl = twl->next; + + if (twl == NULL) + { + twl = top_window_line; + break; + } + if ((hidden_mask == 0) + || (0 == (twl->flags & hidden_mask))) + border--; + } + + win->top_window_line = twl; + find_window_bottom (win); + return 0; + } + + do + { + prev = prev->prev; + } + while (hidden_mask + && (prev != NULL) + && (prev->flags & hidden_mask)); + i++; + } + + /* Now check the borders of the window. Perhaps the current line lies + * outsider the border by a line. Only do this if terminal can scroll. + */ + + if (scroll_mode == 1) + return find_top_to_recenter (win); + else if (scroll_mode == -1) + scroll_mode = 0; + + next = cline->next; + while (hidden_mask + && (next != NULL) + && (next->flags & hidden_mask)) + next = next->next; + + if ((next != NULL) + && (next == top_window_line)) + { + /* The current line is one line above the window. This means user + * has moved up past the top of the window. If scroll_mode is set + * to scroll by pages, we need to do a page up. + */ + + win->top_window_line = cline; + find_window_bottom (win); + + if (scroll_mode) return SLscroll_pageup (win); + + return 0; + } + + prev = cline->prev; + + while (hidden_mask + && (prev != NULL) + && (prev->flags & hidden_mask)) + prev = prev->prev; + + if ((prev == NULL) + || (prev != win->bot_window_line)) + return find_top_to_recenter (win); + + /* It looks like cline is below window by one line. See what line should + * be at top to scroll it into view. Only do this unless we are scrolling + * by pages. + */ + if (scroll_mode) + { + win->top_window_line = cline; + find_window_bottom (win); + return 0; + } + + i = 2; + while ((i < nrows) && (prev != NULL)) + { + do + { + prev = prev->prev; + } + while (hidden_mask + && (prev != NULL) + && (prev->flags & hidden_mask)); + i++; + } + + if (prev != NULL) + { + win->top_window_line = prev; + find_window_bottom (win); + return 0; + } + + return find_top_to_recenter (win); +} + +int SLscroll_find_line_num (SLscroll_Window_Type *win) +{ + SLscroll_Type *cline, *l; + unsigned int n; + unsigned int hidden_mask; + + if (win == NULL) return -1; + + hidden_mask = win->hidden_mask; + cline = win->current_line; + + n = 1; + + l = win->lines; + while (l != cline) + { + if ((hidden_mask == 0) + || (0 == (l->flags & hidden_mask))) + n++; + + l = l->next; + } + + win->line_num = n; + n--; + + while (l != NULL) + { + if ((hidden_mask == 0) + || (0 == (l->flags & hidden_mask))) + n++; + l = l->next; + } + win->num_lines = n; + + return 0; +} + +unsigned int SLscroll_next_n (SLscroll_Window_Type *win, unsigned int n) +{ + unsigned int i; + unsigned int hidden_mask; + SLscroll_Type *l, *cline; + + if ((win == NULL) + || (NULL == (cline = win->current_line))) + return 0; + + hidden_mask = win->hidden_mask; + l = cline; + i = 0; + while (i < n) + { + l = l->next; + while (hidden_mask + && (l != NULL) && (l->flags & hidden_mask)) + l = l->next; + + if (l == NULL) + break; + + i++; + cline = l; + } + + win->current_line = cline; + win->line_num += i; + return i; +} + +unsigned int SLscroll_prev_n (SLscroll_Window_Type *win, unsigned int n) +{ + unsigned int i; + unsigned int hidden_mask; + SLscroll_Type *l, *cline; + + if ((win == NULL) + || (NULL == (cline = win->current_line))) + return 0; + + hidden_mask = win->hidden_mask; + l = cline; + i = 0; + while (i < n) + { + l = l->prev; + while (hidden_mask + && (l != NULL) && (l->flags & hidden_mask)) + l = l->prev; + + if (l == NULL) + break; + + i++; + cline = l; + } + + win->current_line = cline; + win->line_num -= i; + return i; +} + +int SLscroll_pageup (SLscroll_Window_Type *win) +{ + SLscroll_Type *l, *top; + unsigned int nrows, hidden_mask; + unsigned int n; + + if (win == NULL) + return -1; + + (void) SLscroll_find_top (win); + + nrows = win->nrows; + + if ((NULL != (top = win->top_window_line)) + && (nrows > 2)) + { + n = 0; + hidden_mask = win->hidden_mask; + l = win->current_line; + while ((l != NULL) && (l != top)) + { + l = l->prev; + if ((hidden_mask == 0) + || ((l != NULL) && (0 == (l->flags & hidden_mask)))) + n++; + } + + if (l != NULL) + { + unsigned int save_line_num; + int ret = 0; + + win->current_line = l; + win->line_num -= n; + + /* Compute a new top/bottom header */ + save_line_num = win->line_num; + + if ((0 == SLscroll_prev_n (win, nrows - 1)) + && (n == 0)) + ret = -1; + + win->top_window_line = win->current_line; + win->current_line = l; + win->line_num = save_line_num; + + find_window_bottom (win); + return ret; + } + } + + if (nrows < 2) nrows++; + if (0 == SLscroll_prev_n (win, nrows - 1)) + return -1; + return 0; +} + +int SLscroll_pagedown (SLscroll_Window_Type *win) +{ + SLscroll_Type *l, *bot; + unsigned int nrows, hidden_mask; + unsigned int n; + + if (win == NULL) + return -1; + + (void) SLscroll_find_top (win); + + nrows = win->nrows; + + if ((NULL != (bot = win->bot_window_line)) + && (nrows > 2)) + { + n = 0; + hidden_mask = win->hidden_mask; + l = win->current_line; + while ((l != NULL) && (l != bot)) + { + l = l->next; + if ((hidden_mask == 0) + || ((l != NULL) && (0 == (l->flags & hidden_mask)))) + n++; + } + + if (l != NULL) + { + win->current_line = l; + win->top_window_line = l; + win->line_num += n; + + find_window_bottom (win); + + if (n || (bot != win->bot_window_line)) + return 0; + + return -1; + } + } + + if (nrows < 2) nrows++; + if (0 == SLscroll_next_n (win, nrows - 1)) + return -1; + return 0; +} + diff --git a/mdk-stage1/slang/slsearch.c b/mdk-stage1/slang/slsearch.c new file mode 100644 index 000000000..a9a427a7d --- /dev/null +++ b/mdk-stage1/slang/slsearch.c @@ -0,0 +1,239 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#ifdef upcase +# undef upcase +#endif + +#define upcase(ch) (cs ? ch : UPPER_CASE(ch)) + +static unsigned char *search_forward (register unsigned char *beg, + unsigned char *end, + unsigned char *key, + register int key_len, int cs, int *ind) +{ + register unsigned char char1; + unsigned char *pos; + int j, str_len; + register unsigned char ch; + register int db; + + str_len = (int) (end - beg); + if (str_len < key_len) return (NULL); + + if (key_len == 0) + return NULL; + + char1 = key[key_len - 1]; + beg += (key_len - 1); + + while(1) + { + if (cs) while (beg < end) + { + ch = *beg; + db = ind[(unsigned char) ch]; + if ((db < key_len) && (ch == char1)) break; + beg += db; /* ind[(unsigned char) ch]; */ + } + else while (beg < end) + { + ch = *beg; + db = ind[(unsigned char) ch]; + if ((db < key_len) && + (UPPER_CASE(ch) == char1)) break; + beg += db; /* ind[(unsigned char) ch]; */ + } + + if (beg >= end) return(NULL); + + pos = beg - (key_len - 1); + for (j = 0; j < key_len; j++) + { + ch = upcase(pos[j]); + if (ch != (unsigned char) key[j]) break; + } + + if (j == key_len) return(pos); + beg += 1; + } +} + +static unsigned char *search_backward (unsigned char *beg,unsigned char *end, + unsigned char *key, int key_len, + int cs, int *ind) +{ + unsigned char ch, char1; + int j, str_len, ofs; + + str_len = (int) (end - beg); + if (str_len < key_len) return (NULL); + + if (key_len == 0) + return NULL; + + /* end -= (key_len - 1); */ + end -= key_len; + + char1 = key[0]; + + while(1) + { + while ((beg <= end) && (ch = *end, ch = upcase(ch), ch != char1)) + { + ofs = ind[(unsigned char) ch]; +#ifdef __MSDOS__ + /* This is needed for msdos segment wrapping problems */ + if (beg + ofs > end) return(NULL); +#endif + end -= ofs; + } + if (beg > end) return(NULL); + for (j = 1; j < key_len; j++) + { + ch = upcase(end[j]); + if (ch != key[j]) break; + } + if (j == key_len) return(end); + end--; + } +} + +unsigned char *SLsearch (unsigned char *pmin, unsigned char *pmax, + SLsearch_Type *st) +{ + if (st->dir > 0) return search_forward (pmin, pmax, st->key, + st->key_len, st->cs, st->ind); + else return search_backward (pmin, pmax, st->key, + st->key_len, st->cs, st->ind); +} + +static int Case_Tables_Ok; + +int SLsearch_init (char *str, int dir, int cs, SLsearch_Type *st) +{ + int i, maxi; + register int max = strlen(str); + unsigned char *w, *work = st->key; + register int *indp, *indpm; + int *ind = st->ind; + + if (max >= (int) sizeof (st->key)) + { + SLang_doerror ("Search string too long."); + return -1; + } + + st->dir = dir; st->cs = cs; + + if (!Case_Tables_Ok) SLang_init_case_tables (); + + if (dir > 0) + { + w = work; + } + else + { + maxi = max - 1; + str = str + maxi; + w = work + maxi; + } + + /* for (i = 0; i < 256; i++) ind[i] = max; */ + indp = ind; indpm = ind + 256; + while (indp < indpm) + { + *indp++ = max; + *indp++ = max; + *indp++ = max; + *indp++ = max; + } + + i = 0; + if (cs) while (i < max) + { + i++; + maxi = max - i; + *w = *str; + ind[(unsigned char) *str] = maxi; + str += dir; w += dir; + } + else while (i < max) + { + i++; + maxi = max - i; + *w = UPPER_CASE(*str); + ind[(unsigned char) *w] = maxi; + ind[(unsigned char) LOWER_CASE(*str)] = maxi; + str += dir; w += dir; + } + + work[max] = 0; + st->key_len = max; + return max; +} + +/* 8bit clean upper and lowercase macros */ +unsigned char _SLChg_LCase_Lut[256]; +unsigned char _SLChg_UCase_Lut[256]; + +void SLang_define_case (int *u, int *l) +{ + unsigned char up = (unsigned char) *u, dn = (unsigned char) *l; + + _SLChg_LCase_Lut[up] = dn; + _SLChg_LCase_Lut[dn] = dn; + _SLChg_UCase_Lut[dn] = up; + _SLChg_UCase_Lut[up] = up; +} + +void SLang_init_case_tables (void) +{ + int i, j; + if (Case_Tables_Ok) return; + + for (i = 0; i < 256; i++) + { + _SLChg_UCase_Lut[i] = i; + _SLChg_LCase_Lut[i] = i; + } + + for (i = 'A'; i <= 'Z'; i++) + { + j = i + 32; + _SLChg_UCase_Lut[j] = i; + _SLChg_LCase_Lut[i] = j; + } +#ifdef PC_SYSTEM + /* Initialize for DOS code page 437. */ + _SLChg_UCase_Lut[135] = 128; _SLChg_LCase_Lut[128] = 135; + _SLChg_UCase_Lut[132] = 142; _SLChg_LCase_Lut[142] = 132; + _SLChg_UCase_Lut[134] = 143; _SLChg_LCase_Lut[143] = 134; + _SLChg_UCase_Lut[130] = 144; _SLChg_LCase_Lut[144] = 130; + _SLChg_UCase_Lut[145] = 146; _SLChg_LCase_Lut[146] = 145; + _SLChg_UCase_Lut[148] = 153; _SLChg_LCase_Lut[153] = 148; + _SLChg_UCase_Lut[129] = 154; _SLChg_LCase_Lut[154] = 129; + _SLChg_UCase_Lut[164] = 165; _SLChg_LCase_Lut[165] = 164; +#else + /* ISO Latin */ + for (i = 192; i <= 221; i++) + { + j = i + 32; + _SLChg_UCase_Lut[j] = i; + _SLChg_LCase_Lut[i] = j; + } + _SLChg_UCase_Lut[215] = 215; _SLChg_LCase_Lut[215] = 215; + _SLChg_UCase_Lut[223] = 223; _SLChg_LCase_Lut[223] = 223; + _SLChg_UCase_Lut[247] = 247; _SLChg_LCase_Lut[247] = 247; + _SLChg_UCase_Lut[255] = 255; _SLChg_LCase_Lut[255] = 255; +#endif + Case_Tables_Ok = 1; +} diff --git a/mdk-stage1/slang/slsignal.c b/mdk-stage1/slang/slsignal.c new file mode 100644 index 000000000..30707dea5 --- /dev/null +++ b/mdk-stage1/slang/slsignal.c @@ -0,0 +1,336 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include <signal.h> + +#ifdef HAVE_SYS_TYPES_H +# include <sys/types.h> +#endif +#ifdef HAVE_SYS_WAIT_H +# include <sys/wait.h> +#endif + +#include <errno.h> + +#include "slang.h" +#include "_slang.h" + +/* Do not trust these environments */ +#if defined(__CYGWIN32__) || defined(__MINGW32__) || defined(AMIGA) +# ifdef SLANG_POSIX_SIGNALS +# undef SLANG_POSIX_SIGNALS +# endif +#endif + +/* This function will cause system calls to be restarted after signal if possible */ +SLSig_Fun_Type *SLsignal (int sig, SLSig_Fun_Type *f) +{ +#if defined(SLANG_POSIX_SIGNALS) + struct sigaction old_sa, new_sa; + +# ifdef SIGALRM + /* We want system calls to be interrupted by SIGALRM. */ + if (sig == SIGALRM) return SLsignal_intr (sig, f); +# endif + + sigemptyset (&new_sa.sa_mask); + new_sa.sa_handler = f; + + new_sa.sa_flags = 0; +# ifdef SA_RESTART + new_sa.sa_flags |= SA_RESTART; +# endif + + if (-1 == sigaction (sig, &new_sa, &old_sa)) + return (SLSig_Fun_Type *) SIG_ERR; + + return old_sa.sa_handler; +#else + /* Not POSIX. */ + return signal (sig, f); +#endif +} + +/* This function will NOT cause system calls to be restarted after + * signal if possible + */ +SLSig_Fun_Type *SLsignal_intr (int sig, SLSig_Fun_Type *f) +{ +#ifdef SLANG_POSIX_SIGNALS + struct sigaction old_sa, new_sa; + + sigemptyset (&new_sa.sa_mask); + new_sa.sa_handler = f; + + new_sa.sa_flags = 0; +# ifdef SA_INTERRUPT + new_sa.sa_flags |= SA_INTERRUPT; +# endif + + if (-1 == sigaction (sig, &new_sa, &old_sa)) + return (SLSig_Fun_Type *) SIG_ERR; + + return old_sa.sa_handler; +#else + /* Not POSIX. */ + return signal (sig, f); +#endif +} + +/* We are primarily interested in blocking signals that would cause the + * application to reset the tty. These include suspend signals and + * possibly interrupt signals. + */ +#ifdef SLANG_POSIX_SIGNALS +static sigset_t Old_Signal_Mask; +#endif + +static volatile unsigned int Blocked_Depth; + +int SLsig_block_signals (void) +{ +#ifdef SLANG_POSIX_SIGNALS + sigset_t new_mask; +#endif + + Blocked_Depth++; + if (Blocked_Depth != 1) + { + return 0; + } + +#ifdef SLANG_POSIX_SIGNALS + sigemptyset (&new_mask); +# ifdef SIGQUIT + sigaddset (&new_mask, SIGQUIT); +# endif +# ifdef SIGTSTP + sigaddset (&new_mask, SIGTSTP); +# endif +# ifdef SIGINT + sigaddset (&new_mask, SIGINT); +# endif +# ifdef SIGTTIN + sigaddset (&new_mask, SIGTTIN); +# endif +# ifdef SIGTTOU + sigaddset (&new_mask, SIGTTOU); +# endif +# ifdef SIGWINCH + sigaddset (&new_mask, SIGWINCH); +# endif + + (void) sigprocmask (SIG_BLOCK, &new_mask, &Old_Signal_Mask); + return 0; +#else + /* Not implemented. */ + return -1; +#endif +} + +int SLsig_unblock_signals (void) +{ + if (Blocked_Depth == 0) + return -1; + + Blocked_Depth--; + + if (Blocked_Depth != 0) + return 0; + +#ifdef SLANG_POSIX_SIGNALS + (void) sigprocmask (SIG_SETMASK, &Old_Signal_Mask, NULL); + return 0; +#else + return -1; +#endif +} + +#ifdef MSWINDOWS +int SLsystem (char *cmd) +{ + SLang_verror (SL_NOT_IMPLEMENTED, "system not implemented"); + return -1; +} + +#else +int SLsystem (char *cmd) +{ +#ifdef SLANG_POSIX_SIGNALS + pid_t pid; + int status; + struct sigaction ignore; +# ifdef SIGINT + struct sigaction save_intr; +# endif +# ifdef SIGQUIT + struct sigaction save_quit; +# endif +# ifdef SIGCHLD + sigset_t child_mask, save_mask; +# endif + + if (cmd == NULL) return 1; + + ignore.sa_handler = SIG_IGN; + sigemptyset (&ignore.sa_mask); + ignore.sa_flags = 0; + +# ifdef SIGINT + if (-1 == sigaction (SIGINT, &ignore, &save_intr)) + return -1; +# endif + +# ifdef SIGQUIT + if (-1 == sigaction (SIGQUIT, &ignore, &save_quit)) + { + (void) sigaction (SIGINT, &save_intr, NULL); + return -1; + } +# endif + +# ifdef SIGCHLD + sigemptyset (&child_mask); + sigaddset (&child_mask, SIGCHLD); + if (-1 == sigprocmask (SIG_BLOCK, &child_mask, &save_mask)) + { +# ifdef SIGINT + (void) sigaction (SIGINT, &save_intr, NULL); +# endif +# ifdef SIGQUIT + (void) sigaction (SIGQUIT, &save_quit, NULL); +# endif + return -1; + } +# endif + + pid = fork(); + + if (pid == -1) + status = -1; + else if (pid == 0) + { + /* Child */ +# ifdef SIGINT + (void) sigaction (SIGINT, &save_intr, NULL); +# endif +# ifdef SIGQUIT + (void) sigaction (SIGQUIT, &save_quit, NULL); +# endif +# ifdef SIGCHLD + (void) sigprocmask (SIG_SETMASK, &save_mask, NULL); +# endif + + execl ("/bin/sh", "sh", "-c", cmd, NULL); + _exit (127); + } + else + { + /* parent */ + while (-1 == waitpid (pid, &status, 0)) + { +# ifdef EINTR + if (errno == EINTR) + continue; +# endif +# ifdef ERESTARTSYS + if (errno == ERESTARTSYS) + continue; +# endif + status = -1; + break; + } + } +# ifdef SIGINT + if (-1 == sigaction (SIGINT, &save_intr, NULL)) + status = -1; +# endif +# ifdef SIGQUIT + if (-1 == sigaction (SIGQUIT, &save_quit, NULL)) + status = -1; +# endif +# ifdef SIGCHLD + if (-1 == sigprocmask (SIG_SETMASK, &save_mask, NULL)) + status = -1; +# endif + + return status; + +#else /* No POSIX Signals */ +# ifdef SIGINT + void (*sint)(int); +# endif +# ifdef SIGQUIT + void (*squit)(int); +# endif + int status; + +# ifdef SIGQUIT + squit = SLsignal (SIGQUIT, SIG_IGN); +# endif +# ifdef SIGINT + sint = SLsignal (SIGINT, SIG_IGN); +# endif + status = system (cmd); +# ifdef SIGINT + SLsignal (SIGINT, sint); +# endif +# ifdef SIGQUIT + SLsignal (SIGQUIT, squit); +# endif + return status; +#endif /* POSIX_SIGNALS */ +} +#endif + +#if 0 +#include <windows.h> +static int msw_system (char *cmd) +{ + STARTUPINFO startup_info; + PROCESS_INFORMATION process_info; + int status; + + if (cmd == NULL) return -1; + + memset ((char *) &startup_info, 0, sizeof (STARTUPINFO)); + startup_info.cb = sizeof(STARTUPINFO); + startup_info.dwFlags = STARTF_USESHOWWINDOW; + startup_info.wShowWindow = SW_SHOWDEFAULT; + + if (FALSE == CreateProcess (NULL, + cmd, + NULL, + NULL, + FALSE, + NORMAL_PRIORITY_CLASS|CREATE_NEW_CONSOLE, + NULL, + NULL, + &startup_info, + &process_info)) + { + SLang_verror (0, "%s: CreateProcess failed.", cmd); + return -1; + } + + status = -1; + + if (0xFFFFFFFFUL != WaitForSingleObject (process_info.hProcess, INFINITE)) + { + DWORD exit_code; + + if (TRUE == GetExitCodeProcess (process_info.hProcess, &exit_code)) + status = (int) exit_code; + } + + CloseHandle (process_info.hThread); + CloseHandle (process_info.hProcess); + + return status; +} +#endif diff --git a/mdk-stage1/slang/slsmg.c b/mdk-stage1/slang/slsmg.c new file mode 100644 index 000000000..088557f27 --- /dev/null +++ b/mdk-stage1/slang/slsmg.c @@ -0,0 +1,1584 @@ +/* SLang Screen management routines */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +typedef struct Screen_Type + { + int n; /* number of chars written last time */ + int flags; /* line untouched, etc... */ + SLsmg_Char_Type *old, *neew; +#ifndef IBMPC_SYSTEM + unsigned long old_hash, new_hash; +#endif + } +Screen_Type; + +#define TOUCHED 0x1 +#define TRASHED 0x2 +static int Screen_Trashed; + +#if !defined(__MSDOS_16BIT__) +# define MAX_SCREEN_SIZE 256 +#else +# define MAX_SCREEN_SIZE 75 +#endif + +Screen_Type SL_Screen[MAX_SCREEN_SIZE]; +static int Start_Col, Start_Row; +static int Screen_Cols, Screen_Rows; +static int This_Row, This_Col; +static int This_Color; /* only the first 8 bits of this + * are used. The highest bit is used + * to indicate an alternate character + * set. This leaves 127 userdefineable + * color combination. + */ + +#ifndef IBMPC_SYSTEM +#define ALT_CHAR_FLAG 0x80 +#else +#define ALT_CHAR_FLAG 0x00 +#endif + +#if SLTT_HAS_NON_BCE_SUPPORT && !defined(IBMPC_SYSTEM) +#define REQUIRES_NON_BCE_SUPPORT 1 +static int Bce_Color_Offset; +#endif + +int SLsmg_Newline_Behavior = 0; +int SLsmg_Backspace_Moves = 0; +/* Backward compatibility. Not used. */ +/* int SLsmg_Newline_Moves; */ + +static void (*tt_normal_video)(void) = SLtt_normal_video; +static void (*tt_goto_rc)(int, int) = SLtt_goto_rc; +static void (*tt_cls) (void) = SLtt_cls; +static void (*tt_del_eol) (void) = SLtt_del_eol; +static void (*tt_smart_puts) (SLsmg_Char_Type *, SLsmg_Char_Type *, int, int) = SLtt_smart_puts; +static int (*tt_flush_output) (void) = SLtt_flush_output; +static int (*tt_reset_video) (void) = SLtt_reset_video; +static int (*tt_init_video) (void) = SLtt_init_video; +static int *tt_Screen_Rows = &SLtt_Screen_Rows; +static int *tt_Screen_Cols = &SLtt_Screen_Cols; + +#ifndef IBMPC_SYSTEM +static void (*tt_set_scroll_region)(int, int) = SLtt_set_scroll_region; +static void (*tt_reverse_index)(int) = SLtt_reverse_index; +static void (*tt_reset_scroll_region)(void) = SLtt_reset_scroll_region; +static void (*tt_delete_nlines)(int) = SLtt_delete_nlines; +#endif + +#ifndef IBMPC_SYSTEM +static int *tt_Term_Cannot_Scroll = &SLtt_Term_Cannot_Scroll; +static int *tt_Has_Alt_Charset = &SLtt_Has_Alt_Charset; +static char **tt_Graphics_Char_Pairs = &SLtt_Graphics_Char_Pairs; +static int *tt_Use_Blink_For_ACS = &SLtt_Use_Blink_For_ACS; +#endif + +static int Smg_Inited; + +static void blank_line (SLsmg_Char_Type *p, int n, unsigned char ch) +{ + register SLsmg_Char_Type *pmax = p + n; + register SLsmg_Char_Type color_ch; + + color_ch = SLSMG_BUILD_CHAR(ch,This_Color); + + while (p < pmax) + { + *p++ = color_ch; + } +} + +static void clear_region (int row, int n) +{ + int i; + int imax = row + n; + + if (imax > Screen_Rows) imax = Screen_Rows; + for (i = row; i < imax; i++) + { + if (i >= 0) + { + blank_line (SL_Screen[i].neew, Screen_Cols, ' '); + SL_Screen[i].flags |= TOUCHED; + } + } +} + +void SLsmg_erase_eol (void) +{ + int r, c; + + if (Smg_Inited == 0) return; + + c = This_Col - Start_Col; + r = This_Row - Start_Row; + + if ((r < 0) || (r >= Screen_Rows)) return; + if (c < 0) c = 0; else if (c >= Screen_Cols) return; + blank_line (SL_Screen[This_Row].neew + c , Screen_Cols - c, ' '); + SL_Screen[This_Row].flags |= TOUCHED; +} + +static void scroll_up (void) +{ + unsigned int i, imax; + SLsmg_Char_Type *neew; + + neew = SL_Screen[0].neew; + imax = Screen_Rows - 1; + for (i = 0; i < imax; i++) + { + SL_Screen[i].neew = SL_Screen[i + 1].neew; + SL_Screen[i].flags |= TOUCHED; + } + SL_Screen[i].neew = neew; + SL_Screen[i].flags |= TOUCHED; + blank_line (neew, Screen_Cols, ' '); + This_Row--; +} + +void SLsmg_gotorc (int r, int c) +{ + This_Row = r; + This_Col = c; +} + +int SLsmg_get_row (void) +{ + return This_Row; +} + +int SLsmg_get_column (void) +{ + return This_Col; +} + +void SLsmg_erase_eos (void) +{ + if (Smg_Inited == 0) return; + + SLsmg_erase_eol (); + clear_region (This_Row + 1, Screen_Rows); +} + +static int This_Alt_Char; + +void SLsmg_set_char_set (int i) +{ +#ifdef IBMPC_SYSTEM + (void) i; +#else + if ((tt_Use_Blink_For_ACS != NULL) + && (*tt_Use_Blink_For_ACS != 0)) + return;/* alt chars not used and the alt bit + * is used to indicate a blink. + */ + + if (i) This_Alt_Char = ALT_CHAR_FLAG; + else This_Alt_Char = 0; + + This_Color &= 0x7F; + This_Color |= This_Alt_Char; +#endif +} + +void SLsmg_set_color (int color) +{ + if (color < 0) return; +#ifdef REQUIRES_NON_BCE_SUPPORT + color += Bce_Color_Offset; +#endif + This_Color = color | This_Alt_Char; +} + +void SLsmg_reverse_video (void) +{ + SLsmg_set_color (1); +} + +void SLsmg_normal_video (void) +{ + SLsmg_set_color (0); +} + +static int point_visible (int col_too) +{ + return ((This_Row >= Start_Row) && (This_Row < Start_Row + Screen_Rows) + && ((col_too == 0) + || ((This_Col >= Start_Col) + && (This_Col < Start_Col + Screen_Cols)))); +} + +void SLsmg_write_string (char *str) +{ + SLsmg_write_nchars (str, strlen (str)); +} + +void SLsmg_write_nstring (char *str, unsigned int n) +{ + unsigned int width; + char blank = ' '; + + /* Avoid a problem if a user accidently passes a negative value */ + if ((int) n < 0) + return; + + if (str == NULL) width = 0; + else + { + width = strlen (str); + if (width > n) width = n; + SLsmg_write_nchars (str, width); + } + while (width++ < n) SLsmg_write_nchars (&blank, 1); +} + +void SLsmg_write_wrapped_string (char *s, int r, int c, + unsigned int dr, unsigned int dc, + int fill) +{ + register char ch, *p; + int maxc = (int) dc; + + if ((dr == 0) || (dc == 0)) return; + p = s; + dc = 0; + while (1) + { + ch = *p++; + if ((ch == 0) || (ch == '\n')) + { + int diff; + + diff = maxc - (int) dc; + + SLsmg_gotorc (r, c); + SLsmg_write_nchars (s, dc); + if (fill && (diff > 0)) + { + while (diff--) SLsmg_write_char (' '); + } + if ((ch == 0) || (dr == 1)) break; + + r++; + dc = 0; + dr--; + s = p; + } + else if ((int) dc == maxc) + { + SLsmg_gotorc (r, c); + SLsmg_write_nchars (s, dc + 1); + if (dr == 1) break; + + r++; + dc = 0; + dr--; + s = p; + } + else dc++; + } +} + +int SLsmg_Tab_Width = 8; + +/* Minimum value for which eight bit char is displayed as is. */ + +#ifndef IBMPC_SYSTEM +int SLsmg_Display_Eight_Bit = 160; +static unsigned char Alt_Char_Set[129];/* 129th is used as a flag */ +#else +int SLsmg_Display_Eight_Bit = 128; +#endif + +void SLsmg_write_nchars (char *str, unsigned int n) +{ + register SLsmg_Char_Type *p, old, neew, color; + unsigned char ch; + unsigned int flags; + int len, start_len, max_len; + char *str_max; + int newline_flag; +#ifndef IBMPC_SYSTEM + int alt_char_set_flag; + + alt_char_set_flag = ((This_Color & ALT_CHAR_FLAG) + && ((tt_Use_Blink_For_ACS == NULL) + || (*tt_Use_Blink_For_ACS == 0))); +#endif + + if (Smg_Inited == 0) return; + + str_max = str + n; + color = This_Color; + + top: /* get here only on newline */ + + newline_flag = 0; + start_len = Start_Col; + + if (point_visible (0) == 0) return; + + len = This_Col; + max_len = start_len + Screen_Cols; + + p = SL_Screen[This_Row - Start_Row].neew; + if (len > start_len) p += (len - start_len); + + flags = SL_Screen[This_Row - Start_Row].flags; + while ((len < max_len) && (str < str_max)) + { + ch = (unsigned char) *str++; + +#ifndef IBMPC_SYSTEM + if (alt_char_set_flag) + ch = Alt_Char_Set [ch & 0x7F]; +#endif + if (((ch >= ' ') && (ch < 127)) + || (ch >= (unsigned char) SLsmg_Display_Eight_Bit) +#ifndef IBMPC_SYSTEM + || alt_char_set_flag +#endif + ) + { + len += 1; + if (len > start_len) + { + old = *p; + neew = SLSMG_BUILD_CHAR(ch,color); + if (old != neew) + { + flags |= TOUCHED; + *p = neew; + } + p++; + } + } + + else if ((ch == '\t') && (SLsmg_Tab_Width > 0)) + { + n = len; + n += SLsmg_Tab_Width; + n = SLsmg_Tab_Width - (n % SLsmg_Tab_Width); + if ((unsigned int) len + n > (unsigned int) max_len) + n = (unsigned int) (max_len - len); + neew = SLSMG_BUILD_CHAR(' ',color); + while (n--) + { + len += 1; + if (len > start_len) + { + if (*p != neew) + { + flags |= TOUCHED; + *p = neew; + } + p++; + } + } + } + else if ((ch == '\n') + && (SLsmg_Newline_Behavior != SLSMG_NEWLINE_PRINTABLE)) + { + newline_flag = 1; + break; + } + else if ((ch == 0x8) && SLsmg_Backspace_Moves) + { + if (len != 0) len--; + } + else + { + if (ch & 0x80) + { + neew = SLSMG_BUILD_CHAR('~',color); + len += 1; + if (len > start_len) + { + if (*p != neew) + { + *p = neew; + flags |= TOUCHED; + } + p++; + if (len == max_len) break; + ch &= 0x7F; + } + } + + len += 1; + if (len > start_len) + { + neew = SLSMG_BUILD_CHAR('^',color); + if (*p != neew) + { + *p = neew; + flags |= TOUCHED; + } + p++; + if (len == max_len) break; + } + + if (ch == 127) ch = '?'; else ch = ch + '@'; + len++; + if (len > start_len) + { + neew = SLSMG_BUILD_CHAR(ch,color); + if (*p != neew) + { + *p = neew; + flags |= TOUCHED; + } + p++; + } + } + } + + SL_Screen[This_Row - Start_Row].flags = flags; + This_Col = len; + + if (SLsmg_Newline_Behavior == 0) + return; + + if (newline_flag == 0) + { + while (str < str_max) + { + if (*str == '\n') break; + str++; + } + if (str == str_max) return; + str++; + } + + This_Row++; + This_Col = 0; + if (This_Row == Start_Row + Screen_Rows) + { + if (SLsmg_Newline_Behavior == SLSMG_NEWLINE_SCROLLS) scroll_up (); + } + goto top; +} + +void SLsmg_write_char (char ch) +{ + SLsmg_write_nchars (&ch, 1); +} + +static int Cls_Flag; + +void SLsmg_cls (void) +{ + int tac; + if (Smg_Inited == 0) return; + + tac = This_Alt_Char; This_Alt_Char = 0; + SLsmg_set_color (0); + clear_region (0, Screen_Rows); + This_Alt_Char = tac; + SLsmg_set_color (0); + Cls_Flag = 1; +} +#if 0 +static void do_copy (SLsmg_Char_Type *a, SLsmg_Char_Type *b) +{ + SLsmg_Char_Type *amax = a + Screen_Cols; + + while (a < amax) *a++ = *b++; +} +#endif + +#ifndef IBMPC_SYSTEM +int SLsmg_Scroll_Hash_Border = 0; +static unsigned long compute_hash (SLsmg_Char_Type *s, int n) +{ + register unsigned long h = 0, g; + register unsigned long sum = 0; + register SLsmg_Char_Type *smax, ch; + int is_blank = 2; + + s += SLsmg_Scroll_Hash_Border; + smax = s + (n - SLsmg_Scroll_Hash_Border); + while (s < smax) + { + ch = *s++; + if (is_blank && (SLSMG_EXTRACT_CHAR(ch) != 32)) is_blank--; + + sum += ch; + + h = sum + (h << 3); + if ((g = h & 0xE0000000UL) != 0) + { + h = h ^ (g >> 24); + h = h ^ g; + } + } + if (is_blank) return 0; + return h; +} + +static unsigned long Blank_Hash; + +static int try_scroll_down (int rmin, int rmax) +{ + int i, r1, r2, di, j; + unsigned long hash; + int did_scroll; + int color; + SLsmg_Char_Type *tmp; + int ignore; + + did_scroll = 0; + for (i = rmax; i > rmin; i--) + { + hash = SL_Screen[i].new_hash; + if (hash == Blank_Hash) continue; + + if ((hash == SL_Screen[i].old_hash) +#if 0 + || ((i + 1 < Screen_Rows) && (hash == SL_Screen[i + 1].old_hash)) + || ((i - 1 > rmin) && (SL_Screen[i].old_hash == SL_Screen[i - 1].new_hash)) +#endif + ) + continue; + + for (j = i - 1; j >= rmin; j--) + { + if (hash == SL_Screen[j].old_hash) break; + } + if (j < rmin) continue; + + r2 = i; /* end scroll region */ + + di = i - j; + j--; + ignore = 0; + while ((j >= rmin) && (SL_Screen[j].old_hash == SL_Screen[j + di].new_hash)) + { + if (SL_Screen[j].old_hash == Blank_Hash) ignore++; + j--; + } + r1 = j + 1; + + /* If this scroll only scrolls this line into place, don't do it. + */ + if ((di > 1) && (r1 + di + ignore == r2)) continue; + + /* If there is anything in the scrolling region that is ok, abort the + * scroll. + */ + + for (j = r1; j <= r2; j++) + { + if ((SL_Screen[j].old_hash != Blank_Hash) + && (SL_Screen[j].old_hash == SL_Screen[j].new_hash)) + { + /* See if the scroll is happens to scroll this one into place. */ + if ((j + di > r2) || (SL_Screen[j].old_hash != SL_Screen[j + di].new_hash)) + break; + } + } + if (j <= r2) continue; + + color = This_Color; This_Color = 0; + did_scroll = 1; + (*tt_normal_video) (); + (*tt_set_scroll_region) (r1, r2); + (*tt_goto_rc) (0, 0); + (*tt_reverse_index) (di); + (*tt_reset_scroll_region) (); + /* Now we have a hole in the screen. + * Make the virtual screen look like it. + * + * Note that if the terminal does not support BCE, then we have + * no idea what color the hole is. So, for this case, we do not + * want to add Bce_Color_Offset to This_Color since if Bce_Color_Offset + * is non-zero, then This_Color = 0 does not match any valid color + * obtained by adding Bce_Color_Offset. + */ + for (j = r1; j <= r2; j++) SL_Screen[j].flags = TOUCHED; + + while (di--) + { + tmp = SL_Screen[r2].old; + for (j = r2; j > r1; j--) + { + SL_Screen[j].old = SL_Screen[j - 1].old; + SL_Screen[j].old_hash = SL_Screen[j - 1].old_hash; + } + SL_Screen[r1].old = tmp; + blank_line (SL_Screen[r1].old, Screen_Cols, ' '); + SL_Screen[r1].old_hash = Blank_Hash; + r1++; + } + This_Color = color; + } + + return did_scroll; +} + +static int try_scroll_up (int rmin, int rmax) +{ + int i, r1, r2, di, j; + unsigned long hash; + int did_scroll; + int color; + SLsmg_Char_Type *tmp; + int ignore; + + did_scroll = 0; + for (i = rmin; i < rmax; i++) + { + hash = SL_Screen[i].new_hash; + if (hash == Blank_Hash) continue; + if (hash == SL_Screen[i].old_hash) + continue; + /* find a match further down screen */ + for (j = i + 1; j <= rmax; j++) + { + if (hash == SL_Screen[j].old_hash) break; + } + if (j > rmax) continue; + + r1 = i; /* beg scroll region */ + di = j - i; /* number of lines to scroll */ + j++; /* since we know this is a match */ + + /* find end of scroll region */ + ignore = 0; + while ((j <= rmax) && (SL_Screen[j].old_hash == SL_Screen[j - di].new_hash)) + { + if (SL_Screen[j].old_hash == Blank_Hash) ignore++; + j++; + } + r2 = j - 1; /* end of scroll region */ + + /* If this scroll only scrolls this line into place, don't do it. + */ + if ((di > 1) && (r1 + di + ignore == r2)) continue; + + /* If there is anything in the scrolling region that is ok, abort the + * scroll. + */ + + for (j = r1; j <= r2; j++) + { + if ((SL_Screen[j].old_hash != Blank_Hash) + && (SL_Screen[j].old_hash == SL_Screen[j].new_hash)) + { + if ((j - di < r1) || (SL_Screen[j].old_hash != SL_Screen[j - di].new_hash)) + break; + } + + } + if (j <= r2) continue; + + did_scroll = 1; + + /* See the above comments about BCE */ + color = This_Color; This_Color = 0; + (*tt_normal_video) (); + (*tt_set_scroll_region) (r1, r2); + (*tt_goto_rc) (0, 0); /* relative to scroll region */ + (*tt_delete_nlines) (di); + (*tt_reset_scroll_region) (); + /* Now we have a hole in the screen. Make the virtual screen look + * like it. + */ + for (j = r1; j <= r2; j++) SL_Screen[j].flags = TOUCHED; + + while (di--) + { + tmp = SL_Screen[r1].old; + for (j = r1; j < r2; j++) + { + SL_Screen[j].old = SL_Screen[j + 1].old; + SL_Screen[j].old_hash = SL_Screen[j + 1].old_hash; + } + SL_Screen[r2].old = tmp; + blank_line (SL_Screen[r2].old, Screen_Cols, ' '); + SL_Screen[r2].old_hash = Blank_Hash; + r2--; + } + This_Color = color; + } + return did_scroll; +} + +static void try_scroll (void) +{ + int r1, rmin, rmax; + int num_up, num_down; + /* find region limits. */ + + for (rmax = Screen_Rows - 1; rmax > 0; rmax--) + { + if (SL_Screen[rmax].new_hash != SL_Screen[rmax].old_hash) + { + r1 = rmax - 1; + if ((r1 == 0) + || (SL_Screen[r1].new_hash != SL_Screen[r1].old_hash)) + break; + + rmax = r1; + } + } + + for (rmin = 0; rmin < rmax; rmin++) + { + if (SL_Screen[rmin].new_hash != SL_Screen[rmin].old_hash) + { + r1 = rmin + 1; + if ((r1 == rmax) + || (SL_Screen[r1].new_hash != SL_Screen[r1].old_hash)) + break; + + rmin = r1; + } + } + + /* Below, we have two scrolling algorithms. The first has the effect of + * scrolling lines down. This is usually appropriate when one moves + * up the display, e.g., with the UP arrow. The second algorithm is + * appropriate for going the other way. It is important to choose the + * correct one. + */ + + num_up = 0; + for (r1 = rmin; r1 < rmax; r1++) + { + if (SL_Screen[r1].new_hash == SL_Screen[r1 + 1].old_hash) + num_up++; + } + + num_down = 0; + for (r1 = rmax; r1 > rmin; r1--) + { + if (SL_Screen[r1 - 1].old_hash == SL_Screen[r1].new_hash) + num_down++; + } + + if (num_up > num_down) + { + if (try_scroll_up (rmin, rmax)) + return; + + (void) try_scroll_down (rmin, rmax); + } + else + { + if (try_scroll_down (rmin, rmax)) + return; + + (void) try_scroll_up (rmin, rmax); + } +} +#endif /* NOT IBMPC_SYSTEM */ + + +#ifdef REQUIRES_NON_BCE_SUPPORT +static void adjust_colors (void) +{ + int bce; + int i; + + bce = Bce_Color_Offset; + Bce_Color_Offset = _SLtt_get_bce_color_offset (); + if (bce == Bce_Color_Offset) + return; + + if ((tt_Use_Blink_For_ACS != NULL) + && (*tt_Use_Blink_For_ACS != 0)) + return; /* this mode does not support non-BCE + * terminals. + */ + + for (i = 0; i < Screen_Rows; i++) + { + SLsmg_Char_Type *s, *smax; + + SL_Screen[i].flags |= TRASHED; + s = SL_Screen[i].neew; + smax = s + Screen_Cols; + + while (s < smax) + { + int color = (int) SLSMG_EXTRACT_COLOR(*s); + int acs; + + if (color < 0) + { + s++; + continue; + } + + acs = color & 0x80; + color = (color & 0x7F) - bce; + color += Bce_Color_Offset; + if (color >= 0) + { + unsigned char ch = SLSMG_EXTRACT_CHAR(*s); + *s = SLSMG_BUILD_CHAR(ch, ((color&0x7F)|acs)); + } + s++; + } + } +} +#endif + +void SLsmg_refresh (void) +{ + int i; +#ifndef IBMPC_SYSTEM + int trashed = 0; +#endif + + if (Smg_Inited == 0) return; + + if (Screen_Trashed) + { + Cls_Flag = 1; + for (i = 0; i < Screen_Rows; i++) + SL_Screen[i].flags |= TRASHED; +#ifdef REQUIRES_NON_BCE_SUPPORT + adjust_colors (); +#endif + } + +#ifndef IBMPC_SYSTEM + for (i = 0; i < Screen_Rows; i++) + { + if (SL_Screen[i].flags == 0) continue; + SL_Screen[i].new_hash = compute_hash (SL_Screen[i].neew, Screen_Cols); + trashed = 1; + } +#endif + + if (Cls_Flag) + { + (*tt_normal_video) (); (*tt_cls) (); + } +#ifndef IBMPC_SYSTEM + else if (trashed && (*tt_Term_Cannot_Scroll == 0)) try_scroll (); +#endif + + for (i = 0; i < Screen_Rows; i++) + { + if (SL_Screen[i].flags == 0) continue; + + if (Cls_Flag || SL_Screen[i].flags & TRASHED) + { + int color = This_Color; + + if (Cls_Flag == 0) + { + (*tt_goto_rc) (i, 0); + (*tt_del_eol) (); + } + This_Color = 0; + blank_line (SL_Screen[i].old, Screen_Cols, ' '); + This_Color = color; + } + + SL_Screen[i].old[Screen_Cols] = 0; + SL_Screen[i].neew[Screen_Cols] = 0; + + (*tt_smart_puts) (SL_Screen[i].neew, SL_Screen[i].old, Screen_Cols, i); + + SLMEMCPY ((char *) SL_Screen[i].old, (char *) SL_Screen[i].neew, + Screen_Cols * sizeof (SLsmg_Char_Type)); + + SL_Screen[i].flags = 0; +#ifndef IBMPC_SYSTEM + SL_Screen[i].old_hash = SL_Screen[i].new_hash; +#endif + } + + if (point_visible (1)) (*tt_goto_rc) (This_Row - Start_Row, This_Col - Start_Col); + (*tt_flush_output) (); + Cls_Flag = 0; + Screen_Trashed = 0; +} + +static int compute_clip (int row, int n, int box_start, int box_end, + int *rmin, int *rmax) +{ + int row_max; + + if (n < 0) return 0; + if (row >= box_end) return 0; + row_max = row + n; + if (row_max <= box_start) return 0; + + if (row < box_start) row = box_start; + if (row_max >= box_end) row_max = box_end; + *rmin = row; + *rmax = row_max; + return 1; +} + +void SLsmg_touch_lines (int row, unsigned int n) +{ + int i; + int r1, r2; + + /* Allow this function to be called even when we are not initialied. + * Calling this function is useful after calling SLtt_set_color + * to force the display to be redrawn + */ + + if (Smg_Inited == 0) + return; + + if (0 == compute_clip (row, (int) n, Start_Row, Start_Row + Screen_Rows, &r1, &r2)) + return; + + r1 -= Start_Row; + r2 -= Start_Row; + for (i = r1; i < r2; i++) + { + SL_Screen[i].flags |= TRASHED; + } +} + +void SLsmg_touch_screen (void) +{ + Screen_Trashed = 1; +} + + +#ifndef IBMPC_SYSTEM +static char Fake_Alt_Char_Pairs [] = "a:j+k+l+m+q-t+u+v+w+x|n+`+f\\g#~o,<+>.v-^h#0#"; + +static void init_alt_char_set (void) +{ + int i; + unsigned char *p, *pmax, ch; + + if (Alt_Char_Set[128] == 128) return; + + i = 32; + memset ((char *)Alt_Char_Set, ' ', i); + while (i <= 128) + { + Alt_Char_Set [i] = i; + i++; + } + + /* Map to VT100 */ + if (*tt_Has_Alt_Charset) + { + if (tt_Graphics_Char_Pairs == NULL) p = NULL; + else p = (unsigned char *) *tt_Graphics_Char_Pairs; + if (p == NULL) return; + } + else p = (unsigned char *) Fake_Alt_Char_Pairs; + pmax = p + strlen ((char *) p); + + /* Some systems have messed up entries for this */ + while (p < pmax) + { + ch = *p++; + ch &= 0x7F; /* should be unnecessary */ + Alt_Char_Set [ch] = *p; + p++; + } +} +#endif + +#ifndef IBMPC_SYSTEM +# define BLOCK_SIGNALS SLsig_block_signals () +# define UNBLOCK_SIGNALS SLsig_unblock_signals () +#else +# define BLOCK_SIGNALS (void)0 +# define UNBLOCK_SIGNALS (void)0 +#endif + +static int Smg_Suspended; +int SLsmg_suspend_smg (void) +{ + BLOCK_SIGNALS; + + if (Smg_Suspended == 0) + { + (*tt_reset_video) (); + Smg_Suspended = 1; + } + + UNBLOCK_SIGNALS; + return 0; +} + +int SLsmg_resume_smg (void) +{ + BLOCK_SIGNALS; + + if (Smg_Suspended == 0) + { + UNBLOCK_SIGNALS; + return 0; + } + + Smg_Suspended = 0; + + if (-1 == (*tt_init_video) ()) + { + UNBLOCK_SIGNALS; + return -1; + } + + Cls_Flag = 1; + SLsmg_touch_screen (); + SLsmg_refresh (); + + UNBLOCK_SIGNALS; + return 0; +} + + +static void reset_smg (void) +{ + int i; + if (Smg_Inited == 0) + return; + + for (i = 0; i < Screen_Rows; i++) + { + SLfree ((char *)SL_Screen[i].old); + SLfree ((char *)SL_Screen[i].neew); + SL_Screen[i].old = SL_Screen[i].neew = NULL; + } + This_Alt_Char = This_Color = 0; + Smg_Inited = 0; +} + + +static int init_smg (void) +{ + int i, len; + SLsmg_Char_Type *old, *neew; + + Smg_Inited = 0; + +#ifdef REQUIRES_NON_BCE_SUPPORT + Bce_Color_Offset = _SLtt_get_bce_color_offset (); +#endif + + Screen_Rows = *tt_Screen_Rows; + if (Screen_Rows > MAX_SCREEN_SIZE) + Screen_Rows = MAX_SCREEN_SIZE; + + Screen_Cols = *tt_Screen_Cols; + + This_Col = This_Row = Start_Col = Start_Row = 0; + + This_Alt_Char = 0; + SLsmg_set_color (0); + Cls_Flag = 1; +#ifndef IBMPC_SYSTEM + init_alt_char_set (); +#endif + len = Screen_Cols + 3; + for (i = 0; i < Screen_Rows; i++) + { + if ((NULL == (old = (SLsmg_Char_Type *) SLmalloc (sizeof(SLsmg_Char_Type) * len))) + || ((NULL == (neew = (SLsmg_Char_Type *) SLmalloc (sizeof(SLsmg_Char_Type) * len))))) + { + SLfree ((char *) old); + return -1; + } + blank_line (old, len, ' '); + blank_line (neew, len, ' '); + SL_Screen[i].old = old; + SL_Screen[i].neew = neew; + SL_Screen[i].flags = 0; +#ifndef IBMPC_SYSTEM + Blank_Hash = compute_hash (old, Screen_Cols); + SL_Screen[i].new_hash = SL_Screen[i].old_hash = Blank_Hash; +#endif + } + + _SLtt_color_changed_hook = SLsmg_touch_screen; + Screen_Trashed = 1; + Smg_Inited = 1; + return 0; +} + + +int SLsmg_init_smg (void) +{ + int ret; + + BLOCK_SIGNALS; + + if (Smg_Inited) + SLsmg_reset_smg (); + + if (-1 == (*tt_init_video) ()) + { + UNBLOCK_SIGNALS; + return -1; + } + + if (-1 == (ret = init_smg ())) + (void) (*tt_reset_video)(); + + UNBLOCK_SIGNALS; + return ret; +} + +int SLsmg_reinit_smg (void) +{ + int ret; + + if (Smg_Inited == 0) + return SLsmg_init_smg (); + + BLOCK_SIGNALS; + reset_smg (); + ret = init_smg (); + UNBLOCK_SIGNALS; + return ret; +} + +void SLsmg_reset_smg (void) +{ + if (Smg_Inited == 0) + return; + + BLOCK_SIGNALS; + + reset_smg (); + (*tt_reset_video)(); + + UNBLOCK_SIGNALS; +} + +SLsmg_Char_Type SLsmg_char_at (void) +{ + if (Smg_Inited == 0) return 0; + + if (point_visible (1)) + { + return SL_Screen[This_Row - Start_Row].neew[This_Col - Start_Col]; + } + return 0; +} + +void SLsmg_vprintf (char *fmt, va_list ap) +{ + char buf[1024]; + + if (Smg_Inited == 0) return; + + (void) _SLvsnprintf (buf, sizeof (buf), fmt, ap); + SLsmg_write_string (buf); +} + +void SLsmg_printf (char *fmt, ...) +{ + va_list ap; + unsigned int len; + char *f; + + if (Smg_Inited == 0) return; + + va_start(ap, fmt); + + f = fmt; + while (*f && (*f != '%')) + f++; + len = (unsigned int) (f - fmt); + if (len) SLsmg_write_nchars (fmt, len); + + if (*f != 0) + SLsmg_vprintf (f, ap); + + va_end (ap); +} + +void SLsmg_set_screen_start (int *r, int *c) +{ + int orow = Start_Row, oc = Start_Col; + + if (Smg_Inited == 0) return; + + if (c == NULL) Start_Col = 0; + else + { + Start_Col = *c; + *c = oc; + } + if (r == NULL) Start_Row = 0; + else + { + Start_Row = *r; + *r = orow; + } +} + +void SLsmg_draw_object (int r, int c, unsigned char object) +{ + This_Row = r; This_Col = c; + + if (Smg_Inited == 0) return; + + if (point_visible (1)) + { + int color = This_Color; + This_Color |= ALT_CHAR_FLAG; + SLsmg_write_char (object); + This_Color = color; + } + + This_Col = c + 1; +} + +void SLsmg_draw_hline (unsigned int n) +{ + static unsigned char hbuf[16]; + int count; + int cmin, cmax; + int final_col = This_Col + (int) n; + int save_color; + + if (Smg_Inited == 0) return; + + if ((This_Row < Start_Row) || (This_Row >= Start_Row + Screen_Rows) + || (0 == compute_clip (This_Col, n, Start_Col, Start_Col + Screen_Cols, + &cmin, &cmax))) + { + This_Col = final_col; + return; + } + + if (hbuf[0] == 0) + { + SLMEMSET ((char *) hbuf, SLSMG_HLINE_CHAR, 16); + } + + n = (unsigned int)(cmax - cmin); + count = n / 16; + + save_color = This_Color; + This_Color |= ALT_CHAR_FLAG; + This_Col = cmin; + + SLsmg_write_nchars ((char *) hbuf, n % 16); + while (count-- > 0) + { + SLsmg_write_nchars ((char *) hbuf, 16); + } + + This_Color = save_color; + This_Col = final_col; +} + +void SLsmg_draw_vline (int n) +{ + unsigned char ch = SLSMG_VLINE_CHAR; + int c = This_Col, rmin, rmax; + int final_row = This_Row + n; + int save_color; + + if (Smg_Inited == 0) return; + + if (((c < Start_Col) || (c >= Start_Col + Screen_Cols)) || + (0 == compute_clip (This_Row, n, Start_Row, Start_Row + Screen_Rows, + &rmin, &rmax))) + { + This_Row = final_row; + return; + } + + save_color = This_Color; + This_Color |= ALT_CHAR_FLAG; + + for (This_Row = rmin; This_Row < rmax; This_Row++) + { + This_Col = c; + SLsmg_write_nchars ((char *) &ch, 1); + } + + This_Col = c; This_Row = final_row; + This_Color = save_color; +} + +void SLsmg_draw_box (int r, int c, unsigned int dr, unsigned int dc) +{ + if (Smg_Inited == 0) return; + + if (!dr || !dc) return; + This_Row = r; This_Col = c; + dr--; dc--; + SLsmg_draw_hline (dc); + SLsmg_draw_vline (dr); + This_Row = r; This_Col = c; + SLsmg_draw_vline (dr); + SLsmg_draw_hline (dc); + SLsmg_draw_object (r, c, SLSMG_ULCORN_CHAR); + SLsmg_draw_object (r, c + (int) dc, SLSMG_URCORN_CHAR); + SLsmg_draw_object (r + (int) dr, c, SLSMG_LLCORN_CHAR); + SLsmg_draw_object (r + (int) dr, c + (int) dc, SLSMG_LRCORN_CHAR); + This_Row = r; This_Col = c; +} + +void SLsmg_fill_region (int r, int c, unsigned int dr, unsigned int dc, unsigned char ch) +{ + static unsigned char hbuf[16]; + int count; + int dcmax, rmax; + + if (Smg_Inited == 0) return; + + SLsmg_gotorc (r, c); + r = This_Row; c = This_Col; + + dcmax = Screen_Cols - This_Col; + if (dcmax < 0) + return; + + if (dc > (unsigned int) dcmax) dc = (unsigned int) dcmax; + + rmax = This_Row + dr; + if (rmax > Screen_Rows) rmax = Screen_Rows; + +#if 0 + ch = Alt_Char_Set[ch]; +#endif + if (ch != hbuf[0]) SLMEMSET ((char *) hbuf, (char) ch, 16); + + for (This_Row = r; This_Row < rmax; This_Row++) + { + This_Col = c; + count = dc / 16; + SLsmg_write_nchars ((char *) hbuf, dc % 16); + while (count-- > 0) + { + SLsmg_write_nchars ((char *) hbuf, 16); + } + } + + This_Row = r; +} + +void SLsmg_forward (int n) +{ + This_Col += n; +} + +void SLsmg_write_color_chars (SLsmg_Char_Type *s, unsigned int len) +{ + SLsmg_Char_Type *smax, sh; + char buf[32], *b, *bmax; + int color, save_color; + + if (Smg_Inited == 0) return; + + smax = s + len; + b = buf; + bmax = b + sizeof (buf); + + save_color = This_Color; + + while (s < smax) + { + sh = *s++; + + color = SLSMG_EXTRACT_COLOR(sh); + +#if REQUIRES_NON_BCE_SUPPORT + if (Bce_Color_Offset) + { + if (color & 0x80) + color = ((color & 0x7F) + Bce_Color_Offset) | 0x80; + else + color = ((color & 0x7F) + Bce_Color_Offset) & 0x7F; + } +#endif + + if ((color != This_Color) || (b == bmax)) + { + if (b != buf) + { + SLsmg_write_nchars (buf, (int) (b - buf)); + b = buf; + } + This_Color = color; + } + *b++ = (char) SLSMG_EXTRACT_CHAR(sh); + } + + if (b != buf) + SLsmg_write_nchars (buf, (unsigned int) (b - buf)); + + This_Color = save_color; +} + +unsigned int SLsmg_read_raw (SLsmg_Char_Type *buf, unsigned int len) +{ + unsigned int r, c; + + if (Smg_Inited == 0) return 0; + + if (0 == point_visible (1)) return 0; + + r = (unsigned int) (This_Row - Start_Row); + c = (unsigned int) (This_Col - Start_Col); + + if (c + len > (unsigned int) Screen_Cols) + len = (unsigned int) Screen_Cols - c; + + memcpy ((char *) buf, (char *) (SL_Screen[r].neew + c), len * sizeof (SLsmg_Char_Type)); + return len; +} + +unsigned int SLsmg_write_raw (SLsmg_Char_Type *buf, unsigned int len) +{ + unsigned int r, c; + SLsmg_Char_Type *dest; + + if (Smg_Inited == 0) return 0; + + if (0 == point_visible (1)) return 0; + + r = (unsigned int) (This_Row - Start_Row); + c = (unsigned int) (This_Col - Start_Col); + + if (c + len > (unsigned int) Screen_Cols) + len = (unsigned int) Screen_Cols - c; + + dest = SL_Screen[r].neew + c; + + if (0 != memcmp ((char *) dest, (char *) buf, len * sizeof (SLsmg_Char_Type))) + { + memcpy ((char *) dest, (char *) buf, len * sizeof (SLsmg_Char_Type)); + SL_Screen[r].flags |= TOUCHED; + } + return len; +} + +void +SLsmg_set_color_in_region (int color, int r, int c, unsigned int dr, unsigned int dc) +{ + int cmax, rmax; + SLsmg_Char_Type char_mask; + + if (Smg_Inited == 0) return; + + c -= Start_Col; + r -= Start_Row; + + cmax = c + (int) dc; + rmax = r + (int) dr; + + if (cmax > Screen_Cols) cmax = Screen_Cols; + if (rmax > Screen_Rows) rmax = Screen_Rows; + + if (c < 0) c = 0; + if (r < 0) r = 0; + +#if REQUIRES_NON_BCE_SUPPORT + if (Bce_Color_Offset) + { + if (color & 0x80) + color = ((color & 0x7F) + Bce_Color_Offset) | 0x80; + else + color = ((color & 0x7F) + Bce_Color_Offset) & 0x7F; + } +#endif + color = color << 8; + + char_mask = 0xFF; + +#ifndef IBMPC_SYSTEM + if ((tt_Use_Blink_For_ACS == NULL) + || (0 == *tt_Use_Blink_For_ACS)) + char_mask = 0x80FF; +#endif + + while (r < rmax) + { + SLsmg_Char_Type *s, *smax; + + SL_Screen[r].flags |= TOUCHED; + s = SL_Screen[r].neew; + smax = s + cmax; + s += c; + + while (s < smax) + { + *s = (*s & char_mask) | color; + s++; + } + r++; + } +} + +void SLsmg_set_terminal_info (SLsmg_Term_Type *tt) +{ + if (tt == NULL) /* use default */ + return; + + if ((tt->tt_normal_video == NULL) + || (tt->tt_goto_rc == NULL) + || (tt->tt_cls == NULL) + || (tt->tt_del_eol == NULL) + || (tt->tt_smart_puts == NULL) + || (tt->tt_flush_output == NULL) + || (tt->tt_reset_video == NULL) + || (tt->tt_init_video == NULL) +#ifndef IBMPC_SYSTEM + || (tt->tt_set_scroll_region == NULL) + || (tt->tt_reverse_index == NULL) + || (tt->tt_reset_scroll_region == NULL) + || (tt->tt_delete_nlines == NULL) + /* Variables */ + || (tt->tt_term_cannot_scroll == NULL) + || (tt->tt_has_alt_charset == NULL) +#if 0 /* These can be NULL */ + || (tt->tt_use_blink_for_acs == NULL) + || (tt->tt_graphic_char_pairs == NULL) +#endif + || (tt->tt_screen_cols == NULL) + || (tt->tt_screen_rows == NULL) +#endif + ) + SLang_exit_error ("Terminal not powerful enough for SLsmg"); + + tt_normal_video = tt->tt_normal_video; + tt_goto_rc = tt->tt_goto_rc; + tt_cls = tt->tt_cls; + tt_del_eol = tt->tt_del_eol; + tt_smart_puts = tt->tt_smart_puts; + tt_flush_output = tt->tt_flush_output; + tt_reset_video = tt->tt_reset_video; + tt_init_video = tt->tt_init_video; + +#ifndef IBMPC_SYSTEM + tt_set_scroll_region = tt->tt_set_scroll_region; + tt_reverse_index = tt->tt_reverse_index; + tt_reset_scroll_region = tt->tt_reset_scroll_region; + tt_delete_nlines = tt->tt_delete_nlines; + + tt_Term_Cannot_Scroll = tt->tt_term_cannot_scroll; + tt_Has_Alt_Charset = tt->tt_has_alt_charset; + tt_Use_Blink_For_ACS = tt->tt_use_blink_for_acs; + tt_Graphics_Char_Pairs = tt->tt_graphic_char_pairs; +#endif + + tt_Screen_Cols = tt->tt_screen_cols; + tt_Screen_Rows = tt->tt_screen_rows; +} + diff --git a/mdk-stage1/slang/slstd.c b/mdk-stage1/slang/slstd.c new file mode 100644 index 000000000..b05dfcddb --- /dev/null +++ b/mdk-stage1/slang/slstd.c @@ -0,0 +1,724 @@ +/* -*- mode: C; mode: fold; -*- */ +/* Standard intrinsic functions for S-Lang. Included here are string + and array operations */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" +/*{{{ Include Files */ + +#include <time.h> + +#ifndef __QNX__ +# if defined(__GO32__) || defined(__WATCOMC__) +# include <dos.h> +# include <bios.h> +# endif +#endif + +#if SLANG_HAS_FLOAT +# include <math.h> +#endif + +#include "slang.h" +#include "_slang.h" + +/*}}}*/ + +/* builtin stack manipulation functions */ +int SLdo_pop(void) /*{{{*/ +{ + return SLdo_pop_n (1); +} + +/*}}}*/ + +int SLdo_pop_n (unsigned int n) +{ + SLang_Object_Type x; + + while (n--) + { + if (SLang_pop(&x)) return -1; + SLang_free_object (&x); + } + + return 0; +} + +static void do_dup(void) /*{{{*/ +{ + (void) SLdup_n (1); +} + +/*}}}*/ + +static int length_cmd (void) +{ + SLang_Class_Type *cl; + SLang_Object_Type obj; + VOID_STAR p; + unsigned int length; + int len; + + if (-1 == SLang_pop (&obj)) + return -1; + + cl = _SLclass_get_class (obj.data_type); + p = _SLclass_get_ptr_to_value (cl, &obj); + + len = 1; + if (cl->cl_length != NULL) + { + if (0 == (*cl->cl_length)(obj.data_type, p, &length)) + len = (int) length; + else + len = -1; + } + + SLang_free_object (&obj); + return len; +} + +/* convert integer to a string of length 1 */ +static void char_cmd (int *x) /*{{{*/ +{ + char ch, buf[2]; + + ch = (char) *x; + buf[0] = ch; + buf[1] = 0; + SLang_push_string (buf); +} + +/*}}}*/ + +/* format object into a string and returns slstring */ +char *_SLstringize_object (SLang_Object_Type *obj) /*{{{*/ +{ + SLang_Class_Type *cl; + unsigned char stype; + VOID_STAR p; + char *s, *s1; + + stype = obj->data_type; + p = (VOID_STAR) &obj->v.ptr_val; + + cl = _SLclass_get_class (stype); + + s = (*cl->cl_string) (stype, p); + if (s != NULL) + { + s1 = SLang_create_slstring (s); + SLfree (s); + s = s1; + } + return s; +} +/*}}}*/ + +int SLang_run_hooks(char *hook, unsigned int num_args, ...) +{ + unsigned int i; + va_list ap; + + if (SLang_Error) return -1; + + if (0 == SLang_is_defined (hook)) + return 0; + + (void) SLang_start_arg_list (); + va_start (ap, num_args); + for (i = 0; i < num_args; i++) + { + char *arg; + + arg = va_arg (ap, char *); + if (-1 == SLang_push_string (arg)) + break; + } + va_end (ap); + (void) SLang_end_arg_list (); + + if (SLang_Error) return -1; + return SLang_execute_function (hook); +} + +static void intrin_getenv_cmd (char *s) +{ + SLang_push_string (getenv (s)); +} + +#ifdef HAVE_PUTENV +static void intrin_putenv (void) /*{{{*/ +{ + char *s; + + /* Some putenv implementations required malloced strings. */ + if (SLpop_string(&s)) return; + + if (putenv (s)) + { + SLang_Error = SL_INTRINSIC_ERROR; + SLfree (s); + } + + /* Note that s is NOT freed */ +} + +/*}}}*/ + +#endif + +static void lang_print_stack (void) /*{{{*/ +{ + char buf[32]; + unsigned int n; + + n = (unsigned int) (_SLStack_Pointer - _SLRun_Stack); + while (n) + { + n--; + sprintf (buf, "(%u)", n); + _SLdump_objects (buf, _SLRun_Stack + n, 1, 1); + } +} + +/*}}}*/ + +static void byte_compile_file (char *f, int *m) +{ + SLang_byte_compile_file (f, *m); +} + +static void intrin_type_info1 (void) +{ + SLang_Object_Type obj; + unsigned int type; + + if (-1 == SLang_pop (&obj)) + return; + + type = obj.data_type; + if (type == SLANG_ARRAY_TYPE) + type = obj.v.array_val->data_type; + + SLang_free_object (&obj); + + _SLang_push_datatype (type); +} + +static void intrin_type_info (void) +{ + SLang_Object_Type obj; + + if (-1 == SLang_pop (&obj)) + return; + + _SLang_push_datatype (obj.data_type); + SLang_free_object (&obj); +} + +void _SLstring_intrinsic (void) /*{{{*/ +{ + SLang_Object_Type x; + char *s; + + if (SLang_pop (&x)) return; + if (NULL != (s = _SLstringize_object (&x))) + _SLang_push_slstring (s); + + SLang_free_object (&x); +} + +/*}}}*/ + +static void intrin_typecast (void) +{ + unsigned char to_type; + if (0 == _SLang_pop_datatype (&to_type)) + (void) SLclass_typecast (to_type, 0, 1); +} + +#if SLANG_HAS_FLOAT +static void intrin_double (void) +{ + (void) SLclass_typecast (SLANG_DOUBLE_TYPE, 0, 1); +} + +#endif + +static void intrin_int (void) /*{{{*/ +{ + (void) SLclass_typecast (SLANG_INT_TYPE, 0, 1); +} + +/*}}}*/ + +static char * +intrin_function_name (void) +{ + if (NULL == _SLang_Current_Function_Name) + return ""; + return _SLang_Current_Function_Name; +} + +static void intrin_message (char *s) +{ + SLang_vmessage ("%s", s); +} + +static void intrin_error (char *s) +{ + SLang_verror (SL_USER_ERROR, "%s", s); +} + +static void intrin_pop_n (int *n) +{ + SLdo_pop_n ((unsigned int) *n); +} + +static void intrin_reverse_stack (int *n) +{ + SLreverse_stack (*n); +} + +static void intrin_roll_stack (int *n) +{ + SLroll_stack (*n); +} + +static void usage (void) +{ + char *msg; + + _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 1); /* do not include format */ + + if (-1 == SLang_pop_slstring (&msg)) + return; + + SLang_verror (SL_USAGE_ERROR, "Usage: %s", msg); + SLang_free_slstring (msg); +} + +/* Convert string to integer */ +static int intrin_integer (char *s) +{ + int i; + + i = SLatoi ((unsigned char *) s); + + if (SLang_Error) + SLang_verror (SL_TYPE_MISMATCH, "Unable to convert string to integer"); + return i; +} +/*}}}*/ + +static void guess_type (char *s) +{ + _SLang_push_datatype (SLang_guess_type(s)); +} + +static int load_file (char *s) +{ + if (-1 == SLang_load_file (s)) + return 0; + return 1; +} + +static void get_doc_string (char *file, char *topic) +{ + FILE *fp; + char line[1024]; + unsigned int topic_len, str_len; + char *str; + char ch; + + if (NULL == (fp = fopen (file, "r"))) + { + SLang_push_null (); + return; + } + + topic_len = strlen (topic); + ch = *topic; + + while (1) + { + if (NULL == fgets (line, sizeof(line), fp)) + { + fclose (fp); + (void) SLang_push_null (); + return; + } + + if ((ch == *line) + && (0 == strncmp (line, topic, topic_len)) + && ((line[topic_len] == '\n') || (line [topic_len] == 0) + || (line[topic_len] == ' ') || (line[topic_len] == '\t'))) + break; + } + + if (NULL == (str = SLmake_string (line))) + { + fclose (fp); + (void) SLang_push_null (); + return; + } + str_len = strlen (str); + + while (NULL != fgets (line, sizeof (line), fp)) + { + unsigned int len; + char *new_str; + + ch = *line; + if (ch == '#') continue; + if (ch == '-') break; + + len = strlen (line); + if (NULL == (new_str = SLrealloc (str, str_len + len + 1))) + { + SLfree (str); + str = NULL; + break; + } + str = new_str; + strcpy (str + str_len, line); + str_len += len; + } + + fclose (fp); + + (void) SLang_push_malloced_string (str); +} + +static int push_string_array_elements (SLang_Array_Type *at) +{ + char **strs; + unsigned int num; + unsigned int i; + + if (at == NULL) + return -1; + + strs = (char **)at->data; + num = at->num_elements; + for (i = 0; i < num; i++) + { + if (-1 == SLang_push_string (strs[i])) + { + SLdo_pop_n (i); + return -1; + } + } + SLang_push_integer ((int) num); + return 0; +} + + +static void intrin_apropos (void) +{ + int num_args; + char *pat; + char *namespace_name; + unsigned int flags; + SLang_Array_Type *at; + + num_args = SLang_Num_Function_Args; + + if (-1 == SLang_pop_uinteger (&flags)) + return; + if (-1 == SLang_pop_slstring (&pat)) + return; + + namespace_name = NULL; + at = NULL; + if (num_args == 3) + { + if (-1 == SLang_pop_slstring (&namespace_name)) + goto free_and_return; + } + + at = _SLang_apropos (namespace_name, pat, flags); + if (num_args == 3) + { + (void) SLang_push_array (at, 0); + goto free_and_return; + } + + /* Maintain compatibility with old version of the function. That version + * did not take three arguments and returned everything to the stack. + * Yuk. + */ + (void) push_string_array_elements (at); + + free_and_return: + /* NULLs ok */ + SLang_free_slstring (namespace_name); + SLang_free_slstring (pat); + SLang_free_array (at); +} + +static int intrin_get_defines (void) +{ + int n = 0; + char **s = _SLdefines; + + while (*s != NULL) + { + if (-1 == SLang_push_string (*s)) + { + SLdo_pop_n ((unsigned int) n); + return -1; + } + s++; + n++; + } + return n; +} + +static void intrin_get_reference (char *name) +{ + _SLang_push_ref (1, (VOID_STAR) _SLlocate_name (name)); +} + +#ifdef HAVE_SYS_UTSNAME_H +# include <sys/utsname.h> +#endif + +static void uname_cmd (void) +{ +#ifdef HAVE_UNAME + struct utsname u; + char *field_names [6]; + unsigned char field_types[6]; + VOID_STAR field_values [6]; + char *ptrs[6]; + int i; + + if (-1 == uname (&u)) + (void) SLang_push_null (); + + field_names[0] = "sysname"; ptrs[0] = u.sysname; + field_names[1] = "nodename"; ptrs[1] = u.nodename; + field_names[2] = "release"; ptrs[2] = u.release; + field_names[3] = "version"; ptrs[3] = u.version; + field_names[4] = "machine"; ptrs[4] = u.machine; + + for (i = 0; i < 5; i++) + { + field_types[i] = SLANG_STRING_TYPE; + field_values[i] = (VOID_STAR) &ptrs[i]; + } + + if (0 == SLstruct_create_struct (5, field_names, field_types, field_values)) + return; +#endif + + SLang_push_null (); +} + +static void uninitialize_ref_intrin (SLang_Ref_Type *ref) +{ + (void) _SLang_uninitialize_ref (ref); +} + +static SLang_Intrin_Fun_Type SLang_Basic_Table [] = /*{{{*/ +{ + MAKE_INTRINSIC_1("__is_initialized", _SLang_is_ref_initialized, SLANG_INT_TYPE, SLANG_REF_TYPE), + MAKE_INTRINSIC_S("__get_reference", intrin_get_reference, SLANG_VOID_TYPE), + MAKE_INTRINSIC_1("__uninitialize", uninitialize_ref_intrin, SLANG_VOID_TYPE, SLANG_REF_TYPE), + MAKE_INTRINSIC_SS("get_doc_string_from_file", get_doc_string, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SS("autoload", SLang_autoload, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("is_defined", SLang_is_defined, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("string", _SLstring_intrinsic, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("uname", uname_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("getenv", intrin_getenv_cmd, SLANG_VOID_TYPE), +#ifdef HAVE_PUTENV + MAKE_INTRINSIC_0("putenv", intrin_putenv, SLANG_VOID_TYPE), +#endif + MAKE_INTRINSIC_S("evalfile", load_file, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("char", char_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("eval", SLang_load_string, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("dup", do_dup, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("integer", intrin_integer, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("system", SLsystem, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("_apropos", intrin_apropos, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("_trace_function", _SLang_trace_fun, SLANG_VOID_TYPE), +#if SLANG_HAS_FLOAT + MAKE_INTRINSIC_S("atof", _SLang_atof, SLANG_DOUBLE_TYPE), + MAKE_INTRINSIC_0("double", intrin_double, SLANG_VOID_TYPE), +#endif + MAKE_INTRINSIC_0("int", intrin_int, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("typecast", intrin_typecast, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_stkdepth", _SLstack_depth, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("_stk_reverse", intrin_reverse_stack, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("typeof", intrin_type_info, VOID_TYPE), + MAKE_INTRINSIC_0("_typeof", intrin_type_info1, VOID_TYPE), + MAKE_INTRINSIC_I("_pop_n", intrin_pop_n, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_print_stack", lang_print_stack, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("_stk_roll", intrin_roll_stack, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SI("byte_compile_file", byte_compile_file, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_clear_error", _SLang_clear_error, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_function_name", intrin_function_name, SLANG_STRING_TYPE), +#if SLANG_HAS_FLOAT + MAKE_INTRINSIC_S("set_float_format", _SLset_double_format, SLANG_VOID_TYPE), +#endif + MAKE_INTRINSIC_S("_slang_guess_type", guess_type, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("error", intrin_error, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("message", intrin_message, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("__get_defined_symbols", intrin_get_defines, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("__pop_args", _SLstruct_pop_args, SLANG_VOID_TYPE), + MAKE_INTRINSIC_1("__push_args", _SLstruct_push_args, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), + MAKE_INTRINSIC_0("usage", usage, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("implements", _SLang_implements_intrinsic, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("use_namespace", _SLang_use_namespace_intrinsic, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("current_namespace", _SLang_cur_namespace_intrinsic, SLANG_STRING_TYPE), + MAKE_INTRINSIC_0("length", length_cmd, SLANG_INT_TYPE), + SLANG_END_INTRIN_FUN_TABLE +}; + +/*}}}*/ + +#ifdef SLANG_DOC_DIR +char *SLang_Doc_Dir = SLANG_DOC_DIR; +#else +char *SLang_Doc_Dir = ""; +#endif + +static SLang_Intrin_Var_Type Intrin_Vars[] = +{ + MAKE_VARIABLE("_debug_info", &_SLang_Compile_Line_Num_Info, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("_auto_declare", &_SLang_Auto_Declare_Globals, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("_traceback", &SLang_Traceback, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("_slangtrace", &_SLang_Trace, SLANG_INT_TYPE, 0), + MAKE_VARIABLE("_slang_version", &SLang_Version, SLANG_INT_TYPE, 1), + MAKE_VARIABLE("_slang_version_string", &SLang_Version_String, SLANG_STRING_TYPE, 1), + MAKE_VARIABLE("_NARGS", &SLang_Num_Function_Args, SLANG_INT_TYPE, 1), + MAKE_VARIABLE("_slang_doc_dir", &SLang_Doc_Dir, SLANG_STRING_TYPE, 1), + MAKE_VARIABLE("NULL", NULL, SLANG_NULL_TYPE, 1), + SLANG_END_INTRIN_VAR_TABLE +}; + +int SLang_init_slang (void) /*{{{*/ +{ + char name[3]; + unsigned int i; + char **s; + static char *sys_defines [] = + { +#if defined(__os2__) + "OS2", +#endif +#if defined(__MSDOS__) + "MSDOS", +#endif +#if defined(__WIN16__) + "WIN16", +#endif +#if defined (__WIN32__) + "WIN32", +#endif +#if defined(__NT__) + "NT", +#endif +#if defined (VMS) + "VMS", +#endif +#ifdef REAL_UNIX_SYSTEM + "UNIX", +#endif +#if SLANG_HAS_FLOAT + "SLANG_DOUBLE_TYPE", +#endif + NULL + }; + + if (-1 == _SLregister_types ()) return -1; + + if ((-1 == SLadd_intrin_fun_table(SLang_Basic_Table, NULL)) + || (-1 == SLadd_intrin_var_table (Intrin_Vars, NULL)) + || (-1 == _SLang_init_slstrops ()) + || (-1 == _SLang_init_sltime ()) + || (-1 == _SLstruct_init ()) +#if SLANG_HAS_COMPLEX + || (-1 == _SLinit_slcomplex ()) +#endif +#if SLANG_HAS_ASSOC_ARRAYS + || (-1 == SLang_init_slassoc ()) +#endif + ) + return -1; + + SLadd_global_variable (SLANG_SYSTEM_NAME); + + s = sys_defines; + while (*s != NULL) + { + if (-1 == SLdefine_for_ifdef (*s)) return -1; + s++; + } + + /* give temp global variables $0 --> $9 */ + name[2] = 0; name[0] = '$'; + for (i = 0; i < 10; i++) + { + name[1] = (char) (i + '0'); + SLadd_global_variable (name); + } + + SLang_init_case_tables (); + + /* Now add a couple of macros */ + SLang_load_string (".(_NARGS 1 - Sprintf error)verror"); + SLang_load_string (".(_NARGS 1 - Sprintf message)vmessage"); + + if (SLang_Error) + return -1; + + return 0; +} + +/*}}}*/ + +int SLang_set_argc_argv (int argc, char **argv) +{ + static int this_argc; + static char **this_argv; + int i; + + if (argc < 0) argc = 0; + this_argc = argc; + + if (NULL == (this_argv = (char **) SLmalloc ((argc + 1) * sizeof (char *)))) + return -1; + memset ((char *) this_argv, 0, sizeof (char *) * (argc + 1)); + + for (i = 0; i < argc; i++) + { + if (NULL == (this_argv[i] = SLang_create_slstring (argv[i]))) + goto return_error; + } + + if (-1 == SLadd_intrinsic_variable ("__argc", (VOID_STAR)&this_argc, + SLANG_INT_TYPE, 1)) + goto return_error; + + if (-1 == SLang_add_intrinsic_array ("__argv", SLANG_STRING_TYPE, 1, + (VOID_STAR) this_argv, 1, argc)) + goto return_error; + + return 0; + + return_error: + for (i = 0; i < argc; i++) + SLang_free_slstring (this_argv[i]); /* NULL ok */ + SLfree ((char *) this_argv); + + return -1; +} diff --git a/mdk-stage1/slang/slstdio.c b/mdk-stage1/slang/slstdio.c new file mode 100644 index 000000000..05db1af77 --- /dev/null +++ b/mdk-stage1/slang/slstdio.c @@ -0,0 +1,1050 @@ +/* file stdio intrinsics for S-Lang */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if defined(__unix__) || (defined (__os2__) && defined (__EMX__)) +# include <sys/types.h> +#endif + +#ifdef HAVE_FCNTL_H +# include <fcntl.h> +#endif +#ifdef HAVE_SYS_FCNTL_H +# include <sys/fcntl.h> +#endif + +#ifdef __unix__ +# include <sys/file.h> +#endif + +#if defined(__BORLANDC__) +# include <io.h> +# include <dir.h> +#endif + +#if defined(__DECC) && defined(VMS) +# include <unixio.h> +# include <unixlib.h> +#endif + +#ifdef VMS +# include <stat.h> +#else +# include <sys/stat.h> +#endif + +#include <errno.h> + +#define SL_APP_WANTS_FOREACH +#include "slang.h" +#include "_slang.h" + +typedef struct +{ + FILE *fp; /* kind of obvious */ + char *file; /* file name associated with pointer */ + + unsigned int flags; /* modes, etc... */ +#define SL_READ 0x0001 +#define SL_WRITE 0x0002 +#define SL_BINARY 0x0004 +#define SL_FDOPEN 0x2000 +#define SL_PIPE 0x4000 +#define SL_INUSE 0x8000 +} +SL_File_Table_Type; + +static SL_File_Table_Type *SL_File_Table; + +static SL_File_Table_Type *get_free_file_table_entry (void) +{ + SL_File_Table_Type *t = SL_File_Table, *tmax; + + tmax = t + SL_MAX_FILES; + while (t < tmax) + { + if (t->flags == 0) + { + memset ((char *) t, 0, sizeof (SL_File_Table_Type)); + return t; + } + t++; + } + + return NULL; +} + +static unsigned int file_process_flags (char *mode) +{ + char ch; + unsigned int flags = 0; + + while (1) + { + ch = *mode++; + switch (ch) + { + case 'r': flags |= SL_READ; + break; + case 'w': + case 'a': + case 'A': + flags |= SL_WRITE; + break; + case '+': flags |= SL_WRITE | SL_READ; + break; + case 'b': flags |= SL_BINARY; + break; + case 0: + return flags; + + default: + SLang_verror (SL_INVALID_PARM, "File flag %c is not supported", ch); + return 0; + } + } +} + +static int open_file_type (char *file, int fd, char *mode, + FILE *(*open_fun)(char *, char *), + int (*close_fun)(FILE *), + unsigned int xflags) +{ + FILE *fp; + SL_File_Table_Type *t; + unsigned int flags; + SLang_MMT_Type *mmt; + + fp = NULL; + t = NULL; + mmt = NULL; + + if ((NULL == (t = get_free_file_table_entry ())) + || (0 == (flags = file_process_flags(mode)))) + goto return_error; + + if (fd != -1) + fp = fdopen (fd, mode); + else + fp = open_fun (file, mode); + + if (fp == NULL) + { + _SLerrno_errno = errno; + goto return_error; + } + + if (NULL == (mmt = SLang_create_mmt (SLANG_FILE_PTR_TYPE, (VOID_STAR) t))) + goto return_error; + + t->fp = fp; + t->flags = flags | xflags; + fp = NULL; /* allow free_mmt to close fp */ + + if ((NULL != (t->file = SLang_create_slstring (file))) + && (0 == SLang_push_mmt (mmt))) + return 0; + + /* drop */ + + return_error: + if (fp != NULL) (*close_fun) (fp); + if (mmt != NULL) SLang_free_mmt (mmt); + (void) SLang_push_null (); + return -1; +} + +/* Since some compilers do not have popen/pclose prototyped and in scope, + * and pc compilers sometimes have silly prototypes involving PASCAL, etc. + * use wrappers around the function to avoid compilation errors. + */ + +static FILE *fopen_fun (char *f, char *m) +{ + return fopen (f, m); +} +static int fclose_fun (FILE *fp) +{ + return fclose (fp); +} + +static void stdio_fopen (char *file, char *mode) +{ + (void) open_file_type (file, -1, mode, fopen_fun, fclose_fun, 0); +} + +int _SLstdio_fdopen (char *file, int fd, char *mode) +{ + if (fd == -1) + { + _SLerrno_errno = EBADF; + (void) SLang_push_null (); + return -1; + } + + return open_file_type (file, fd, mode, NULL, fclose_fun, SL_FDOPEN); +} + +#ifdef HAVE_POPEN +static int pclose_fun (FILE *fp) +{ + return pclose (fp); +} + +static FILE *popen_fun (char *file, char *mode) +{ + return popen (file, mode); +} + +static void stdio_popen (char *file, char *mode) +{ + (void) open_file_type (file, -1, mode, popen_fun, pclose_fun, SL_PIPE); +} +#endif + +/* returns pointer to file entry if it is open and consistent with + flags. Returns NULL otherwise */ +static SLang_MMT_Type *pop_fp (unsigned int flags, FILE **fp_ptr) +{ + SL_File_Table_Type *t; + SLang_MMT_Type *mmt; + + *fp_ptr = NULL; + + if (NULL == (mmt = SLang_pop_mmt (SLANG_FILE_PTR_TYPE))) + return NULL; + + t = (SL_File_Table_Type *) SLang_object_from_mmt (mmt); + if ((t->flags & flags) + && (NULL != (*fp_ptr = t->fp))) + return mmt; + + SLang_free_mmt (mmt); + return NULL; +} + +static FILE *check_fp (SL_File_Table_Type *t, unsigned flags) +{ + if ((t != NULL) && (t->flags & flags)) + return t->fp; + + return NULL; +} + +char *SLang_get_name_from_fileptr (SLang_MMT_Type *mmt) +{ + SL_File_Table_Type *ft; + + ft = (SL_File_Table_Type *) SLang_object_from_mmt (mmt); + if (ft == NULL) + return NULL; + return ft->file; +} + +int SLang_pop_fileptr (SLang_MMT_Type **mmt, FILE **fp) +{ + if (NULL == (*mmt = pop_fp (0xFFFF, fp))) + { +#ifdef EBADF + _SLerrno_errno = EBADF; +#endif + return -1; + } + + return 0; +} + +static int close_file_type (SL_File_Table_Type *t) +{ + int ret = 0; + FILE *fp; + + if (t == NULL) + return -1; + + fp = t->fp; + + if (NULL == fp) ret = -1; + else + { + if (0 == (t->flags & SL_PIPE)) + { + if (EOF == (ret = fclose (fp))) + _SLerrno_errno = errno; + } +#ifdef HAVE_POPEN + else + { + if (-1 == (ret = pclose (fp))) + _SLerrno_errno = errno; + } +#endif + } + + if (t->file != NULL) SLang_free_slstring (t->file); + memset ((char *) t, 0, sizeof (SL_File_Table_Type)); + return ret; +} + +static int stdio_fclose (SL_File_Table_Type *t) +{ + int ret; + + if (NULL == check_fp (t, 0xFFFF)) + return -1; + + ret = close_file_type (t); + + t->flags = SL_INUSE; + return ret; +} + +static int read_one_line (FILE *fp, char **strp, unsigned int *lenp) +{ + char buf[512]; + char *str; + unsigned int len; + + *strp = NULL; + len = 0; + str = NULL; + + while (NULL != fgets (buf, sizeof (buf), fp)) + { + unsigned int dlen; + char *new_str; + int done_flag; + + dlen = strlen (buf); + /* Note: If the file contains embedded \0 characters, then this + * fails to work properly since dlen will not be correct. + */ + done_flag = ((dlen + 1 < sizeof (buf)) + || (buf[dlen - 1] == '\n')); + + if (done_flag && (str == NULL)) + { + /* Avoid the malloc */ + str = buf; + len = dlen; + break; + } + + if (NULL == (new_str = SLrealloc (str, len + dlen + 1))) + { + SLfree (str); + return -1; + } + + str = new_str; + strcpy (str + len, buf); + len += dlen; + + if (done_flag) break; + } + + if (str == NULL) + return 0; + + *strp = SLang_create_nslstring (str, len); + if (str != buf) SLfree (str); + + if (*strp == NULL) return -1; + + *lenp = len; + return 1; +} + +/* returns number of characters read and pushes the string to the stack. + If it fails, it returns -1 */ +static int stdio_fgets (SLang_Ref_Type *ref, SL_File_Table_Type *t) +{ + char *s; + unsigned int len; + FILE *fp; + int status; + + if (NULL == (fp = check_fp (t, SL_READ))) + return -1; + + status = read_one_line (fp, &s, &len); + if (status <= 0) + return -1; + + status = SLang_assign_to_ref (ref, SLANG_STRING_TYPE, (VOID_STAR)&s); + SLang_free_slstring (s); + + if (status == -1) + return -1; + + return (int) len; +} + +static void stdio_fgetslines_internal (FILE *fp, unsigned int n) +{ + unsigned int num_lines, max_num_lines; + char **list; + SLang_Array_Type *at; + int inum_lines; + + if (n > 1024) + max_num_lines = 1024; + else + { + max_num_lines = n; + if (max_num_lines == 0) + max_num_lines++; + } + + list = (char **) SLmalloc (sizeof (char *) * max_num_lines); + if (list == NULL) + return; + + num_lines = 0; + while (num_lines < n) + { + int status; + char *line; + unsigned int len; + + status = read_one_line (fp, &line, &len); + if (status == -1) + goto return_error; + + if (status == 0) + break; + + if (max_num_lines == num_lines) + { + char **new_list; + + if (max_num_lines + 4096 > n) + max_num_lines = n; + else + max_num_lines += 4096; + + new_list = (char **) SLrealloc ((char *)list, sizeof (char *) * max_num_lines); + if (new_list == NULL) + { + SLang_free_slstring (line); + goto return_error; + } + list = new_list; + } + + list[num_lines] = line; + num_lines++; + } + + if (num_lines != max_num_lines) + { + char **new_list; + + new_list = (char **)SLrealloc ((char *)list, sizeof (char *) * (num_lines + 1)); + if (new_list == NULL) + goto return_error; + + list = new_list; + } + + inum_lines = (int) num_lines; + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) list, &inum_lines, 1))) + goto return_error; + + if (-1 == SLang_push_array (at, 1)) + SLang_push_null (); + return; + + return_error: + while (num_lines > 0) + { + num_lines--; + SLfree (list[num_lines]); + } + SLfree ((char *)list); + SLang_push_null (); +} + +static void stdio_fgetslines (void) +{ + unsigned int n; + FILE *fp; + SLang_MMT_Type *mmt; + + n = (unsigned int)-1; + + if (SLang_Num_Function_Args == 2) + { + if (-1 == SLang_pop_uinteger (&n)) + return; + } + + if (NULL == (mmt = pop_fp (SL_READ, &fp))) + { + SLang_push_null (); + return; + } + + stdio_fgetslines_internal (fp, n); + SLang_free_mmt (mmt); +} + + +static int stdio_fputs (char *s, SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, SL_WRITE))) + return -1; + + if (EOF == fputs(s, fp)) return -1; + return (int) strlen (s); +} + +static int stdio_fflush (SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, SL_WRITE))) + return -1; + + if (EOF == fflush (fp)) + { + _SLerrno_errno = errno; + return -1; + } + + return 0; +} + +/* Usage: n = fread (&str, data-type, nelems, fp); */ +static void stdio_fread (SLang_Ref_Type *ref, int *data_typep, unsigned int *num_elemns, SL_File_Table_Type *t) +{ + char *s; + FILE *fp; + int ret; + unsigned int num_read, num_to_read; + unsigned int nbytes; + SLang_Class_Type *cl; + unsigned int sizeof_type; + int data_type; + + ret = -1; + s = NULL; + cl = NULL; + + if (NULL == (fp = check_fp (t, SL_READ))) + goto the_return; + + /* FIXME: priority = low : I should add some mechanism to support + * other types. + */ + data_type = *data_typep; + + cl = _SLclass_get_class ((unsigned char) data_type); + + if (cl->cl_fread == NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "fread does not support %s objects", + cl->cl_name); + goto the_return; + } + + sizeof_type = cl->cl_sizeof_type; + + num_to_read = *num_elemns; + nbytes = (unsigned int) num_to_read * sizeof_type; + + s = SLmalloc (nbytes + 1); + if (s == NULL) + goto the_return; + + ret = cl->cl_fread (data_type, fp, (VOID_STAR)s, num_to_read, &num_read); + + if ((num_read == 0) + && (num_read != num_to_read)) + ret = -1; + + if ((ret == -1) && ferror (fp)) + _SLerrno_errno = errno; + + if ((ret == 0) + && (num_read != num_to_read)) + { + char *new_s; + + nbytes = num_read * sizeof_type; + new_s = SLrealloc (s, nbytes + 1); + if (new_s == NULL) + ret = -1; + else + s = new_s; + } + + if (ret == 0) + { + if (num_read == 1) + { + ret = SLang_assign_to_ref (ref, data_type, (VOID_STAR)s); + SLfree (s); + } + else if ((data_type == SLANG_CHAR_TYPE) + || (data_type == SLANG_UCHAR_TYPE)) + { + SLang_BString_Type *bs; + + bs = SLbstring_create_malloced ((unsigned char *)s, num_read, 1); + ret = SLang_assign_to_ref (ref, SLANG_BSTRING_TYPE, (VOID_STAR)&bs); + SLbstring_free (bs); + } + else + { + SLang_Array_Type *at; + int inum_read = (int) num_read; + at = SLang_create_array (data_type, 0, (VOID_STAR)s, &inum_read, 1); + ret = SLang_assign_to_ref (ref, SLANG_ARRAY_TYPE, (VOID_STAR)&at); + SLang_free_array (at); + } + s = NULL; + } + + the_return: + + if (s != NULL) + SLfree (s); + + if (ret == -1) + SLang_push_integer (ret); + else + SLang_push_uinteger (num_read); +} + +/* Usage: n = fwrite (str, fp); */ +static void stdio_fwrite (SL_File_Table_Type *t) +{ + FILE *fp; + unsigned char *s; + unsigned int num_to_write, num_write; + int ret; + SLang_BString_Type *b; + SLang_Array_Type *at; + SLang_Class_Type *cl; + + ret = -1; + b = NULL; + at = NULL; + + switch (SLang_peek_at_stack ()) + { + case SLANG_BSTRING_TYPE: + case SLANG_STRING_TYPE: + if (-1 == SLang_pop_bstring (&b)) + goto the_return; + + if (NULL == (s = SLbstring_get_pointer (b, &num_to_write))) + goto the_return; + + cl = _SLclass_get_class (SLANG_UCHAR_TYPE); + break; + + default: + if (-1 == SLang_pop_array (&at, 1)) + goto the_return; + + cl = at->cl; + num_to_write = at->num_elements; + s = (unsigned char *) at->data; + } + + if (NULL == (fp = check_fp (t, SL_WRITE))) + goto the_return; + + if (cl->cl_fwrite == NULL) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "fwrite does not support %s objects", cl->cl_name); + goto the_return; + } + + ret = cl->cl_fwrite (cl->cl_data_type, fp, s, num_to_write, &num_write); + + if ((ret == -1) && ferror (fp)) + _SLerrno_errno = errno; + + /* drop */ + the_return: + if (b != NULL) + SLbstring_free (b); + if (at != NULL) + SLang_free_array (at); + + if (ret == -1) + SLang_push_integer (ret); + else + SLang_push_uinteger (num_write); +} + +static int stdio_fseek (SL_File_Table_Type *t, int *ofs, int *whence) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, 0xFFFF))) + return -1; + + if (-1 == fseek (fp, (long) *ofs, *whence)) + { + _SLerrno_errno = errno; + return -1; + } + + return 0; +} + +static int stdio_ftell (SL_File_Table_Type *t) +{ + FILE *fp; + long ofs; + + if (NULL == (fp = check_fp (t, 0xFFFF))) + return -1; + + if (-1L == (ofs = ftell (fp))) + { + _SLerrno_errno = errno; + return -1; + } + + return (int) ofs; +} + +static int stdio_feof (SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, 0xFFFF))) + return -1; + + return feof (fp); +} + +static int stdio_ferror (SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL == (fp = check_fp (t, 0xFFFF))) + return -1; + + return ferror (fp); +} + +static void stdio_clearerr (SL_File_Table_Type *t) +{ + FILE *fp; + + if (NULL != (fp = check_fp (t, 0xFFFF))) + clearerr (fp); +} + +/* () = fprintf (fp, "FORMAT", arg...); */ +static int stdio_fprintf (void) +{ + char *s; + FILE *fp; + SLang_MMT_Type *mmt; + int status; + + if (-1 == _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 2)) + return -1; + + if (-1 == SLang_pop_slstring (&s)) + return -1; + + if (NULL == (mmt = pop_fp (SL_WRITE, &fp))) + { + SLang_free_slstring (s); + return -1; + } + + if (EOF == fputs(s, fp)) + status = -1; + else + status = (int) strlen (s); + + SLang_free_mmt (mmt); + SLang_free_slstring (s); + return status; +} + +static int stdio_printf (void) +{ + char *s; + int status; + + if (-1 == _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 1)) + return -1; + + if (-1 == SLang_pop_slstring (&s)) + return -1; + + if (EOF == fputs(s, stdout)) + status = -1; + else + status = (int) strlen (s); + + SLang_free_slstring (s); + return status; +} + + +#define F SLANG_FILE_PTR_TYPE +#define R SLANG_REF_TYPE +#define I SLANG_INT_TYPE +#define V SLANG_VOID_TYPE +#define S SLANG_STRING_TYPE +#define B SLANG_BSTRING_TYPE +#define U SLANG_UINT_TYPE +#define D SLANG_DATATYPE_TYPE +static SLang_Intrin_Fun_Type Stdio_Name_Table[] = +{ + MAKE_INTRINSIC_0("fgetslines", stdio_fgetslines, V), + MAKE_INTRINSIC_SS("fopen", stdio_fopen, V), + MAKE_INTRINSIC_1("feof", stdio_feof, I, F), + MAKE_INTRINSIC_1("ferror", stdio_ferror, I, F), + MAKE_INTRINSIC_1("fclose", stdio_fclose, I, F), + MAKE_INTRINSIC_2("fgets", stdio_fgets, I, R, F), + MAKE_INTRINSIC_1("fflush", stdio_fflush, I, F), + MAKE_INTRINSIC_2("fputs", stdio_fputs, I, S, F), + MAKE_INTRINSIC_0("fprintf", stdio_fprintf, I), + MAKE_INTRINSIC_0("printf", stdio_printf, I), + MAKE_INTRINSIC_3("fseek", stdio_fseek, I, F, I, I), + MAKE_INTRINSIC_1("ftell", stdio_ftell, I, F), + MAKE_INTRINSIC_1("clearerr", stdio_clearerr, V, F), + MAKE_INTRINSIC_4("fread", stdio_fread, V, R, D, U, F), + MAKE_INTRINSIC_1("fwrite", stdio_fwrite, V, F), +#ifdef HAVE_POPEN + MAKE_INTRINSIC_SS("popen", stdio_popen, V), + MAKE_INTRINSIC_1("pclose", stdio_fclose, I, F), +#endif + SLANG_END_INTRIN_FUN_TABLE +}; +#undef F +#undef I +#undef R +#undef V +#undef S +#undef B +#undef U +#undef D + +#ifndef SEEK_SET +# define SEEK_SET 0 +#endif +#ifndef SEEK_CUR +# define SEEK_CUR 1 +#endif +#ifndef SEEK_END +# define SEEK_END 2 +#endif + +static SLang_IConstant_Type Stdio_Consts [] = +{ + MAKE_ICONSTANT("SEEK_SET", SEEK_SET), + MAKE_ICONSTANT("SEEK_END", SEEK_END), + MAKE_ICONSTANT("SEEK_CUR", SEEK_CUR), + SLANG_END_ICONST_TABLE +}; + +static void destroy_file_type (unsigned char type, VOID_STAR ptr) +{ + (void) type; + (void) close_file_type ((SL_File_Table_Type *) ptr); +} + + +struct _SLang_Foreach_Context_Type +{ + SLang_MMT_Type *mmt; + FILE *fp; +#define CTX_USE_LINE 1 +#define CTX_USE_CHAR 2 + unsigned char type; +}; + + +static SLang_Foreach_Context_Type * +cl_foreach_open (unsigned char type, unsigned int num) +{ + SLang_Foreach_Context_Type *c; + SLang_MMT_Type *mmt; + FILE *fp; + + if (NULL == (mmt = pop_fp (SL_READ, &fp))) + return NULL; + + type = CTX_USE_LINE; + + switch (num) + { + char *s; + + case 0: + type = CTX_USE_LINE; + break; + + case 1: + if (-1 == SLang_pop_slstring (&s)) + { + SLang_free_mmt (mmt); + return NULL; + } + if (0 == strcmp (s, "char")) + type = CTX_USE_CHAR; + else if (0 == strcmp (s, "line")) + type = CTX_USE_LINE; + else + { + SLang_verror (SL_NOT_IMPLEMENTED, + "using '%s' not supported by File_Type", + s); + SLang_free_slstring (s); + SLang_free_mmt (mmt); + return NULL; + } + SLang_free_slstring (s); + break; + + default: + SLdo_pop_n (num); + SLang_verror (SL_NOT_IMPLEMENTED, + "Usage: foreach (File_Type) using ([line|char])"); + SLang_free_mmt (mmt); + return NULL; + } + + if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type)))) + { + SLang_free_mmt (mmt); + return NULL; + } + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + + c->type = type; + c->mmt = mmt; + c->fp = fp; + + return c; +} + +static void cl_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + SLang_free_mmt (c->mmt); + SLfree ((char *) c); +} + +static int cl_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + int status; + int ch; + unsigned int len; + char *s; + + (void) type; + + if (c == NULL) + return -1; + + switch (c->type) + { + case CTX_USE_CHAR: + if (EOF == (ch = getc (c->fp))) + return 0; + if (-1 == SLang_push_uchar ((unsigned char) ch)) + return -1; + return 1; + + case CTX_USE_LINE: + status = read_one_line (c->fp, &s, &len); + if (status <= 0) + return status; + if (0 == _SLang_push_slstring (s)) + return 1; + return -1; + } + + return -1; +} + +static int Stdio_Initialized; +static SLang_MMT_Type *Stdio_Mmts[3]; + +int SLang_init_stdio (void) +{ + unsigned int i; + SL_File_Table_Type *s; + SLang_Class_Type *cl; + char *names[3]; + + if (Stdio_Initialized) + return 0; + + SL_File_Table = (SL_File_Table_Type *)SLcalloc(sizeof (SL_File_Table_Type), SL_MAX_FILES); + if (SL_File_Table == NULL) + return -1; + + if (NULL == (cl = SLclass_allocate_class ("File_Type"))) + return -1; + cl->cl_destroy = destroy_file_type; + cl->cl_foreach_open = cl_foreach_open; + cl->cl_foreach_close = cl_foreach_close; + cl->cl_foreach = cl_foreach; + + + if (-1 == SLclass_register_class (cl, SLANG_FILE_PTR_TYPE, sizeof (SL_File_Table_Type), SLANG_CLASS_TYPE_MMT)) + return -1; + + if ((-1 == SLadd_intrin_fun_table(Stdio_Name_Table, "__STDIO__")) + || (-1 == SLadd_iconstant_table (Stdio_Consts, NULL)) + || (-1 == _SLerrno_init ())) + return -1; + + names[0] = "stdin"; + names[1] = "stdout"; + names[2] = "stderr"; + + s = SL_File_Table; + s->fp = stdin; s->flags = SL_READ; + + s++; + s->fp = stdout; s->flags = SL_WRITE; + + s++; + s->fp = stderr; s->flags = SL_WRITE|SL_READ; + + s = SL_File_Table; + for (i = 0; i < 3; i++) + { + if (NULL == (s->file = SLang_create_slstring (names[i]))) + return -1; + + if (NULL == (Stdio_Mmts[i] = SLang_create_mmt (SLANG_FILE_PTR_TYPE, (VOID_STAR) s))) + return -1; + SLang_inc_mmt (Stdio_Mmts[i]); + + if (-1 == SLadd_intrinsic_variable (s->file, (VOID_STAR)&Stdio_Mmts[i], SLANG_FILE_PTR_TYPE, 1)) + return -1; + s++; + } + + Stdio_Initialized = 1; + return 0; +} + diff --git a/mdk-stage1/slang/slstring.c b/mdk-stage1/slang/slstring.c new file mode 100644 index 000000000..529c41827 --- /dev/null +++ b/mdk-stage1/slang/slstring.c @@ -0,0 +1,546 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +typedef struct _SLstring_Type +{ + struct _SLstring_Type *next; + unsigned int ref_count; + char bytes [1]; +} +SLstring_Type; + +static SLstring_Type *String_Hash_Table [SLSTRING_HASH_TABLE_SIZE]; +static char Single_Char_Strings [256 * 2]; + +#if _SLANG_OPTIMIZE_FOR_SPEED +#define MAX_FREE_STORE_LEN 32 +static SLstring_Type *SLS_Free_Store [MAX_FREE_STORE_LEN]; + +# define NUM_CACHED_STRINGS 601 +typedef struct +{ + unsigned long hash; + SLstring_Type *sls; + unsigned int len; +} +Cached_String_Type; +static Cached_String_Type Cached_Strings [NUM_CACHED_STRINGS]; + +#define GET_CACHED_STRING(s) \ + (Cached_Strings + (unsigned int)(((unsigned long) (s)) % NUM_CACHED_STRINGS)) + +_INLINE_ +static void cache_string (SLstring_Type *sls, unsigned int len, unsigned long hash) +{ + Cached_String_Type *cs; + + cs = GET_CACHED_STRING(sls->bytes); + cs->sls = sls; + cs->hash = hash; + cs->len = len; +} + +_INLINE_ +static void uncache_string (char *s) +{ + Cached_String_Type *cs; + + cs = GET_CACHED_STRING(s); + if ((cs->sls != NULL) + && (cs->sls->bytes == s)) + cs->sls = NULL; +} +#endif + + + +_INLINE_ +unsigned long _SLstring_hash (unsigned char *s, unsigned char *smax) +{ + register unsigned long h = 0; + register unsigned long sum = 0; + unsigned char *smax4; + + smax4 = smax - 4; + + while (s < smax4) + { + sum += s[0]; + h = sum + (h << 1); + sum += s[1]; + h = sum + (h << 1); + sum += s[2]; + h = sum + (h << 1); + sum += s[3]; + h = sum + (h << 1); + + s += 4; + } + + while (s < smax) + { + sum += *s++; + h ^= sum + (h << 3); /* slightly different */ + } + + return h; +} + +unsigned long _SLcompute_string_hash (char *s) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + SLstring_Type *sls; + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + return cs->hash; +#endif + return _SLstring_hash ((unsigned char *) s, (unsigned char *) s + strlen (s)); +} + +_INLINE_ +/* This routine works with any (long) string */ +static SLstring_Type *find_string (char *s, unsigned int len, unsigned long hash) +{ + SLstring_Type *sls; + char ch; + + sls = String_Hash_Table [(unsigned int)(hash % SLSTRING_HASH_TABLE_SIZE)]; + + if (sls == NULL) + return NULL; + + ch = s[0]; + do + { + char *bytes = sls->bytes; + + /* Note that we need to actually make sure that bytes[len] == 0. + * In this case, it is not enough to just compare pointers. In fact, + * this is called from create_nstring, etc... It is unlikely that the + * pointer is a slstring + */ + if ((/* (s == bytes) || */ ((ch == bytes[0]) + && (0 == strncmp (s, bytes, len)))) + && (bytes [len] == 0)) + break; + + sls = sls->next; + } + while (sls != NULL); + + return sls; +} + +_INLINE_ +static SLstring_Type *find_slstring (char *s, unsigned long hash) +{ + SLstring_Type *sls; + + sls = String_Hash_Table [(unsigned int)(hash % SLSTRING_HASH_TABLE_SIZE)]; + while (sls != NULL) + { + if (s == sls->bytes) + return sls; + + sls = sls->next; + } + return sls; +} + +_INLINE_ +static SLstring_Type *allocate_sls (unsigned int len) +{ + SLstring_Type *sls; + +#if _SLANG_OPTIMIZE_FOR_SPEED + if ((len < MAX_FREE_STORE_LEN) + && (NULL != (sls = SLS_Free_Store [len]))) + { + SLS_Free_Store[len] = NULL; + return sls; + } +#endif + /* FIXME: use structure padding */ + return (SLstring_Type *) SLmalloc (len + sizeof (SLstring_Type)); +} + +_INLINE_ +static void free_sls (SLstring_Type *sls, unsigned int len) +{ +#if _SLANG_OPTIMIZE_FOR_SPEED + if ((len < MAX_FREE_STORE_LEN) + && (SLS_Free_Store[len] == NULL)) + { + SLS_Free_Store [len] = sls; + return; + } +#else + (void) len; +#endif + SLfree ((char *)sls); +} + +_INLINE_ +static char *create_long_string (char *s, unsigned int len, unsigned long hash) +{ + SLstring_Type *sls; + + sls = find_string (s, len, hash); + + if (sls != NULL) + { + sls->ref_count++; + s = sls->bytes; + +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + return s; + } + + sls = allocate_sls (len); + if (sls == NULL) + return NULL; + + strncpy (sls->bytes, s, len); + sls->bytes[len] = 0; + sls->ref_count = 1; + +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + + hash = hash % SLSTRING_HASH_TABLE_SIZE; + sls->next = String_Hash_Table [(unsigned int)hash]; + String_Hash_Table [(unsigned int)hash] = sls; + + return sls->bytes; +} + +_INLINE_ +static char *create_short_string (char *s, unsigned int len) +{ + char ch; + + /* Note: if len is 0, then it does not matter what *s is. This is + * important for SLang_create_nslstring. + */ + if (len) ch = *s; else ch = 0; + + len = 2 * (unsigned int) ((unsigned char) ch); + Single_Char_Strings [len] = ch; + Single_Char_Strings [len + 1] = 0; + return Single_Char_Strings + len; +} + +/* s cannot be NULL */ +_INLINE_ +static char *create_nstring (char *s, unsigned int len, unsigned long *hash_ptr) +{ + unsigned long hash; + + if (len < 2) + return create_short_string (s, len); + + hash = _SLstring_hash ((unsigned char *) s, (unsigned char *) (s + len)); + *hash_ptr = hash; + + return create_long_string (s, len, hash); +} + +char *SLang_create_nslstring (char *s, unsigned int len) +{ + unsigned long hash; + return create_nstring (s, len, &hash); +} + +char *_SLstring_make_hashed_string (char *s, unsigned int len, unsigned long *hashptr) +{ + unsigned long hash; + + if (s == NULL) return NULL; + + hash = _SLstring_hash ((unsigned char *) s, (unsigned char *) s + len); + *hashptr = hash; + + if (len < 2) + return create_short_string (s, len); + + return create_long_string (s, len, hash); +} + +char *_SLstring_dup_hashed_string (char *s, unsigned long hash) +{ + unsigned int len; +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + SLstring_Type *sls; + + if (s == NULL) return NULL; + if (s[0] == 0) + return create_short_string (s, 0); + if (s[1] == 0) + return create_short_string (s, 1); + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + { + sls->ref_count += 1; + return s; + } +#else + if (s == NULL) return NULL; +#endif + + len = strlen (s); +#if !_SLANG_OPTIMIZE_FOR_SPEED + if (len < 2) return create_short_string (s, len); +#endif + + return create_long_string (s, len, hash); +} + +char *_SLstring_dup_slstring (char *s) +{ + SLstring_Type *sls; + unsigned int len; + unsigned long hash; +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + { + sls->ref_count += 1; + return s; + } +#endif + + if ((s == NULL) || ((len = strlen (s)) < 2)) + return s; + + hash = _SLstring_hash ((unsigned char *)s, (unsigned char *)(s + len)); + + sls = find_slstring (s, hash); + if (sls == NULL) + { + SLang_Error = SL_INTERNAL_ERROR; + return NULL; + } + + sls->ref_count++; +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + return s; +} + +static void free_sls_string (SLstring_Type *sls, char *s, unsigned int len, + unsigned long hash) +{ + SLstring_Type *sls1, *prev; + +#if _SLANG_OPTIMIZE_FOR_SPEED + uncache_string (s); +#endif + + hash = hash % SLSTRING_HASH_TABLE_SIZE; + + sls1 = String_Hash_Table [(unsigned int) hash]; + + prev = NULL; + + /* This should not fail. */ + while (sls1 != sls) + { + prev = sls1; + sls1 = sls1->next; + } + + if (prev != NULL) + prev->next = sls->next; + else + String_Hash_Table [(unsigned int) hash] = sls->next; + + free_sls (sls, len); +} + +_INLINE_ +static void free_long_string (char *s, unsigned int len, unsigned long hash) +{ + SLstring_Type *sls; + + if (NULL == (sls = find_slstring (s, hash))) + { + SLang_doerror ("Application internal error: invalid attempt to free string"); + return; + } + + sls->ref_count--; + if (sls->ref_count != 0) + { +#if _SLANG_OPTIMIZE_FOR_SPEED + /* cache_string (sls, len, hash); */ +#endif + return; + } + + + free_sls_string (sls, s, len, hash); +} + +/* This routine may be passed NULL-- it is not an error. */ +void SLang_free_slstring (char *s) +{ + unsigned long hash; + unsigned int len; +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + SLstring_Type *sls; + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + { + if (sls->ref_count <= 1) + free_sls_string (sls, s, cs->len, cs->hash); + else + sls->ref_count -= 1; + return; + } +#endif + + if (s == NULL) return; + + if ((len = strlen (s)) < 2) + return; + + hash = _SLstring_hash ((unsigned char *)s, (unsigned char *) s + len); + free_long_string (s, len, hash); +} + +char *SLang_create_slstring (char *s) +{ + unsigned long hash; +#if _SLANG_OPTIMIZE_FOR_SPEED + Cached_String_Type *cs; + SLstring_Type *sls; + + cs = GET_CACHED_STRING(s); + if (((sls = cs->sls) != NULL) + && (sls->bytes == s)) + { + sls->ref_count += 1; + return s; + } +#endif + + if (s == NULL) return NULL; + return create_nstring (s, strlen (s), &hash); +} + +void _SLfree_hashed_string (char *s, unsigned int len, unsigned long hash) +{ + if ((s == NULL) || (len < 2)) return; + free_long_string (s, len, hash); +} + + +char *_SLallocate_slstring (unsigned int len) +{ + SLstring_Type *sls = allocate_sls (len); + if (sls == NULL) + return NULL; + + return sls->bytes; +} + +void _SLunallocate_slstring (char *s, unsigned int len) +{ + SLstring_Type *sls; + + if (s == NULL) + return; + + sls = (SLstring_Type *) (s - offsetof(SLstring_Type,bytes[0])); + free_sls (sls, len); +} + +char *_SLcreate_via_alloced_slstring (char *s, unsigned int len) +{ + unsigned long hash; + SLstring_Type *sls; + + if (s == NULL) + return NULL; + + if (len < 2) + { + char *s1 = create_short_string (s, len); + _SLunallocate_slstring (s, len); + return s1; + } + + /* s is not going to be in the cache because when it was malloced, its + * value was unknown. This simplifies the coding. + */ + hash = _SLstring_hash ((unsigned char *)s, (unsigned char *)s + len); + sls = find_string (s, len, hash); + if (sls != NULL) + { + sls->ref_count++; + _SLunallocate_slstring (s, len); + s = sls->bytes; + +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + return s; + } + + sls = (SLstring_Type *) (s - offsetof(SLstring_Type,bytes[0])); + sls->ref_count = 1; + +#if _SLANG_OPTIMIZE_FOR_SPEED + cache_string (sls, len, hash); +#endif + + hash = hash % SLSTRING_HASH_TABLE_SIZE; + sls->next = String_Hash_Table [(unsigned int)hash]; + String_Hash_Table [(unsigned int)hash] = sls; + + return s; +} + +/* Note, a and b may be ordinary strings. The result is an slstring */ +char *SLang_concat_slstrings (char *a, char *b) +{ + unsigned int lena, len; + char *c; + + lena = strlen (a); + len = lena + strlen (b); + + c = _SLallocate_slstring (len); + if (c == NULL) + return NULL; + + strcpy (c, a); + strcpy (c + lena, b); + + return _SLcreate_via_alloced_slstring (c, len); +} + diff --git a/mdk-stage1/slang/slstrops.c b/mdk-stage1/slang/slstrops.c new file mode 100644 index 000000000..a57ef6389 --- /dev/null +++ b/mdk-stage1/slang/slstrops.c @@ -0,0 +1,1686 @@ +/* -*- mode: C; mode: fold; -*- */ +/* string manipulation functions for S-Lang. */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" +/*{{{ Include Files */ + +#include <time.h> + +#ifndef __QNX__ +# if defined(__GO32__) || defined(__WATCOMC__) +# include <dos.h> +# include <bios.h> +# endif +#endif + +#if SLANG_HAS_FLOAT +#include <math.h> +#endif + +#include <string.h> +#include <stdarg.h> +#include <ctype.h> + +#ifndef isdigit +# define isdigit(x) (((x) >= '0') && ((x) <= '9')) +#endif + +#include "slang.h" +#include "_slang.h" + +/*}}}*/ + +#define USE_ALLOC_STSTRING 1 + +/*{{{ Utility Functions */ + +static char Utility_Char_Table [256]; +static unsigned char WhiteSpace_Lut[256]; + +static void set_utility_char_table (char *pos) /*{{{*/ +{ + register char *t = Utility_Char_Table, *tmax; + register unsigned char ch; + + tmax = t + 256; + while (t < tmax) *t++ = 0; + + t = Utility_Char_Table; + while ((ch = (unsigned char) *pos++) != 0) t[ch] = 1; +} + +/*}}}*/ + +_INLINE_ +static unsigned char *make_whitespace_lut (void) +{ + if (WhiteSpace_Lut[' '] != 1) + { + WhiteSpace_Lut[' '] = WhiteSpace_Lut['\r'] + = WhiteSpace_Lut ['\n'] = WhiteSpace_Lut['\t'] + = WhiteSpace_Lut ['\f'] = 1; + } + return WhiteSpace_Lut; +} + +static unsigned char *make_lut (unsigned char *s, unsigned char *lut) +{ + int reverse = 0; + + if (*s == '^') + { + reverse = 1; + s++; + } + SLmake_lut (lut, s, reverse); + return lut; +} + +static unsigned int do_trim (char **beg, int do_beg, + char **end, int do_end, + char *white) /*{{{*/ +{ + unsigned int len; + char *a, *b; + + set_utility_char_table (white); + + a = *beg; + len = strlen (a); + b = a + len; + + if (do_beg) + while (Utility_Char_Table[(unsigned char) *a]) a++; + + if (do_end) + { + b--; + while ((b >= a) && (Utility_Char_Table[(unsigned char) *b])) b--; + b++; + } + + len = (unsigned int) (b - a); + *beg = a; + *end = b; + return len; +} + +/*}}}*/ + +/*}}}*/ + +static int pop_3_strings (char **a, char **b, char **c) +{ + *a = *b = *c = NULL; + if (-1 == SLpop_string (c)) + return -1; + + if (-1 == SLpop_string (b)) + { + SLfree (*c); + *c = NULL; + return -1; + } + + if (-1 == SLpop_string (a)) + { + SLfree (*b); + SLfree (*c); + *b = *c = NULL; + return -1; + } + + return 0; +} + +static void free_3_strings (char *a, char *b, char *c) +{ + SLfree (a); + SLfree (b); + SLfree (c); +} + +static void strcat_cmd (void) /*{{{*/ +{ + char *c, *c1; + int nargs; + int i; + char **ptrs; + unsigned int len; +#if !USE_ALLOC_STSTRING + char buf[256]; +#endif + nargs = SLang_Num_Function_Args; + if (nargs <= 0) nargs = 2; + + if (NULL == (ptrs = (char **)SLmalloc (nargs * sizeof (char *)))) + return; + + memset ((char *) ptrs, 0, sizeof (char *) * nargs); + + c = NULL; + i = nargs; + len = 0; + while (i != 0) + { + char *s; + + i--; + if (-1 == SLang_pop_slstring (&s)) + goto free_and_return; + ptrs[i] = s; + len += strlen (s); + } +#if USE_ALLOC_STSTRING + if (NULL == (c = _SLallocate_slstring (len))) + goto free_and_return; +#else + len++; /* \0 char */ + if (len <= sizeof (buf)) + c = buf; + else if (NULL == (c = SLmalloc (len))) + goto free_and_return; +#endif + + c1 = c; + for (i = 0; i < nargs; i++) + { + strcpy (c1, ptrs[i]); + c1 += strlen (c1); + } + + free_and_return: + for (i = 0; i < nargs; i++) + SLang_free_slstring (ptrs[i]); + SLfree ((char *) ptrs); + +#if USE_ALLOC_STSTRING + (void) _SLpush_alloced_slstring (c, len); +#else + if (c != buf) + (void) SLang_push_malloced_string (c); /* NULL ok */ + else + (void) SLang_push_string (c); +#endif +} + +/*}}}*/ + +static int _SLang_push_nstring (char *a, unsigned int len) +{ + a = SLang_create_nslstring (a, len); + if (a == NULL) + return -1; + + return _SLang_push_slstring (a); +} + + +static void strtrim_cmd_internal (char *str, int do_beg, int do_end) +{ + char *beg, *end, *white; + int free_str; + unsigned int len; + + /* Go through SLpop_string to get a private copy since it will be + * modified. + */ + + free_str = 0; + if (SLang_Num_Function_Args == 2) + { + white = str; + if (-1 == SLang_pop_slstring (&str)) + return; + free_str = 1; + } + else white = " \t\f\r\n"; + + beg = str; + len = do_trim (&beg, do_beg, &end, do_end, white); + + (void) _SLang_push_nstring (beg, len); + if (free_str) + SLang_free_slstring (str); +} + + +static void strtrim_cmd (char *str) +{ + strtrim_cmd_internal (str, 1, 1); +} + +static void strtrim_beg_cmd (char *str) +{ + strtrim_cmd_internal (str, 1, 0); +} + +static void strtrim_end_cmd (char *str) +{ + strtrim_cmd_internal (str, 0, 1); +} + + +static void strcompress_cmd (void) /*{{{*/ +{ + char *str, *white, *c; + unsigned char *s, *beg, *end; + unsigned int len; + char pref_char; + + if (SLpop_string (&white)) return; + if (SLpop_string (&str)) + { + SLfree (white); + return; + } + + /* The first character of white is the preferred whitespace character */ + pref_char = *white; + + beg = (unsigned char *) str; + (void) do_trim ((char **) &beg, 1, (char **) &end, 1, white); + SLfree (white); + + /* Determine the effective length */ + len = 0; + s = (unsigned char *) beg; + while (s < end) + { + len++; + if (Utility_Char_Table[*s++]) + { + while ((s < end) && Utility_Char_Table[*s]) s++; + } + } + +#if USE_ALLOC_STSTRING + c = _SLallocate_slstring (len); +#else + c = SLmalloc (len + 1); +#endif + if (c == NULL) + { + SLfree (str); + return; + } + + s = (unsigned char *) c; + + while (beg < end) + { + unsigned char ch = *beg++; + + if (0 == Utility_Char_Table[ch]) + { + *s++ = ch; + continue; + } + + *s++ = (unsigned char) pref_char; + + while ((beg < end) && Utility_Char_Table[*beg]) + beg++; + } + + *s = 0; + +#if USE_ALLOC_STSTRING + (void) _SLpush_alloced_slstring (c, len); +#else + SLang_push_malloced_string(c); +#endif + + SLfree(str); +} + +/*}}}*/ + +static int str_replace_cmd_1 (char *orig, char *match, char *rep, unsigned int max_num_replaces, + char **new_strp) /*{{{*/ +{ + char *s, *t, *new_str; + unsigned int rep_len, match_len, new_len; + unsigned int num_replaces; + + *new_strp = NULL; + + match_len = strlen (match); + + if (match_len == 0) + return 0; + + num_replaces = 0; + s = orig; + while (num_replaces < max_num_replaces) + { + s = strstr (s, match); + if (s == NULL) + break; + s += match_len; + num_replaces++; + } + + if (num_replaces == 0) + return 0; + + max_num_replaces = num_replaces; + + rep_len = strlen (rep); + + new_len = (strlen (orig) - num_replaces * match_len) + num_replaces * rep_len; + new_str = SLmalloc (new_len + 1); + if (new_str == NULL) + return -1; + + s = orig; + t = new_str; + + for (num_replaces = 0; num_replaces < max_num_replaces; num_replaces++) + { + char *next_s; + unsigned int len; + + next_s = strstr (s, match); /* cannot be NULL */ + len = (unsigned int) (next_s - s); + strncpy (t, s, len); + t += len; + strcpy (t, rep); + t += rep_len; + + s = next_s + match_len; + } + strcpy (t, s); + *new_strp = new_str; + + return (int) num_replaces; +} + +/*}}}*/ + +static void reverse_string (char *a) +{ + char *b; + + b = a + strlen (a); + while (b > a) + { + char ch; + + b--; + ch = *a; + *a++ = *b; + *b = ch; + } +} + +static int strreplace_cmd (int *np) +{ + char *orig, *match, *rep; + char *new_str; + int max_num_replaces; + int ret; + + max_num_replaces = *np; + + if (-1 == pop_3_strings (&orig, &match, &rep)) + return -1; + + if (max_num_replaces < 0) + { + reverse_string (orig); + reverse_string (match); + reverse_string (rep); + ret = str_replace_cmd_1 (orig, match, rep, -max_num_replaces, &new_str); + if (ret > 0) reverse_string (new_str); + else if (ret == 0) + reverse_string (orig); + } + else ret = str_replace_cmd_1 (orig, match, rep, max_num_replaces, &new_str); + + if (ret == 0) + { + if (-1 == SLang_push_malloced_string (orig)) + ret = -1; + orig = NULL; + } + else if (ret > 0) + { + if (-1 == SLang_push_malloced_string (new_str)) + ret = -1; + } + + free_3_strings (orig, match, rep); + return ret; +} + +static int str_replace_cmd (char *orig, char *match, char *rep) +{ + char *s; + int ret; + + ret = str_replace_cmd_1 (orig, match, rep, 1, &s); + if (ret == 1) + (void) SLang_push_malloced_string (s); + return ret; +} + + + +static void strtok_cmd (char *str) +{ + _SLString_List_Type sl; + unsigned char white_buf[256]; + char *s; + unsigned char *white; + + if (SLang_Num_Function_Args == 1) + white = make_whitespace_lut (); + else + { + white = white_buf; + make_lut ((unsigned char *)str, white); + if (-1 == SLang_pop_slstring (&str)) + return; + } + + if (-1 == _SLstring_list_init (&sl, 256, 1024)) + goto the_return; + + s = str; + while (*s != 0) + { + char *s0; + + s0 = s; + /* Skip whitespace */ + while ((*s0 != 0) && (0 != white[(unsigned char)*s0])) + s0++; + + if (*s0 == 0) + break; + + s = s0; + while ((*s != 0) && (0 == white[(unsigned char) *s])) + s++; + + /* sl deleted upon failure */ + if (-1 == _SLstring_list_append (&sl, SLang_create_nslstring (s0, (unsigned int) (s - s0)))) + goto the_return; + } + + /* Deletes sl */ + (void) _SLstring_list_push (&sl); + + the_return: + if (white == white_buf) + SLang_free_slstring (str); +} + +/* This routine returns the string with text removed between single character + comment delimiters from the set b and e. */ + +static void str_uncomment_string_cmd (char *str, char *b, char *e) /*{{{*/ +{ + unsigned char chb, che; + unsigned char *s, *cbeg, *mark; + + if (strlen(b) != strlen(e)) + { + SLang_doerror ("Comment delimiter length mismatch."); + return; + } + + set_utility_char_table (b); + + if (NULL == (str = (char *) SLmake_string(str))) return; + + s = (unsigned char *) str; + + while ((chb = *s++) != 0) + { + if (Utility_Char_Table [chb] == 0) continue; + + mark = s - 1; + + cbeg = (unsigned char *) b; + while (*cbeg != chb) cbeg++; + + che = (unsigned char) *(e + (int) (cbeg - (unsigned char *) b)); + + while (((chb = *s++) != 0) && (chb != che)); + + if (chb == 0) + { + /* end of string and end not found. Just truncate it a return; */ + *mark = 0; + break; + } + + strcpy ((char *) mark, (char *)s); + s = mark; + } + SLang_push_malloced_string (str); +} + +/*}}}*/ + +static void str_quote_string_cmd (char *str, char *quotes, int *slash_ptr) /*{{{*/ +{ + char *q; + int slash; + unsigned int len; + register char *t, *s, *q1; + register unsigned char ch; + + slash = *slash_ptr; + + if ((slash > 255) || (slash < 0)) + { + SLang_Error = SL_INVALID_PARM; + return; + } + + /* setup the utility table to have 1s at quote char postitions. */ + set_utility_char_table (quotes); + + t = Utility_Char_Table; + t[(unsigned int) slash] = 1; + + /* calculate length */ + s = str; + len = 0; + while ((ch = (unsigned char) *s++) != 0) if (t[ch]) len++; + len += (unsigned int) (s - str); + + if (NULL != (q = SLmalloc(len))) + { + s = str; q1 = q; + while ((ch = (unsigned char) *s++) != 0) + { + if (t[ch]) *q1++ = slash; + *q1++ = (char) ch; + } + *q1 = 0; + SLang_push_malloced_string(q); + } +} + +/*}}}*/ + +/* returns the position of substrin in a string or null */ +static int issubstr_cmd (char *a, char *b) /*{{{*/ +{ + char *c; + + if (NULL == (c = (char *) strstr(a, b))) + return 0; + + return 1 + (int) (c - a); +} + +/*}}}*/ + +/* returns to stack string at pos n to n + m of a */ +static void substr_cmd (char *a, int *n_ptr, int *m_ptr) /*{{{*/ +{ + int n, m; + int lena; + + n = *n_ptr; + m = *m_ptr; + + lena = strlen (a); + if (n > lena) n = lena + 1; + if (n < 1) + { + SLang_Error = SL_INVALID_PARM; + return; + } + + n--; + if (m < 0) m = lena; + if (n + m > lena) m = lena - n; + + (void) _SLang_push_nstring (a + n, (unsigned int) m); +} + +/*}}}*/ + +/* substitute char m at positin string n in string*/ +static void strsub_cmd (int *nptr, int *mptr) /*{{{*/ +{ + char *a; + int n, m; + unsigned int lena; + + if (-1 == SLpop_string (&a)) + return; + + n = *nptr; + m = *mptr; + + lena = strlen (a); + + if ((n <= 0) || (lena < (unsigned int) n)) + { + SLang_Error = SL_INVALID_PARM; + SLfree(a); + return; + } + + a[n - 1] = (char) m; + + SLang_push_malloced_string (a); +} + +/*}}}*/ + +static void strup_cmd(void) /*{{{*/ +{ + unsigned char c, *a; + char *str; + + if (SLpop_string (&str)) + return; + + a = (unsigned char *) str; + while ((c = *a) != 0) + { + /* if ((*a >= 'a') && (*a <= 'z')) *a -= 32; */ + *a = UPPER_CASE(c); + a++; + } + + SLang_push_malloced_string (str); +} + +/*}}}*/ + +static int isdigit_cmd (char *what) /*{{{*/ +{ + return isdigit((unsigned char)*what); +} + +/*}}}*/ +static int toupper_cmd (int *ch) /*{{{*/ +{ + return UPPER_CASE(*ch); +} + +/*}}}*/ + +static int tolower_cmd (int *ch) /*{{{*/ +{ + return LOWER_CASE(*ch); +} + +/*}}}*/ + +static void strlow_cmd (void) /*{{{*/ +{ + unsigned char c, *a; + char *str; + + if (SLpop_string(&str)) return; + a = (unsigned char *) str; + while ((c = *a) != 0) + { + /* if ((*a >= 'a') && (*a <= 'z')) *a -= 32; */ + *a = LOWER_CASE(c); + a++; + } + + SLang_push_malloced_string ((char *) str); +} + +/*}}}*/ + +static SLang_Array_Type *do_strchop (char *str, int delim, int quote) +{ + int count; + char *s0, *elm; + register char *s1; + register unsigned char ch; + int quoted; + SLang_Array_Type *at; + char **data; + + if ((quote < 0) || (quote > 255) + || (delim <= 0) || (delim > 255)) + { + SLang_Error = SL_INVALID_PARM; + return NULL; + } + + s1 = s0 = str; + + quoted = 0; + count = 1; /* at least 1 */ + while (1) + { + ch = (unsigned char) *s1++; + if ((ch == quote) && quote) + { + if (*s1 == 0) + break; + + s1++; + continue; + } + + if (ch == delim) + { + count++; + continue; + } + + if (ch == 0) + break; + } + + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &count, 1))) + return NULL; + + data = (char **)at->data; + + count = 0; + s1 = s0; + + while (1) + { + ch = (unsigned char) *s1; + + if ((ch == quote) && quote) + { + s1++; + if (*s1 != 0) s1++; + quoted = 1; + continue; + } + + if ((ch == delim) || (ch == 0)) + { + if (quoted == 0) + elm = SLang_create_nslstring (s0, (unsigned int) (s1 - s0)); + else + { + register char ch1, *p, *p1; + char *tmp; + + tmp = SLmake_nstring (s0, (unsigned int)(s1 - s0)); + if (tmp == NULL) + break; + + /* Now unquote it */ + p = p1 = tmp; + do + { + ch1 = *p1++; + if (ch1 == '\\') ch1 = *p1++; + *p++ = ch1; + } + while (ch1 != 0); + quoted = 0; + + elm = SLang_create_slstring (tmp); + SLfree (tmp); + } + + if (elm == NULL) + break; + + data[count] = elm; + count++; + + if (ch == 0) + return at; + + s1++; /* skip past delim */ + s0 = s1; /* and reset */ + } + else s1++; + } + + SLang_free_array (at); + return NULL; +} + +static void strchop_cmd (char *str, int *q, int *d) +{ + (void) SLang_push_array (do_strchop (str, *q, *d), 1); +} + +static void strchopr_cmd (char *str, int *q, int *d) +{ + SLang_Array_Type *at; + + if (NULL != (at = do_strchop (str, *q, *d))) + { + char **d0, **d1; + + d0 = (char **) at->data; + d1 = d0 + (at->num_elements - 1); + + while (d0 < d1) + { + char *tmp; + + tmp = *d0; + *d0 = *d1; + *d1 = tmp; + d0++; + d1--; + } + } + SLang_push_array (at, 1); +} + +static int strcmp_cmd (char *a, char *b) /*{{{*/ +{ + return strcmp(a, b); +} + +/*}}}*/ + +static int strncmp_cmd (char *a, char *b, int *n) /*{{{*/ +{ + return strncmp(a, b, (unsigned int) *n); +} + +/*}}}*/ + +static int strlen_cmd (char *s) /*{{{*/ +{ + return (int) strlen (s); +} +/*}}}*/ + +static void extract_element_cmd (char *list, int *nth_ptr, int *delim_ptr) +{ + char buf[1024], *b; + + b = buf; + if (-1 == SLextract_list_element (list, *nth_ptr, *delim_ptr, buf, sizeof(buf))) + b = NULL; + + SLang_push_string (b); +} + +/* sprintf functionality for S-Lang */ + +static char *SLdo_sprintf (char *fmt) /*{{{*/ +{ + register char *p = fmt, ch; + char *out = NULL, *outp = NULL; + char dfmt[1024]; /* used to hold part of format */ + char *f; + VOID_STAR varp; + int want_width, width, precis, use_varp, int_var; + long long_var; + unsigned int len = 0, malloc_len = 0, dlen; + int do_free, guess_size; +#if SLANG_HAS_FLOAT + int tmp1, tmp2, use_double; + double x; +#endif + int use_long = 0; + + while (1) + { + while ((ch = *p) != 0) + { + if (ch == '%') + break; + p++; + } + + /* p points at '%' or 0 */ + + dlen = (unsigned int) (p - fmt); + + if (len + dlen >= malloc_len) + { + malloc_len = len + dlen; + if (out == NULL) outp = SLmalloc(malloc_len + 1); + else outp = SLrealloc(out, malloc_len + 1); + if (NULL == outp) + return out; + out = outp; + outp = out + len; + } + + strncpy(outp, fmt, dlen); + len += dlen; + outp = out + len; + *outp = 0; + if (ch == 0) break; + + /* bump it beyond '%' */ + ++p; + fmt = p; + + f = dfmt; + *f++ = ch; + /* handle flag char */ + ch = *p++; + + /* Make sure cases such as "% #g" can be handled. */ + if ((ch == '-') || (ch == '+') || (ch == ' ') || (ch == '#')) + { + *f++ = ch; + ch = *p++; + if ((ch == '-') || (ch == '+') || (ch == ' ') || (ch == '#')) + { + *f++ = ch; + ch = *p++; + } + } + + + /* width */ + /* I have got to parse it myself so that I can see how big it needs + * to be. + */ + want_width = width = 0; + if (ch == '*') + { + if (SLang_pop_integer(&width)) return (out); + want_width = 1; + ch = *p++; + } + else + { + if (ch == '0') + { + *f++ = '0'; + ch = *p++; + } + + while ((ch <= '9') && (ch >= '0')) + { + width = width * 10 + (ch - '0'); + ch = *p++; + want_width = 1; + } + } + + if (want_width) + { + sprintf(f, "%d", width); + f += strlen (f); + } + precis = 0; + /* precision -- also indicates max number of chars from string */ + if (ch == '.') + { + *f++ = ch; + ch = *p++; + want_width = 0; + if (ch == '*') + { + if (SLang_pop_integer(&precis)) return (out); + ch = *p++; + want_width = 1; + } + else while ((ch <= '9') && (ch >= '0')) + { + precis = precis * 10 + (ch - '0'); + ch = *p++; + want_width = 1; + } + if (want_width) + { + sprintf(f, "%d", precis); + f += strlen (f); + } + else precis = 0; + } + + long_var = 0; + int_var = 0; + varp = NULL; + guess_size = 32; +#if SLANG_HAS_FLOAT + use_double = 0; +#endif + use_long = 0; + use_varp = 0; + do_free = 0; + + if (ch == 'l') + { + use_long = 1; + ch = *p++; + } + else if (ch == 'h') ch = *p++; /* not supported */ + + /* Now the actual format specifier */ + switch (ch) + { + case 'S': + _SLstring_intrinsic (); + ch = 's'; + /* drop */ + case 's': + if (SLang_pop_slstring((char **) &varp)) return (out); + do_free = 1; + guess_size = strlen((char *) varp); + use_varp = 1; + break; + + case '%': + guess_size = 1; + do_free = 0; + use_varp = 1; + varp = (VOID_STAR) "%"; + break; + + case 'c': guess_size = 1; + use_long = 0; + /* drop */ + case 'd': + case 'i': + case 'o': + case 'u': + case 'X': + case 'x': + if (SLang_pop_long (&long_var)) return(out); + if (use_long == 0) + int_var = (int) long_var; + else + *f++ = 'l'; + break; + + case 'f': + case 'e': + case 'g': + case 'E': + case 'G': +#if SLANG_HAS_FLOAT + if (SLang_pop_double(&x, &tmp1, &tmp2)) return (out); + use_double = 1; + guess_size = 256; + (void) tmp1; (void) tmp2; + use_long = 0; + break; +#endif + case 'p': + guess_size = 32; + /* Pointer type?? Why?? */ + if (-1 == SLdo_pop ()) + return out; + varp = (VOID_STAR) _SLStack_Pointer; + use_varp = 1; + use_long = 0; + break; + + default: + SLang_doerror("Invalid Format."); + return(out); + } + *f++ = ch; *f = 0; + + width = width + precis; + if (width > guess_size) guess_size = width; + + if (len + guess_size > malloc_len) + { + outp = (char *) SLrealloc(out, len + guess_size + 1); + if (outp == NULL) + { + SLang_Error = SL_MALLOC_ERROR; + return (out); + } + out = outp; + outp = out + len; + malloc_len = len + guess_size; + } + + if (use_varp) + { + sprintf(outp, dfmt, varp); + if (do_free) SLang_free_slstring ((char *)varp); + } +#if SLANG_HAS_FLOAT + else if (use_double) sprintf(outp, dfmt, x); +#endif + else if (use_long) sprintf (outp, dfmt, long_var); + else sprintf(outp, dfmt, int_var); + + len += strlen(outp); + outp = out + len; + fmt = p; + } + + if (out != NULL) + { + outp = SLrealloc (out, (unsigned int) (outp - out) + 1); + if (outp != NULL) out = outp; + } + + return (out); +} + +/*}}}*/ + +int _SLstrops_do_sprintf_n (int n) /*{{{*/ +{ + char *p; + char *fmt; + SLang_Object_Type *ptr; + int ofs; + + if (-1 == (ofs = SLreverse_stack (n + 1))) + return -1; + + ptr = _SLRun_Stack + ofs; + + if (SLang_pop_slstring(&fmt)) + return -1; + + p = SLdo_sprintf (fmt); + SLang_free_slstring (fmt); + + while (_SLStack_Pointer > ptr) + SLdo_pop (); + + if (SLang_Error) + { + SLfree (p); + return -1; + } + + return SLang_push_malloced_string (p); +} + +/*}}}*/ + +static void sprintf_n_cmd (int *n) +{ + _SLstrops_do_sprintf_n (*n); +} + +static void sprintf_cmd (void) +{ + _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 1); /* do not include format */ +} + +/* converts string s to a form that can be used in an eval */ +static void make_printable_string(char *s) /*{{{*/ +{ + unsigned int len; + register char *s1 = s, ch, *ss1; + char *ss; + + /* compute length */ + len = 3; + while ((ch = *s1++) != 0) + { + if ((ch == '\n') || (ch == '\\') || (ch == '"')) len++; + len++; + } + + if (NULL == (ss = SLmalloc(len))) + return; + + s1 = s; + ss1 = ss; + *ss1++ = '"'; + while ((ch = *s1++) != 0) + { + if (ch == '\n') + { + ch = 'n'; + *ss1++ = '\\'; + } + else if ((ch == '\\') || (ch == '"')) + { + *ss1++ = '\\'; + } + *ss1++ = ch; + } + *ss1++ = '"'; + *ss1 = 0; + if (-1 == SLang_push_string (ss)) + SLfree (ss); +} + +/*}}}*/ + +static int is_list_element_cmd (char *list, char *elem, int *d_ptr) +{ + char ch; + int d, n; + unsigned int len; + char *lbeg, *lend; + + d = *d_ptr; + + len = strlen (elem); + + n = 1; + lend = list; + + while (1) + { + lbeg = lend; + while ((0 != (ch = *lend)) && (ch != (char) d)) lend++; + + if ((lbeg + len == lend) + && (0 == strncmp (elem, lbeg, len))) + break; + + if (ch == 0) + { + n = 0; + break; + } + lend++; /* skip delim */ + n++; + } + + return n; +} + +/*}}}*/ + +/* Regular expression routines for strings */ +static SLRegexp_Type regexp_reg; + +static int string_match_cmd (char *str, char *pat, int *nptr) /*{{{*/ +{ + int n; + unsigned int len; + unsigned char rbuf[512], *match; + + n = *nptr; + + regexp_reg.case_sensitive = 1; + regexp_reg.buf = rbuf; + regexp_reg.pat = (unsigned char *) pat; + regexp_reg.buf_len = sizeof (rbuf); + + if (SLang_regexp_compile (®exp_reg)) + { + SLang_verror (SL_INVALID_PARM, "Unable to compile pattern"); + return -1; + } + + n--; + len = strlen(str); + if ((n < 0) || ((unsigned int) n >= len)) + { + /* SLang_Error = SL_INVALID_PARM; */ + return 0; + } + + str += n; + len -= n; + + if (NULL == (match = SLang_regexp_match((unsigned char *) str, len, ®exp_reg))) + return 0; + + /* adjust offsets */ + regexp_reg.offset = n; + + return (1 + (int) ((char *) match - str)); +} + +/*}}}*/ + +static int string_match_nth_cmd (int *nptr) /*{{{*/ +{ + int n, beg; + + n = *nptr; + + if ((n < 0) || (n > 9) || (regexp_reg.pat == NULL) + || ((beg = regexp_reg.beg_matches[n]) == -1)) + { + SLang_Error = SL_INVALID_PARM; + return -1; + } + SLang_push_integer(beg + regexp_reg.offset); + return regexp_reg.end_matches[n]; +} + +/*}}}*/ + +static char *create_delimited_string (char **list, unsigned int n, + char *delim) +{ + unsigned int len, dlen; + unsigned int i; + unsigned int num; + char *str, *s; + + len = 1; /* allow room for \0 char */ + num = 0; + for (i = 0; i < n; i++) + { + if (list[i] == NULL) continue; + len += strlen (list[i]); + num++; + } + + dlen = strlen (delim); + if (num > 1) + len += (num - 1) * dlen; + + if (NULL == (str = SLmalloc (len))) + return NULL; + + *str = 0; + s = str; + i = 0; + + while (num > 1) + { + while (list[i] == NULL) + i++; + + strcpy (s, list[i]); + s += strlen (list[i]); + strcpy (s, delim); + s += dlen; + i++; + num--; + } + + if (num) + { + while (list[i] == NULL) + i++; + + strcpy (s, list[i]); + } + + return str; +} + +static void create_delimited_string_cmd (int *nptr) +{ + unsigned int n, i; + char **strings; + char *str; + + str = NULL; + + n = 1 + (unsigned int) *nptr; /* n includes delimiter */ + + if (NULL == (strings = (char **)SLmalloc (n * sizeof (char *)))) + { + SLdo_pop_n (n); + return; + } + memset((char *)strings, 0, n * sizeof (char *)); + + i = n; + while (i != 0) + { + i--; + if (-1 == SLang_pop_slstring (strings + i)) + goto return_error; + } + + str = create_delimited_string (strings + 1, (n - 1), strings[0]); + /* drop */ + return_error: + for (i = 0; i < n; i++) SLang_free_slstring (strings[i]); + SLfree ((char *)strings); + + (void) SLang_push_malloced_string (str); /* NULL Ok */ +} + +static void strjoin_cmd (char *delim) +{ + SLang_Array_Type *at; + char *str; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE)) + return; + + str = create_delimited_string ((char **)at->data, at->num_elements, delim); + SLang_free_array (at); + (void) SLang_push_malloced_string (str); /* NULL Ok */ +} + +static void str_delete_chars_cmd (char *s, char *d) +{ + unsigned char lut[256]; + unsigned char *s1, *s2; + unsigned char ch; + + make_lut ((unsigned char *)d, lut); + if (NULL == (s = SLmake_string (s))) + return; + + s1 = s2 = (unsigned char *) s; + while ((ch = *s2++) != 0) + { + if (0 == lut[ch]) + *s1++ = ch; + } + *s1 = 0; + + (void) SLang_push_malloced_string (s); +} + +static unsigned char *make_lut_string (unsigned char *s) +{ + unsigned char lut[256]; + unsigned char *l; + unsigned int i; + + /* Complement-- a natural order is imposed */ + make_lut (s, lut); + l = lut; + for (i = 1; i < 256; i++) + { + if (lut[i]) + *l++ = (unsigned char) i; + } + *l = 0; + return (unsigned char *) SLmake_string ((char *)lut); +} + +static unsigned char *make_str_range (unsigned char *s) +{ + unsigned char *s1, *range; + unsigned int num; + unsigned char ch; + int len; + + if (*s == '^') + return make_lut_string (s); + + num = 0; + s1 = s; + while ((ch = *s1++) != 0) + { + unsigned char ch1; + + ch1 = *s1; + if (ch1 == '-') + { + s1++; + ch1 = *s1; + len = (int)ch1 - (int)ch; + if (len < 0) + len = -len; + + num += (unsigned int) len; + if (ch1 != 0) + s1++; + } + + num++; + } + + range = (unsigned char *)SLmalloc (num + 1); + if (range == NULL) + return NULL; + + s1 = s; + s = range; + while ((ch = *s1++) != 0) + { + unsigned char ch1; + unsigned int i; + + ch1 = *s1; + if (ch1 != '-') + { + *s++ = ch; + continue; + } + + s1++; + ch1 = *s1; + + if (ch > ch1) + { + if (ch1 == 0) + ch1 = 1; + + for (i = (unsigned int) ch; i >= (unsigned int) ch1; i--) + *s++ = (unsigned char) i; + + if (*s1 == 0) + break; + } + else + { + for (i = (unsigned int) ch; i <= (unsigned int) ch1; i++) + *s++ = (unsigned char) i; + } + s1++; + } + +#if 0 + if (range + num != s) + SLang_verror (SL_INTERNAL_ERROR, "make_str_range: num wrong"); +#endif + *s = 0; + + return range; +} + +static void strtrans_cmd (char *s, unsigned char *from, unsigned char *to) +{ + unsigned char map[256]; + char *s1; + unsigned int i; + unsigned char ch; + unsigned char last_to; + unsigned char *from_range, *to_range; + + for (i = 0; i < 256; i++) map[i] = (unsigned char) i; + + if (*to == 0) + { + str_delete_chars_cmd (s, (char *)from); + return; + } + + from_range = make_str_range (from); + if (from_range == NULL) + return; + to_range = make_str_range (to); + if (to_range == NULL) + { + SLfree ((char *)from_range); + return; + } + + from = from_range; + to = to_range; + + last_to = 0; + while ((ch = *from++) != 0) + { + unsigned char to_ch; + + if (0 == (to_ch = *to++)) + { + do + { + map[ch] = last_to; + } + while (0 != (ch = *from++)); + break; + } + + last_to = map[ch] = to_ch; + } + + SLfree ((char *)from_range); + SLfree ((char *)to_range); + + s = SLmake_string (s); + if (s == NULL) + return; + + s1 = s; + while ((ch = (unsigned char) *s1) != 0) + *s1++ = (char) map[ch]; + + (void) SLang_push_malloced_string (s); +} + + +static SLang_Intrin_Fun_Type Strops_Table [] = /*{{{*/ +{ + MAKE_INTRINSIC_I("create_delimited_string", create_delimited_string_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SS("strcmp", strcmp_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SSI("strncmp", strncmp_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("strcat", strcat_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strlen", strlen_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SII("strchop", strchop_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SII("strchopr", strchopr_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("strreplace", strreplace_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SSS("str_replace", str_replace_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SII("substr", substr_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SS("is_substr", issubstr_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_II("strsub", strsub_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SII("extract_element", extract_element_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SSI("is_list_element", is_list_element_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_SSI("string_match", string_match_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("string_match_nth", string_match_nth_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("strlow", strlow_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("tolower", tolower_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_I("toupper", toupper_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_0("strup", strup_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("isdigit", isdigit_cmd, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("strtrim", strtrim_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strtrim_end", strtrim_end_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strtrim_beg", strtrim_beg_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("strcompress", strcompress_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_I("Sprintf", sprintf_n_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("sprintf", sprintf_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("sscanf", _SLang_sscanf, SLANG_INT_TYPE), + MAKE_INTRINSIC_S("make_printable_string", make_printable_string, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SSI("str_quote_string", str_quote_string_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SSS("str_uncomment_string", str_uncomment_string_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_II("define_case", SLang_define_case, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strtok", strtok_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_S("strjoin", strjoin_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SSS("strtrans", strtrans_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_SS("str_delete_chars", str_delete_chars_cmd, SLANG_VOID_TYPE), + + SLANG_END_INTRIN_FUN_TABLE +}; + +/*}}}*/ + +int _SLang_init_slstrops (void) +{ + return SLadd_intrin_fun_table (Strops_Table, NULL); +} diff --git a/mdk-stage1/slang/slstruct.c b/mdk-stage1/slang/slstruct.c new file mode 100644 index 000000000..33d182373 --- /dev/null +++ b/mdk-stage1/slang/slstruct.c @@ -0,0 +1,932 @@ +/* Structure type implementation */ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#define SL_APP_WANTS_FOREACH +#include "slang.h" +#include "_slang.h" + +void _SLstruct_delete_struct (_SLang_Struct_Type *s) +{ + _SLstruct_Field_Type *field, *field_max; + + if (s == NULL) return; + + if (s->num_refs > 1) + { + s->num_refs -= 1; + return; + } + + field = s->fields; + if (field != NULL) + { + field_max = field + s->nfields; + + while (field < field_max) + { + SLang_free_object (&field->obj); + SLang_free_slstring (field->name); /* could be NULL */ + field++; + } + SLfree ((char *) s->fields); + } + SLfree ((char *) s); +} + +static _SLang_Struct_Type *allocate_struct (unsigned int nfields) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + unsigned int i, size; + + s = (_SLang_Struct_Type *) SLmalloc (sizeof (_SLang_Struct_Type)); + if (s == NULL) return NULL; + + SLMEMSET((char *) s, 0, sizeof (_SLang_Struct_Type)); + + size = nfields * sizeof(_SLstruct_Field_Type); + if (NULL == (f = (_SLstruct_Field_Type *) SLmalloc (size))) + { + SLfree ((char *) s); + return NULL; + } + SLMEMSET ((char *) f, 0, size); + s->nfields = nfields; + s->fields = f; + + /* By default, all structs will be created with elements set to NULL. I + * do not know whether or not it is better to use SLANG_UNDEFINED_TYPE. + */ + for (i = 0; i < nfields; i++) + f[i].obj.data_type = SLANG_NULL_TYPE; + + return s; +} + +static int push_struct_of_type (unsigned char type, _SLang_Struct_Type *s) +{ + SLang_Object_Type obj; + + obj.data_type = type; + obj.v.struct_val = s; + s->num_refs += 1; + + if (0 == SLang_push (&obj)) + return 0; + + s->num_refs -= 1; + return -1; +} + +int _SLang_push_struct (_SLang_Struct_Type *s) +{ + return push_struct_of_type (SLANG_STRUCT_TYPE, s); +} + +int _SLang_pop_struct (_SLang_Struct_Type **sp) +{ + SLang_Object_Type obj; + SLang_Class_Type *cl; + unsigned char type; + + if (0 != SLang_pop (&obj)) + return -1; + + type = obj.data_type; + if (type != SLANG_STRUCT_TYPE) + { + cl = _SLclass_get_class (type); + if (cl->cl_struct_def == NULL) + { + *sp = NULL; + SLang_free_object (&obj); + SLang_verror (SL_TYPE_MISMATCH, + "Expecting struct type object. Found %s", + cl->cl_name); + return -1; + } + } + + *sp = obj.v.struct_val; + return 0; +} + +static void struct_destroy (unsigned char type, VOID_STAR vs) +{ + (void) type; + _SLstruct_delete_struct (*(_SLang_Struct_Type **) vs); +} + +static int struct_push (unsigned char type, VOID_STAR ptr) +{ + return push_struct_of_type (type, *(_SLang_Struct_Type **) ptr); +} + +static _SLstruct_Field_Type *find_field (_SLang_Struct_Type *s, char *name) +{ + _SLstruct_Field_Type *f, *fmax; + + f = s->fields; + fmax = f + s->nfields; + + while (f < fmax) + { + /* Since both these are slstrings, only compare pointer */ + if (name == f->name) + return f; + + f++; + } + + return NULL; +} + +static _SLstruct_Field_Type *pop_field (_SLang_Struct_Type *s, char *name) +{ + _SLstruct_Field_Type *f; + + f = find_field (s, name); + if (f == NULL) + SLang_verror (SL_SYNTAX_ERROR, "struct has no field named %s", name); + return f; +} + +int SLstruct_create_struct (unsigned int nfields, + char **field_names, + unsigned char *field_types, + VOID_STAR *field_values) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + unsigned int i; + + if (NULL == (s = allocate_struct (nfields))) + return -1; + + f = s->fields; + for (i = 0; i < nfields; i++) + { + unsigned char type; + SLang_Class_Type *cl; + VOID_STAR value; + char *name = field_names [i]; + + if (name == NULL) + { + SLang_verror (SL_INVALID_PARM, "A struct field name cannot be NULL"); + goto return_error; + } + + if (NULL == (f->name = SLang_create_slstring (name))) + goto return_error; + + if ((field_values == NULL) + || (NULL == (value = field_values [i]))) + { + f++; + continue; + } + + type = field_types[i]; + cl = _SLclass_get_class (type); + + if ((-1 == (cl->cl_push (type, value))) + || (-1 == SLang_pop (&f->obj))) + goto return_error; + + f++; + } + + if (0 == _SLang_push_struct (s)) + return 0; + /* drop */ + + return_error: + _SLstruct_delete_struct (s); + return -1; +} + +/* Interpreter interface */ + +int _SLstruct_define_struct (void) +{ + int nfields; + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + + if (-1 == SLang_pop_integer (&nfields)) + return -1; + + if (nfields <= 0) + { + SLang_verror (SL_INVALID_PARM, "Number of struct fields must be > 0"); + return -1; + } + + if (NULL == (s = allocate_struct (nfields))) + return -1; + + f = s->fields; + while (nfields) + { + char *name; + + nfields--; + if (-1 == SLang_pop_slstring (&name)) + { + _SLstruct_delete_struct (s); + return -1; + } + f[nfields].name = name; + } + + if (-1 == _SLang_push_struct (s)) + { + _SLstruct_delete_struct (s); + return -1; + } + return 0; +} + +/* Simply make a struct that contains the same fields as struct s. Do not + * duplicate the field values. + */ +static _SLang_Struct_Type *make_struct_shell (_SLang_Struct_Type *s) +{ + _SLang_Struct_Type *new_s; + _SLstruct_Field_Type *new_f, *old_f; + unsigned int i, nfields; + + nfields = s->nfields; + if (NULL == (new_s = allocate_struct (nfields))) + return NULL; + + new_f = new_s->fields; + old_f = s->fields; + + for (i = 0; i < nfields; i++) + { + if (NULL == (new_f[i].name = SLang_create_slstring (old_f[i].name))) + { + _SLstruct_delete_struct (new_s); + return NULL; + } + } + return new_s; +} + +static int struct_init_array_object (unsigned char type, VOID_STAR addr) +{ + SLang_Class_Type *cl; + _SLang_Struct_Type *s; + + cl = _SLclass_get_class (type); + if (NULL == (s = make_struct_shell (cl->cl_struct_def))) + return -1; + + s->num_refs = 1; + *(_SLang_Struct_Type **) addr = s; + return 0; +} + +static int +typedefed_struct_datatype_deref (unsigned char type) +{ + SLang_Class_Type *cl; + _SLang_Struct_Type *s; + + cl = _SLclass_get_class (type); + if (NULL == (s = make_struct_shell (cl->cl_struct_def))) + return -1; + + if (-1 == push_struct_of_type (type, s)) + { + _SLstruct_delete_struct (s); + return -1; + } + + return 0; +} + +static _SLang_Struct_Type *duplicate_struct (_SLang_Struct_Type *s) +{ + _SLang_Struct_Type *new_s; + _SLstruct_Field_Type *new_f, *f, *fmax; + + new_s = make_struct_shell (s); + + if (new_s == NULL) + return NULL; + + f = s->fields; + fmax = f + s->nfields; + new_f = new_s->fields; + + while (f < fmax) + { + SLang_Object_Type *obj; + + obj = &f->obj; + if (obj->data_type != SLANG_UNDEFINED_TYPE) + { + if ((-1 == _SLpush_slang_obj (obj)) + || (-1 == SLang_pop (&new_f->obj))) + { + _SLstruct_delete_struct (new_s); + return NULL; + } + } + new_f++; + f++; + } + + return new_s; +} + +static int struct_dereference (unsigned char type, VOID_STAR addr) +{ + _SLang_Struct_Type *s; + + if (NULL == (s = duplicate_struct (*(_SLang_Struct_Type **) addr))) + return -1; + + if (-1 == push_struct_of_type (type, s)) + { + _SLstruct_delete_struct (s); + return -1; + } + + return 0; +} + +/*{{{ foreach */ + +struct _SLang_Foreach_Context_Type +{ + _SLang_Struct_Type *s; + char *next_field_name; +}; + +static SLang_Foreach_Context_Type * +struct_foreach_open (unsigned char type, unsigned int num) +{ + SLang_Foreach_Context_Type *c; + _SLang_Struct_Type *s; + char *next_name; + + (void) type; + + if (-1 == _SLang_pop_struct (&s)) + return NULL; + + switch (num) + { + case 0: + next_name = SLang_create_slstring ("next"); + break; + + case 1: + if (-1 == SLang_pop_slstring (&next_name)) + next_name = NULL; + break; + + default: + next_name = NULL; + SLang_verror (SL_NOT_IMPLEMENTED, + "'foreach (Struct_Type) using' requires single control value"); + SLdo_pop_n (num); + break; + } + + if (next_name == NULL) + { + _SLstruct_delete_struct (s); + return NULL; + } + + c = (SLang_Foreach_Context_Type *)SLmalloc (sizeof (SLang_Foreach_Context_Type)); + if (c == NULL) + { + _SLstruct_delete_struct (s); + SLang_free_slstring (next_name); + return NULL; + } + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + + c->next_field_name = next_name; + c->s = s; + + return c; +} + +static void struct_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + + SLang_free_slstring (c->next_field_name); + if (c->s != NULL) _SLstruct_delete_struct (c->s); + SLfree ((char *) c); +} + +static int struct_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + _SLstruct_Field_Type *f; + _SLang_Struct_Type *next_s; + + (void) type; + + if (c == NULL) + return -1; + + if (c->s == NULL) + return 0; /* done */ + + if (-1 == _SLang_push_struct (c->s)) + return -1; + + /* Now get the next one ready for the next foreach loop */ + + next_s = NULL; + if (NULL != (f = find_field (c->s, c->next_field_name))) + { + SLang_Class_Type *cl; + + cl = _SLclass_get_class (f->obj.data_type); + /* Note that I cannot simply look for SLANG_STRUCT_TYPE since the + * user may have typedefed another struct type. So, look at the + * class methods. + */ + if (cl->cl_foreach_open == struct_foreach_open) + { + next_s = f->obj.v.struct_val; + next_s->num_refs += 1; + } + } + + _SLstruct_delete_struct (c->s); + c->s = next_s; + + /* keep going */ + return 1; +} + +/*}}}*/ + +static int struct_sput (unsigned char type, char *name) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + SLang_Object_Type obj; + + (void) type; + + if (-1 == _SLang_pop_struct (&s)) + return -1; + + if ((NULL == (f = pop_field (s, name))) + || (-1 == SLang_pop (&obj))) + { + _SLstruct_delete_struct (s); + return -1; + } + + SLang_free_object (&f->obj); + f->obj = obj; + _SLstruct_delete_struct (s); + return 0; +} + +static int struct_sget (unsigned char type, char *name) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + int ret; + + (void) type; + + if (-1 == _SLang_pop_struct (&s)) + return -1; + + if (NULL == (f = pop_field (s, name))) + { + _SLstruct_delete_struct (s); + return -1; + } + + ret = _SLpush_slang_obj (&f->obj); + _SLstruct_delete_struct (s); + return ret; +} + +static int struct_typecast + (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + _SLang_Struct_Type **a, **b; + unsigned int i; + + (void) a_type; + (void) b_type; + + a = (_SLang_Struct_Type **) ap; + b = (_SLang_Struct_Type **) bp; + for (i = 0; i < na; i++) + { + b[i] = a[i]; + if (a[i] != NULL) + a[i]->num_refs += 1; + } + + return 1; +} + +int _SLstruct_define_typedef (void) +{ + char *type_name; + _SLang_Struct_Type *s, *s1; + SLang_Class_Type *cl; + + if (-1 == SLang_pop_slstring (&type_name)) + return -1; + + if (-1 == _SLang_pop_struct (&s)) + { + SLang_free_slstring (type_name); + return -1; + } + + if (NULL == (s1 = make_struct_shell (s))) + { + SLang_free_slstring (type_name); + _SLstruct_delete_struct (s); + return -1; + } + + _SLstruct_delete_struct (s); + + if (NULL == (cl = SLclass_allocate_class (type_name))) + { + SLang_free_slstring (type_name); + _SLstruct_delete_struct (s1); + return -1; + } + SLang_free_slstring (type_name); + + cl->cl_struct_def = s1; + cl->cl_init_array_object = struct_init_array_object; + cl->cl_datatype_deref = typedefed_struct_datatype_deref; + cl->cl_destroy = struct_destroy; + cl->cl_push = struct_push; + cl->cl_dereference = struct_dereference; + cl->cl_foreach_open = struct_foreach_open; + cl->cl_foreach_close = struct_foreach_close; + cl->cl_foreach = struct_foreach; + + cl->cl_sget = struct_sget; + cl->cl_sput = struct_sput; + + if (-1 == SLclass_register_class (cl, + SLANG_VOID_TYPE, /* any open slot */ + sizeof (_SLang_Struct_Type), + SLANG_CLASS_TYPE_PTR)) + { + /* FIXME: Priority=low */ + /* There is a memory leak here if this fails... */ + return -1; + } + /* Note: typecast from a user type struct type allowed but not the other + * way. + */ + if (-1 == SLclass_add_typecast (cl->cl_data_type, SLANG_STRUCT_TYPE, struct_typecast, 1)) + return -1; + + return 0; +} + +static int +struct_datatype_deref (unsigned char stype) +{ + (void) stype; + + if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE) + { + SLang_Array_Type *at; + int status; + + if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE)) + return -1; + + status = SLstruct_create_struct (at->num_elements, + (char **) at->data, NULL, NULL); + + SLang_free_array (at); + return status; + } + + SLang_push_integer (SLang_Num_Function_Args); + return _SLstruct_define_struct (); +} + +static int register_struct (void) +{ + SLang_Class_Type *cl; + + if (NULL == (cl = SLclass_allocate_class ("Struct_Type"))) + return -1; + + (void) SLclass_set_destroy_function (cl, struct_destroy); + (void) SLclass_set_push_function (cl, struct_push); + cl->cl_dereference = struct_dereference; + cl->cl_datatype_deref = struct_datatype_deref; + + cl->cl_foreach_open = struct_foreach_open; + cl->cl_foreach_close = struct_foreach_close; + cl->cl_foreach = struct_foreach; + + cl->cl_sget = struct_sget; + cl->cl_sput = struct_sput; + + if (-1 == SLclass_register_class (cl, SLANG_STRUCT_TYPE, sizeof (_SLang_Struct_Type), + SLANG_CLASS_TYPE_PTR)) + return -1; + + return 0; +} + +static void get_struct_field_names (_SLang_Struct_Type *s) +{ + SLang_Array_Type *a; + char **data; + int i, nfields; + _SLstruct_Field_Type *f; + + nfields = (int) s->nfields; + + if (NULL == (a = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &nfields, 1))) + return; + + f = s->fields; + data = (char **) a->data; + for (i = 0; i < nfields; i++) + { + /* Since we are dealing with hashed strings, the next call should not + * fail. If it does, the interpreter will handle it at some other + * level. + */ + data [i] = SLang_create_slstring (f[i].name); + } + + SLang_push_array (a, 1); +} + +static int push_struct_fields (_SLang_Struct_Type *s) +{ + _SLstruct_Field_Type *f, *fmax; + int num; + + f = s->fields; + fmax = f + s->nfields; + + num = 0; + while (fmax > f) + { + fmax--; + if (-1 == _SLpush_slang_obj (&fmax->obj)) + break; + + num++; + } + + return num; +} + +/* Syntax: set_struct_field (s, name, value); */ +static void struct_set_field (void) +{ + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + SLang_Object_Type obj; + char *name; + + if (-1 == SLang_pop (&obj)) + return; + + if (-1 == SLang_pop_slstring (&name)) + { + SLang_free_object (&obj); + return; + } + + if (-1 == _SLang_pop_struct (&s)) + { + SLang_free_slstring (name); + SLang_free_object (&obj); + return; + } + + if (NULL == (f = pop_field (s, name))) + { + _SLstruct_delete_struct (s); + SLang_free_slstring (name); + SLang_free_object (&obj); + return; + } + + SLang_free_object (&f->obj); + f->obj = obj; + + _SLstruct_delete_struct (s); + SLang_free_slstring (name); +} + +/* Syntax: set_struct_fields (s, values....); */ +static void set_struct_fields (void) +{ + unsigned int n; + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + + n = (unsigned int) SLang_Num_Function_Args; + + if (-1 == SLreverse_stack (n)) + return; + + n--; + if (-1 == _SLang_pop_struct (&s)) + { + SLdo_pop_n (n); + return; + } + + if (n > s->nfields) + { + SLdo_pop_n (n); + SLang_verror (SL_INVALID_PARM, "Too many values for structure"); + _SLstruct_delete_struct (s); + return; + } + + f = s->fields; + while (n > 0) + { + SLang_Object_Type obj; + + if (-1 == SLang_pop (&obj)) + break; + + SLang_free_object (&f->obj); + f->obj = obj; + + f++; + n--; + } + + _SLstruct_delete_struct (s); +} + +static void get_struct_field (char *name) +{ + (void) struct_sget (0, name); +} + +static int is_struct_type (void) +{ + SLang_Object_Type obj; + unsigned char type; + int status; + + if (-1 == SLang_pop (&obj)) + return -1; + + type = obj.data_type; + if (type == SLANG_STRUCT_TYPE) + status = 1; + else + status = (NULL != _SLclass_get_class (type)->cl_struct_def); + SLang_free_object (&obj); + return status; +} + + +static SLang_Intrin_Fun_Type Struct_Table [] = +{ + MAKE_INTRINSIC_1("get_struct_field_names", get_struct_field_names, SLANG_VOID_TYPE, SLANG_STRUCT_TYPE), + MAKE_INTRINSIC_1("get_struct_field", get_struct_field, SLANG_VOID_TYPE, SLANG_STRING_TYPE), + MAKE_INTRINSIC_1("_push_struct_field_values", push_struct_fields, SLANG_INT_TYPE, SLANG_STRUCT_TYPE), + MAKE_INTRINSIC_0("set_struct_field", struct_set_field, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("set_struct_fields", set_struct_fields, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("is_struct_type", is_struct_type, SLANG_INT_TYPE), + /* MAKE_INTRINSIC_I("_create_struct", create_struct, SLANG_VOID_TYPE), */ + SLANG_END_INTRIN_FUN_TABLE +}; + +int _SLstruct_init (void) +{ + if ((-1 == SLadd_intrin_fun_table (Struct_Table, NULL)) + || (-1 == register_struct ())) + return -1; + + return 0; +} + +void _SLstruct_pop_args (int *np) +{ + SLang_Array_Type *at; + int i, n; + _SLang_Struct_Type **data; + + n = *np; + + if (n < 0) + { + SLang_Error = SL_INVALID_PARM; + return; + } + + data = (_SLang_Struct_Type **) SLmalloc ((n + 1) * sizeof (_SLang_Struct_Type *)); + if (data == NULL) + { + SLdo_pop_n (n); + return; + } + + memset ((char *)data, 0, n * sizeof (_SLang_Struct_Type *)); + + i = n; + while (i > 0) + { + _SLang_Struct_Type *s; + _SLstruct_Field_Type *f; + + i--; + + if (NULL == (s = allocate_struct (1))) + goto return_error; + + data[i] = s; + s->num_refs += 1; /* keeping a copy */ + + f = s->fields; + if (NULL == (f->name = SLang_create_slstring ("value"))) + goto return_error; + + if (-1 == SLang_pop (&f->obj)) + goto return_error; + } + + if (NULL == (at = SLang_create_array (SLANG_STRUCT_TYPE, 0, + (VOID_STAR) data, &n, 1))) + goto return_error; + + (void) SLang_push_array (at, 1); + return; + + return_error: + for (i = 0; i < n; i++) + { + _SLang_Struct_Type *s; + + s = data[i]; + if (s != NULL) + _SLstruct_delete_struct (s); + } + + SLfree ((char *) data); +} + +void _SLstruct_push_args (SLang_Array_Type *at) +{ + _SLang_Struct_Type **sp; + unsigned int num; + + if (at->data_type != SLANG_STRUCT_TYPE) + { + SLang_Error = SL_TYPE_MISMATCH; + return; + } + + sp = (_SLang_Struct_Type **) at->data; + num = at->num_elements; + + while ((SLang_Error == 0) && (num > 0)) + { + _SLang_Struct_Type *s; + + num--; + if (NULL == (s = *sp++)) + { + SLang_push_null (); + continue; + } + + /* I should check to see if the value field is present, but... */ + (void) _SLpush_slang_obj (&s->fields->obj); + } +} diff --git a/mdk-stage1/slang/sltermin.c b/mdk-stage1/slang/sltermin.c new file mode 100644 index 000000000..f9c64f0b2 --- /dev/null +++ b/mdk-stage1/slang/sltermin.c @@ -0,0 +1,1155 @@ +/* This file contains enough terminfo reading capabilities sufficient for + * the slang SLtt interface. + */ + +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +/* + * The majority of the comments found in the file were taken from the + * term(4) man page on an SGI. + */ + +/* Short integers are stored in two 8-bit bytes. The first byte contains + * the least significant 8 bits of the value, and the second byte contains + * the most significant 8 bits. (Thus, the value represented is + * 256*second+first.) The value -1 is represented by 0377,0377, and the + * value -2 is represented by 0376,0377; other negative values are illegal. + * The -1 generally means that a capability is missing from this terminal. + * The -2 means that the capability has been cancelled in the terminfo + * source and also is to be considered missing. + */ + +static int make_integer (unsigned char *buf) +{ + register int lo, hi; + lo = (int) *buf++; hi = (int) *buf; + if (hi == 0377) + { + if (lo == 0377) return -1; + if (lo == 0376) return -2; + } + return lo + 256 * hi; +} + +/* + * The compiled file is created from the source file descriptions of the + * terminals (see the -I option of infocmp) by using the terminfo compiler, + * tic, and read by the routine setupterm [see curses(3X).] The file is + * divided into six parts in the following order: the header, terminal + * names, boolean flags, numbers, strings, and string table. + * + * The header section begins the file. This section contains six short + * integers in the format described below. These integers are (1) the magic + * number (octal 0432); (2) the size, in bytes, of the names section; (3) + * the number of bytes in the boolean section; (4) the number of short + * integers in the numbers section; (5) the number of offsets (short + * integers) in the strings section; (6) the size, in bytes, of the string + * table. + */ + +#define MAGIC 0432 + +/* In this structure, all char * fields are malloced EXCEPT if the + * structure is SLTERMCAP. In that case, only terminal_names is malloced + * and the other fields are pointers into it. + */ +struct _SLterminfo_Type +{ +#define SLTERMINFO 1 +#define SLTERMCAP 2 + unsigned int flags; + + unsigned int name_section_size; + char *terminal_names; + + unsigned int boolean_section_size; + unsigned char *boolean_flags; + + unsigned int num_numbers; + unsigned char *numbers; + + unsigned int num_string_offsets; + unsigned char *string_offsets; + + unsigned int string_table_size; + char *string_table; + +}; + +static char *tcap_getstr (char *, SLterminfo_Type *); +static int tcap_getnum (char *, SLterminfo_Type *); +static int tcap_getflag (char *, SLterminfo_Type *); +static int tcap_getent (char *, SLterminfo_Type *); + +static FILE *open_terminfo (char *file, SLterminfo_Type *h) +{ + FILE *fp; + unsigned char buf[12]; + + /* Alan Cox reported a security problem here if the application using the + * library is setuid. So, I need to make sure open the file as a normal + * user. Unfortunately, there does not appear to be a portable way of + * doing this, so I am going to use 'setfsgid' and 'setfsuid', which + * are not portable. + * + * I will also look into the use of setreuid, seteuid and setregid, setegid. + * FIXME: Priority=medium + */ + fp = fopen (file, "rb"); + if (fp == NULL) return NULL; + + if ((12 == fread ((char *) buf, 1, 12, fp) && (MAGIC == make_integer (buf)))) + { + h->name_section_size = make_integer (buf + 2); + h->boolean_section_size = make_integer (buf + 4); + h->num_numbers = make_integer (buf + 6); + h->num_string_offsets = make_integer (buf + 8); + h->string_table_size = make_integer (buf + 10); + } + else + { + fclose (fp); + fp = NULL; + } + return fp; +} + +/* + * The terminal names section comes next. It contains the first line of the + * terminfo description, listing the various names for the terminal, + * separated by the bar ( | ) character (see term(5)). The section is + * terminated with an ASCII NUL character. + */ + +/* returns pointer to malloced space */ +static unsigned char *read_terminfo_section (FILE *fp, unsigned int size) +{ + char *s; + + if (NULL == (s = (char *) SLmalloc (size))) return NULL; + if (size != fread (s, 1, size, fp)) + { + SLfree (s); + return NULL; + } + return (unsigned char *) s; +} + +static char *read_terminal_names (FILE *fp, SLterminfo_Type *t) +{ + return t->terminal_names = (char *) read_terminfo_section (fp, t->name_section_size); +} + +/* + * The boolean flags have one byte for each flag. This byte is either 0 or + * 1 as the flag is present or absent. The value of 2 means that the flag + * has been cancelled. The capabilities are in the same order as the file + * <term.h>. + */ + +static unsigned char *read_boolean_flags (FILE *fp, SLterminfo_Type *t) +{ + /* Between the boolean section and the number section, a null byte is + * inserted, if necessary, to ensure that the number section begins on an + * even byte offset. All short integers are aligned on a short word + * boundary. + */ + + unsigned int size = (t->name_section_size + t->boolean_section_size) % 2; + size += t->boolean_section_size; + + return t->boolean_flags = read_terminfo_section (fp, size); +} + +/* + * The numbers section is similar to the boolean flags section. Each + * capability takes up two bytes, and is stored as a short integer. If the + * value represented is -1 or -2, the capability is taken to be missing. + */ + +static unsigned char *read_numbers (FILE *fp, SLterminfo_Type *t) +{ + return t->numbers = read_terminfo_section (fp, 2 * t->num_numbers); +} + +/* The strings section is also similar. Each capability is stored as a + * short integer, in the format above. A value of -1 or -2 means the + * capability is missing. Otherwise, the value is taken as an offset from + * the beginning of the string table. Special characters in ^X or \c + * notation are stored in their interpreted form, not the printing + * representation. Padding information ($<nn>) and parameter information + * (%x) are stored intact in uninterpreted form. + */ + +static unsigned char *read_string_offsets (FILE *fp, SLterminfo_Type *t) +{ + return t->string_offsets = (unsigned char *) read_terminfo_section (fp, 2 * t->num_string_offsets); +} + +/* The final section is the string table. It contains all the values of + * string capabilities referenced in the string section. Each string is + * null terminated. + */ + +static char *read_string_table (FILE *fp, SLterminfo_Type *t) +{ + return t->string_table = (char *) read_terminfo_section (fp, t->string_table_size); +} + +/* + * Compiled terminfo(4) descriptions are placed under the directory + * /usr/share/lib/terminfo. In order to avoid a linear search of a huge + * UNIX system directory, a two-level scheme is used: + * /usr/share/lib/terminfo/c/name where name is the name of the terminal, + * and c is the first character of name. Thus, att4425 can be found in the + * file /usr/share/lib/terminfo/a/att4425. Synonyms for the same terminal + * are implemented by multiple links to the same compiled file. + */ + +#define MAX_TI_DIRS 7 +static char *Terminfo_Dirs [MAX_TI_DIRS] = +{ + NULL, /* $HOME/.terminfo */ + NULL, /* $TERMINFO */ + "/usr/share/terminfo", + "/usr/lib/terminfo", + "/usr/share/lib/terminfo", + "/etc/terminfo", + "/usr/local/lib/terminfo" +}; + +SLterminfo_Type *_SLtt_tigetent (char *term) +{ + char *tidir; + int i; + FILE *fp = NULL; + char file[1024]; + static char home_ti [1024]; + char *home; + SLterminfo_Type *ti; + + if ( + (term == NULL) +#ifdef SLANG_UNTIC + && (SLang_Untic_Terminfo_File == NULL) +#endif + ) + return NULL; + + if (NULL == (ti = (SLterminfo_Type *) SLmalloc (sizeof (SLterminfo_Type)))) + { + return NULL; + } + +#ifdef SLANG_UNTIC + if (SLang_Untic_Terminfo_File != NULL) + { + fp = open_terminfo (SLang_Untic_Terminfo_File, ti); + goto fp_open_label; + } + else +#endif + /* If we are on a termcap based system, use termcap */ + if (0 == tcap_getent (term, ti)) return ti; + + if (NULL != (home = getenv ("HOME"))) + { + strncpy (home_ti, home, sizeof (home_ti) - 11); + home_ti [sizeof(home_ti) - 11] = 0; + strcat (home_ti, "/.terminfo"); + Terminfo_Dirs [0] = home_ti; + } + + Terminfo_Dirs[1] = getenv ("TERMINFO"); + i = 0; + while (i < MAX_TI_DIRS) + { + tidir = Terminfo_Dirs[i]; + if ((tidir != NULL) + && (sizeof (file) > strlen (tidir) + 2 + strlen (term))) + { + sprintf (file, "%s/%c/%s", tidir, *term, term); + if (NULL != (fp = open_terminfo (file, ti))) + break; + } + i++; + } +#ifdef SLANG_UNTIC + fp_open_label: +#endif + + if (fp != NULL) + { + if (NULL != read_terminal_names (fp, ti)) + { + if (NULL != read_boolean_flags (fp, ti)) + { + if (NULL != read_numbers (fp, ti)) + { + if (NULL != read_string_offsets (fp, ti)) + { + if (NULL != read_string_table (fp, ti)) + { + /* success */ + fclose (fp); + ti->flags = SLTERMINFO; + return ti; + } + SLfree ((char *)ti->string_offsets); + } + SLfree ((char *)ti->numbers); + } + SLfree ((char *)ti->boolean_flags); + } + SLfree ((char *)ti->terminal_names); + } + fclose (fp); + } + + SLfree ((char *)ti); + return NULL; +} + +#ifdef SLANG_UNTIC +# define UNTIC_COMMENT(x) ,x +#else +# define UNTIC_COMMENT(x) +#endif + +typedef struct +{ + char name[3]; + int offset; +#ifdef SLANG_UNTIC + char *comment; +#endif +} +Tgetstr_Map_Type; + +/* I need to add: K1-5, %0-5(not important), @8, &8... */ +static Tgetstr_Map_Type Tgetstr_Map [] = +{ + {"!1", 212 UNTIC_COMMENT("shifted key")}, + {"!2", 213 UNTIC_COMMENT("shifted key")}, + {"!3", 214 UNTIC_COMMENT("shifted key")}, + {"#1", 198 UNTIC_COMMENT("shifted key")}, + {"#2", 199 UNTIC_COMMENT("Key S-Home")}, + {"#3", 200 UNTIC_COMMENT("Key S-Insert")}, + {"#4", 201 UNTIC_COMMENT("Key S-Left")}, + {"%0", 177 UNTIC_COMMENT("redo key")}, + {"%1", 168 UNTIC_COMMENT("help key")}, + {"%2", 169 UNTIC_COMMENT("mark key")}, + {"%3", 170 UNTIC_COMMENT("message key")}, + {"%4", 171 UNTIC_COMMENT("move key")}, + {"%5", 172 UNTIC_COMMENT("next key")}, + {"%6", 173 UNTIC_COMMENT("open key")}, + {"%7", 174 UNTIC_COMMENT("options key")}, + {"%8", 175 UNTIC_COMMENT("previous key")}, + {"%9", 176 UNTIC_COMMENT("print key")}, + {"%a", 202 UNTIC_COMMENT("shifted key")}, + {"%b", 203 UNTIC_COMMENT("shifted key")}, + {"%c", 204 UNTIC_COMMENT("Key S-Next")}, + {"%d", 205 UNTIC_COMMENT("shifted key")}, + {"%e", 206 UNTIC_COMMENT("Key S-Previous")}, + {"%f", 207 UNTIC_COMMENT("shifted key")}, + {"%g", 208 UNTIC_COMMENT("shifted key")}, + {"%h", 209 UNTIC_COMMENT("shifted key")}, + {"%i", 210 UNTIC_COMMENT("Key S-Right")}, + {"%j", 211 UNTIC_COMMENT("shifted key")}, + {"&0", 187 UNTIC_COMMENT("shifted key")}, + {"&1", 178 UNTIC_COMMENT("reference key")}, + {"&2", 179 UNTIC_COMMENT("refresh key")}, + {"&3", 180 UNTIC_COMMENT("replace key")}, + {"&4", 181 UNTIC_COMMENT("restart key")}, + {"&5", 182 UNTIC_COMMENT("resume key")}, + {"&6", 183 UNTIC_COMMENT("save key")}, + {"&7", 184 UNTIC_COMMENT("suspend key")}, + {"&8", 185 UNTIC_COMMENT("undo key")}, + {"&9", 186 UNTIC_COMMENT("shifted key")}, + {"*0", 197 UNTIC_COMMENT("shifted key")}, + {"*1", 188 UNTIC_COMMENT("shifted key")}, + {"*2", 189 UNTIC_COMMENT("shifted key")}, + {"*3", 190 UNTIC_COMMENT("shifted key")}, + {"*4", 191 UNTIC_COMMENT("Key S-Delete")}, + {"*5", 192 UNTIC_COMMENT("shifted key")}, + {"*6", 193 UNTIC_COMMENT("select key")}, + {"*7", 194 UNTIC_COMMENT("Key S-End")}, + {"*8", 195 UNTIC_COMMENT("shifted key")}, + {"*9", 196 UNTIC_COMMENT("shifted key")}, + {"@0", 167 UNTIC_COMMENT("find key")}, + {"@1", 158 UNTIC_COMMENT("begin key")}, + {"@2", 159 UNTIC_COMMENT("cancel key")}, + {"@3", 160 UNTIC_COMMENT("close key")}, + {"@4", 161 UNTIC_COMMENT("command key")}, + {"@5", 162 UNTIC_COMMENT("copy key")}, + {"@6", 163 UNTIC_COMMENT("create key")}, + {"@7", 164 UNTIC_COMMENT("Key End")}, + {"@8", 165 UNTIC_COMMENT("enter/send key")}, + {"@9", 166 UNTIC_COMMENT("exit key")}, + {"AB", 360 UNTIC_COMMENT("set ANSI color background")}, + {"AF", 359 UNTIC_COMMENT("set ANSI color foreground")}, + {"AL", 110 UNTIC_COMMENT("parm_insert_line")}, + {"CC", 9 UNTIC_COMMENT("terminal settable cmd character in prototype !?")}, + {"CM", 15 UNTIC_COMMENT("memory relative cursor addressing")}, + {"CW", 277 UNTIC_COMMENT("define a window #1 from #2, #3 to #4, #5")}, + {"DC", 105 UNTIC_COMMENT("delete #1 chars")}, + {"DI", 280 UNTIC_COMMENT("dial number #1")}, + {"DK", 275 UNTIC_COMMENT("display clock at (#1,#2)")}, + {"DL", 106 UNTIC_COMMENT("parm_delete_line")}, + {"DO", 107 UNTIC_COMMENT("down #1 lines")}, + {"F1", 216 UNTIC_COMMENT("key_f11")}, + {"F2", 217 UNTIC_COMMENT("key_f12")}, + {"F3", 218 UNTIC_COMMENT("key_f13")}, + {"F4", 219 UNTIC_COMMENT("key_f14")}, + {"F5", 220 UNTIC_COMMENT("key_f15")}, + {"F6", 221 UNTIC_COMMENT("key_f16")}, + {"F7", 222 UNTIC_COMMENT("key_f17")}, + {"F8", 223 UNTIC_COMMENT("key_f18")}, + {"F9", 224 UNTIC_COMMENT("key_f19")}, + {"FA", 225 UNTIC_COMMENT("key_f20")}, + {"FB", 226 UNTIC_COMMENT("F21 function key")}, + {"FC", 227 UNTIC_COMMENT("F22 function key")}, + {"FD", 228 UNTIC_COMMENT("F23 function key")}, + {"FE", 229 UNTIC_COMMENT("F24 function key")}, + {"FF", 230 UNTIC_COMMENT("F25 function key")}, + {"FG", 231 UNTIC_COMMENT("F26 function key")}, + {"FH", 232 UNTIC_COMMENT("F27 function key")}, + {"FI", 233 UNTIC_COMMENT("F28 function key")}, + {"FJ", 234 UNTIC_COMMENT("F29 function key")}, + {"FK", 235 UNTIC_COMMENT("F30 function key")}, + {"FL", 236 UNTIC_COMMENT("F31 function key")}, + {"FM", 237 UNTIC_COMMENT("F32 function key")}, + {"FN", 238 UNTIC_COMMENT("F33 function key")}, + {"FO", 239 UNTIC_COMMENT("F34 function key")}, + {"FP", 240 UNTIC_COMMENT("F35 function key")}, + {"FQ", 241 UNTIC_COMMENT("F36 function key")}, + {"FR", 242 UNTIC_COMMENT("F37 function key")}, + {"FS", 243 UNTIC_COMMENT("F38 function key")}, + {"FT", 244 UNTIC_COMMENT("F39 function key")}, + {"FU", 245 UNTIC_COMMENT("F40 function key")}, + {"FV", 246 UNTIC_COMMENT("F41 function key")}, + {"FW", 247 UNTIC_COMMENT("F42 function key")}, + {"FX", 248 UNTIC_COMMENT("F43 function key")}, + {"FY", 249 UNTIC_COMMENT("F44 function key")}, + {"FZ", 250 UNTIC_COMMENT("F45 function key")}, + {"Fa", 251 UNTIC_COMMENT("F46 function key")}, + {"Fb", 252 UNTIC_COMMENT("F47 function key")}, + {"Fc", 253 UNTIC_COMMENT("F48 function key")}, + {"Fd", 254 UNTIC_COMMENT("F49 function key")}, + {"Fe", 255 UNTIC_COMMENT("F50 function key")}, + {"Ff", 256 UNTIC_COMMENT("F51 function key")}, + {"Fg", 257 UNTIC_COMMENT("F52 function key")}, + {"Fh", 258 UNTIC_COMMENT("F53 function key")}, + {"Fi", 259 UNTIC_COMMENT("F54 function key")}, + {"Fj", 260 UNTIC_COMMENT("F55 function key")}, + {"Fk", 261 UNTIC_COMMENT("F56 function key")}, + {"Fl", 262 UNTIC_COMMENT("F57 function key")}, + {"Fm", 263 UNTIC_COMMENT("F58 function key")}, + {"Fn", 264 UNTIC_COMMENT("F59 function key")}, + {"Fo", 265 UNTIC_COMMENT("F60 function key")}, + {"Fp", 266 UNTIC_COMMENT("F61 function key")}, + {"Fq", 267 UNTIC_COMMENT("F62 function key")}, + {"Fr", 268 UNTIC_COMMENT("F63 function key")}, + {"G1", 400 UNTIC_COMMENT("single upper right")}, + {"G2", 398 UNTIC_COMMENT("single upper left")}, + {"G3", 399 UNTIC_COMMENT("single lower left")}, + {"G4", 401 UNTIC_COMMENT("single lower right")}, + {"GC", 408 UNTIC_COMMENT("single intersection")}, + {"GD", 405 UNTIC_COMMENT("tee pointing down")}, + {"GH", 406 UNTIC_COMMENT("single horizontal line")}, + {"GL", 403 UNTIC_COMMENT("tee pointing left")}, + {"GR", 402 UNTIC_COMMENT("tee pointing right")}, + {"GU", 404 UNTIC_COMMENT("tee pointing up")}, + {"GV", 407 UNTIC_COMMENT("single vertical line")}, + {"Gm", 358 UNTIC_COMMENT("Curses should get button events")}, + {"HU", 279 UNTIC_COMMENT("hang-up phone")}, + {"IC", 108 UNTIC_COMMENT("insert #1 chars")}, + {"Ic", 299 UNTIC_COMMENT("initialize color #1 to (#2,#3,#4)")}, + {"Ip", 300 UNTIC_COMMENT("Initialize color pair #1 to fg=(#2,#3,#4), bg=(#5,#6,#7)")}, + {"K1", 139 UNTIC_COMMENT("upper left of keypad")}, + {"K2", 141 UNTIC_COMMENT("center of keypad")}, + {"K3", 140 UNTIC_COMMENT("upper right of keypad")}, + {"K4", 142 UNTIC_COMMENT("lower left of keypad")}, + {"K5", 143 UNTIC_COMMENT("lower right of keypad")}, + {"Km", 355 UNTIC_COMMENT("Mouse event has occurred")}, + {"LE", 111 UNTIC_COMMENT("move #1 chars to the left")}, + {"LF", 157 UNTIC_COMMENT("turn off soft labels")}, + {"LO", 156 UNTIC_COMMENT("turn on soft labels")}, + {"Lf", 273 UNTIC_COMMENT("label format")}, + {"MC", 270 UNTIC_COMMENT("clear right and left soft margins")}, + {"ML", 271 UNTIC_COMMENT("set left soft margin")}, + {"ML", 368 UNTIC_COMMENT("Set both left and right margins to #1, #2")}, + {"MR", 272 UNTIC_COMMENT("set right soft margin")}, + {"MT", 369 UNTIC_COMMENT("Sets both top and bottom margins to #1, #2")}, + {"Mi", 356 UNTIC_COMMENT("Mouse status information")}, + {"PA", 285 UNTIC_COMMENT("pause for 2-3 seconds")}, + {"PU", 283 UNTIC_COMMENT("select pulse dialling")}, + {"QD", 281 UNTIC_COMMENT("dial number #1 without checking")}, + {"RA", 152 UNTIC_COMMENT("turn off automatic margins")}, + {"RC", 276 UNTIC_COMMENT("remove clock")}, + {"RF", 215 UNTIC_COMMENT("send next input char (for ptys)")}, + {"RI", 112 UNTIC_COMMENT("parm_right_cursor")}, + {"RQ", 357 UNTIC_COMMENT("Request mouse position")}, + {"RX", 150 UNTIC_COMMENT("turn off xon/xoff handshaking")}, + {"S1", 378 UNTIC_COMMENT("Display PC character")}, + {"S2", 379 UNTIC_COMMENT("Enter PC character display mode")}, + {"S3", 380 UNTIC_COMMENT("Exit PC character display mode")}, + {"S4", 381 UNTIC_COMMENT("Enter PC scancode mode")}, + {"S5", 382 UNTIC_COMMENT("Exit PC scancode mode")}, + {"S6", 383 UNTIC_COMMENT("PC terminal options")}, + {"S7", 384 UNTIC_COMMENT("Escape for scancode emulation")}, + {"S8", 385 UNTIC_COMMENT("Alternate escape for scancode emulation")}, + {"SA", 151 UNTIC_COMMENT("turn on automatic margins")}, + {"SC", 274 UNTIC_COMMENT("set clock, #1 hrs #2 mins #3 secs")}, + {"SF", 109 UNTIC_COMMENT("scroll forward #1 lines")}, + {"SR", 113 UNTIC_COMMENT("scroll back #1 lines")}, + {"SX", 149 UNTIC_COMMENT("turn on xon/xoff handshaking")}, + {"Sb", 303 UNTIC_COMMENT("set background (color)")}, + {"Sf", 302 UNTIC_COMMENT("set foreground (color)")}, + {"TO", 282 UNTIC_COMMENT("select touch tone dialing")}, + {"UP", 114 UNTIC_COMMENT("up #1 lines")}, + {"WA", 286 UNTIC_COMMENT("wait for dial-tone")}, + {"WG", 278 UNTIC_COMMENT("go to window #1")}, + {"XF", 154 UNTIC_COMMENT("XOFF character")}, + {"XN", 153 UNTIC_COMMENT("XON character")}, + {"Xh", 386 UNTIC_COMMENT("Enter horizontal highlight mode")}, + {"Xl", 387 UNTIC_COMMENT("Enter left highlight mode")}, + {"Xo", 388 UNTIC_COMMENT("Enter low highlight mode")}, + {"Xr", 389 UNTIC_COMMENT("Enter right highlight mode")}, + {"Xt", 390 UNTIC_COMMENT("Enter top highlight mode")}, + {"Xv", 391 UNTIC_COMMENT("Enter vertical highlight mode")}, + {"Xy", 370 UNTIC_COMMENT("Repeat bit image cell #1 #2 times")}, + {"YZ", 377 UNTIC_COMMENT("Set page length to #1 lines")}, + {"Yv", 372 UNTIC_COMMENT("Move to beginning of same row")}, + {"Yw", 373 UNTIC_COMMENT("Give name for color #1")}, + {"Yx", 374 UNTIC_COMMENT("Define rectangualar bit image region")}, + {"Yy", 375 UNTIC_COMMENT("End a bit-image region")}, + {"Yz", 376 UNTIC_COMMENT("Change to ribbon color #1")}, + {"ZA", 304 UNTIC_COMMENT("Change number of characters per inch")}, + {"ZB", 305 UNTIC_COMMENT("Change number of lines per inch")}, + {"ZC", 306 UNTIC_COMMENT("Change horizontal resolution")}, + {"ZD", 307 UNTIC_COMMENT("Change vertical resolution")}, + {"ZE", 308 UNTIC_COMMENT("Define a character")}, + {"ZF", 309 UNTIC_COMMENT("Enter double-wide mode")}, + {"ZG", 310 UNTIC_COMMENT("Enter draft-quality mode")}, + {"ZH", 311 UNTIC_COMMENT("Enter italic mode")}, + {"ZI", 312 UNTIC_COMMENT("Start leftward carriage motion")}, + {"ZJ", 313 UNTIC_COMMENT("Start micro-motion mode")}, + {"ZK", 314 UNTIC_COMMENT("Enter NLQ mode")}, + {"ZL", 315 UNTIC_COMMENT("Wnter normal-quality mode")}, + {"ZM", 316 UNTIC_COMMENT("Enter shadow-print mode")}, + {"ZN", 317 UNTIC_COMMENT("Enter subscript mode")}, + {"ZO", 318 UNTIC_COMMENT("Enter superscript mode")}, + {"ZP", 319 UNTIC_COMMENT("Start upward carriage motion")}, + {"ZQ", 320 UNTIC_COMMENT("End double-wide mode")}, + {"ZR", 321 UNTIC_COMMENT("End italic mode")}, + {"ZS", 322 UNTIC_COMMENT("End left-motion mode")}, + {"ZT", 323 UNTIC_COMMENT("End micro-motion mode")}, + {"ZU", 324 UNTIC_COMMENT("End shadow-print mode")}, + {"ZV", 325 UNTIC_COMMENT("End subscript mode")}, + {"ZW", 326 UNTIC_COMMENT("End superscript mode")}, + {"ZX", 327 UNTIC_COMMENT("End reverse character motion")}, + {"ZY", 328 UNTIC_COMMENT("Like column_address in micro mode")}, + {"ZZ", 329 UNTIC_COMMENT("Like cursor_down in micro mode")}, + {"Za", 330 UNTIC_COMMENT("Like cursor_left in micro mode")}, + {"Zb", 331 UNTIC_COMMENT("Like cursor_right in micro mode")}, + {"Zc", 332 UNTIC_COMMENT("Like row_address in micro mode")}, + {"Zd", 333 UNTIC_COMMENT("Like cursor_up in micro mode")}, + {"Ze", 334 UNTIC_COMMENT("Match software bits to print-head pins")}, + {"Zf", 335 UNTIC_COMMENT("Like parm_down_cursor in micro mode")}, + {"Zg", 336 UNTIC_COMMENT("Like parm_left_cursor in micro mode")}, + {"Zh", 337 UNTIC_COMMENT("Like parm_right_cursor in micro mode")}, + {"Zi", 338 UNTIC_COMMENT("Like parm_up_cursor in micro mode")}, + {"Zj", 339 UNTIC_COMMENT("Select character set")}, + {"Zk", 340 UNTIC_COMMENT("Set bottom margin at current line")}, + {"Zl", 341 UNTIC_COMMENT("Set bottom margin at line #1 or #2 lines from bottom")}, + {"Zm", 342 UNTIC_COMMENT("Set left (right) margin at column #1 (#2)")}, + {"Zn", 343 UNTIC_COMMENT("Set right margin at column #1")}, + {"Zo", 344 UNTIC_COMMENT("Set top margin at current line")}, + {"Zp", 345 UNTIC_COMMENT("Set top (bottom) margin at row #1 (#2)")}, + {"Zq", 346 UNTIC_COMMENT("Start printing bit image braphics")}, + {"Zr", 347 UNTIC_COMMENT("Start character set definition")}, + {"Zs", 348 UNTIC_COMMENT("Stop printing bit image graphics")}, + {"Zt", 349 UNTIC_COMMENT("End definition of character aet")}, + {"Zu", 350 UNTIC_COMMENT("List of subscriptable characters")}, + {"Zv", 351 UNTIC_COMMENT("List of superscriptable characters")}, + {"Zw", 352 UNTIC_COMMENT("Printing any of these chars causes CR")}, + {"Zx", 353 UNTIC_COMMENT("No motion for subsequent character")}, + {"Zy", 354 UNTIC_COMMENT("List of character set names")}, + {"Zz", 371 UNTIC_COMMENT("Move to next row of the bit image")}, + {"ac", 146 UNTIC_COMMENT("acs_chars")}, + {"ae", 38 UNTIC_COMMENT("exit_alt_charset_mode")}, + {"al", 53 UNTIC_COMMENT("insert line")}, + {"as", 25 UNTIC_COMMENT("enter_alt_charset_mode")}, + {"bc", 395 UNTIC_COMMENT("move left, if not ^H")}, + {"bl", 1 UNTIC_COMMENT("audible signal (bell)")}, + {"bt", 0 UNTIC_COMMENT("back tab")}, + {"bx", 411 UNTIC_COMMENT("box chars primary set")}, + {"cb", 269 UNTIC_COMMENT("Clear to beginning of line")}, + {"cd", 7 UNTIC_COMMENT("clear to end of screen")}, + {"ce", 6 UNTIC_COMMENT("clr_eol")}, + {"ch", 8 UNTIC_COMMENT("horizontal position #1, absolute")}, + {"ci", 363 UNTIC_COMMENT("Init sequence for multiple codesets")}, + {"cl", 5 UNTIC_COMMENT("clear screen and home cursor")}, + {"cm", 10 UNTIC_COMMENT("move to row #1 columns #2")}, + {"cr", 2 UNTIC_COMMENT("carriage return")}, + {"cs", 3 UNTIC_COMMENT("change region to line #1 to line #2")}, + {"ct", 4 UNTIC_COMMENT("clear all tab stops")}, + {"cv", 127 UNTIC_COMMENT("vertical position #1 absolute")}, + {"dc", 21 UNTIC_COMMENT("delete character")}, + {"dl", 22 UNTIC_COMMENT("delete line")}, + {"dm", 29 UNTIC_COMMENT("enter delete mode")}, + {"do", 11 UNTIC_COMMENT("down one line")}, + {"ds", 23 UNTIC_COMMENT("disable status line")}, + {"dv", 362 UNTIC_COMMENT("Indicate language/codeset support")}, + {"eA", 155 UNTIC_COMMENT("enable alternate char set")}, + {"ec", 37 UNTIC_COMMENT("erase #1 characters")}, + {"ed", 41 UNTIC_COMMENT("end delete mode")}, + {"ei", 42 UNTIC_COMMENT("exit insert mode")}, + {"ff", 46 UNTIC_COMMENT("hardcopy terminal page eject")}, + {"fh", 284 UNTIC_COMMENT("flash switch hook")}, + {"fs", 47 UNTIC_COMMENT("return from status line")}, + {"hd", 24 UNTIC_COMMENT("half a line down")}, + {"ho", 12 UNTIC_COMMENT("home cursor (if no cup)")}, + {"hu", 137 UNTIC_COMMENT("half a line up")}, + {"i1", 48 UNTIC_COMMENT("initialization string")}, + {"i2", 392 UNTIC_COMMENT("secondary initialization string")}, + {"i3", 50 UNTIC_COMMENT("initialization string")}, + {"iP", 138 UNTIC_COMMENT("path name of program for initialization")}, + {"ic", 52 UNTIC_COMMENT("insert character")}, + {"if", 51 UNTIC_COMMENT("name of initialization file")}, + {"im", 31 UNTIC_COMMENT("enter insert mode")}, + {"ip", 54 UNTIC_COMMENT("insert padding after inserted character")}, + {"is", 49 UNTIC_COMMENT("initialization string")}, + {"k0", 65 UNTIC_COMMENT("F0 function key")}, + {"k1", 66 UNTIC_COMMENT("F1 function key")}, + {"k2", 68 UNTIC_COMMENT("F2 function key")}, + {"k3", 69 UNTIC_COMMENT("F3 function key")}, + {"k4", 70 UNTIC_COMMENT("F4 function key")}, + {"k5", 71 UNTIC_COMMENT("F5 function key")}, + {"k6", 72 UNTIC_COMMENT("F6 function key")}, + {"k7", 73 UNTIC_COMMENT("F7 function key")}, + {"k8", 74 UNTIC_COMMENT("F8 fucntion key")}, + {"k9", 75 UNTIC_COMMENT("F9 function key")}, + {"k;", 67 UNTIC_COMMENT("F10 function key")}, + {"kA", 78 UNTIC_COMMENT("insert-line key")}, + {"kB", 148 UNTIC_COMMENT("back-tab key")}, + {"kC", 57 UNTIC_COMMENT("clear-screen or erase key")}, + {"kD", 59 UNTIC_COMMENT("delete-character key")}, + {"kE", 63 UNTIC_COMMENT("clear-to-end-of-line key")}, + {"kF", 84 UNTIC_COMMENT("scroll-forward key")}, + {"kH", 80 UNTIC_COMMENT("last-line key")}, + {"kI", 77 UNTIC_COMMENT("insert-character key")}, + {"kL", 60 UNTIC_COMMENT("delete-line key")}, + {"kM", 62 UNTIC_COMMENT("sent by rmir or smir in insert mode")}, + {"kN", 81 UNTIC_COMMENT("next-page key")}, + {"kP", 82 UNTIC_COMMENT("prev-page key")}, + {"kR", 85 UNTIC_COMMENT("scroll-backward key")}, + {"kS", 64 UNTIC_COMMENT("clear-to-end-of-screen key")}, + {"kT", 86 UNTIC_COMMENT("set-tab key")}, + {"ka", 56 UNTIC_COMMENT("clear-all-tabs key")}, + {"kb", 55 UNTIC_COMMENT("backspace key")}, + {"kd", 61 UNTIC_COMMENT("down-arrow key")}, + {"ke", 88 UNTIC_COMMENT("leave 'keyboard_transmit' mode")}, + {"kh", 76 UNTIC_COMMENT("home key")}, + {"kl", 79 UNTIC_COMMENT("left-arrow key")}, + {"ko", 396 UNTIC_COMMENT("list of self-mapped keycaps")}, + {"kr", 83 UNTIC_COMMENT("right-arrow key")}, + {"ks", 89 UNTIC_COMMENT("enter 'keyboard_transmit' mode")}, + {"kt", 58 UNTIC_COMMENT("clear-tab key")}, + {"ku", 87 UNTIC_COMMENT("up-arrow key")}, + {"l0", 90 UNTIC_COMMENT("label on function key f0 if not f0")}, + {"l1", 91 UNTIC_COMMENT("label on function key f1 if not f1")}, + {"l2", 93 UNTIC_COMMENT("label on function key f2 if not f2")}, + {"l3", 94 UNTIC_COMMENT("label on function key f3 if not f3")}, + {"l4", 95 UNTIC_COMMENT("label on function key f4 if not f4")}, + {"l5", 96 UNTIC_COMMENT("lable on function key f5 if not f5")}, + {"l6", 97 UNTIC_COMMENT("label on function key f6 if not f6")}, + {"l7", 98 UNTIC_COMMENT("label on function key f7 if not f7")}, + {"l8", 99 UNTIC_COMMENT("label on function key f8 if not f8")}, + {"l9", 100 UNTIC_COMMENT("label on function key f9 if not f9")}, + {"la", 92 UNTIC_COMMENT("label on function key f10 if not f10")}, + {"le", 14 UNTIC_COMMENT("move left one space")}, + {"ll", 18 UNTIC_COMMENT("last line, first column (if no cup)")}, + {"ma", 397 UNTIC_COMMENT("map arrow keys rogue(1) motion keys")}, + {"mb", 26 UNTIC_COMMENT("turn on blinking")}, + {"md", 27 UNTIC_COMMENT("turn on bold (extra bright) mode")}, + {"me", 39 UNTIC_COMMENT("turn off all attributes")}, + {"mh", 30 UNTIC_COMMENT("turn on half-bright mode")}, + {"mk", 32 UNTIC_COMMENT("turn on blank mode (characters invisible)")}, + {"ml", 409 UNTIC_COMMENT("memory lock above")}, + {"mm", 102 UNTIC_COMMENT("turn on meta mode (8th-bit on)")}, + {"mo", 101 UNTIC_COMMENT("turn off meta mode")}, + {"mp", 33 UNTIC_COMMENT("turn on protected mode")}, + {"mr", 34 UNTIC_COMMENT("turn on reverse video mode")}, + {"mu", 410 UNTIC_COMMENT("memory unlock")}, + {"nd", 17 UNTIC_COMMENT("move right one space")}, + {"nl", 394 UNTIC_COMMENT("use to move down")}, + {"nw", 103 UNTIC_COMMENT("newline (behave like cr followed by lf)")}, + {"oc", 298 UNTIC_COMMENT("Set all color pairs to the original ones")}, + {"op", 297 UNTIC_COMMENT("Set default pair to its original value")}, + {"pO", 144 UNTIC_COMMENT("turn on printer for #1 bytes")}, + {"pc", 104 UNTIC_COMMENT("padding char (instead of null)")}, + {"pf", 119 UNTIC_COMMENT("turn off printer")}, + {"pk", 115 UNTIC_COMMENT("program function key #1 to type string #2")}, + {"pl", 116 UNTIC_COMMENT("program function key #1 to execute string #2")}, + {"pn", 147 UNTIC_COMMENT("program label #1 to show string #2")}, + {"po", 120 UNTIC_COMMENT("turn on printer")}, + {"ps", 118 UNTIC_COMMENT("print contents of screen")}, + {"px", 117 UNTIC_COMMENT("program function key #1 to transmit string #2")}, + {"r1", 122 UNTIC_COMMENT("reset string")}, + {"r2", 123 UNTIC_COMMENT("reset string")}, + {"r3", 124 UNTIC_COMMENT("reset string")}, + {"rP", 145 UNTIC_COMMENT("like ip but when in insert mode")}, + {"rc", 126 UNTIC_COMMENT("restore cursor to last position of sc")}, + {"rf", 125 UNTIC_COMMENT("name of reset file")}, + {"rp", 121 UNTIC_COMMENT("repeat char #1 #2 times")}, + {"rs", 393 UNTIC_COMMENT("terminal reset string")}, + {"s0", 364 UNTIC_COMMENT("Shift to code set 0 (EUC set 0, ASCII)")}, + {"s1", 365 UNTIC_COMMENT("Shift to code set 1")}, + {"s2", 366 UNTIC_COMMENT("Shift to code set 2")}, + {"s3", 367 UNTIC_COMMENT("Shift to code set 3")}, + {"sa", 131 UNTIC_COMMENT("define video attributes #1-#9 (PG9)")}, + {"sc", 128 UNTIC_COMMENT("save current cursor position")}, + {"se", 43 UNTIC_COMMENT("exit standout mode")}, + {"sf", 129 UNTIC_COMMENT("scroll text up")}, + {"so", 35 UNTIC_COMMENT("begin standout mode")}, + {"sp", 301 UNTIC_COMMENT("Set current color pair to #1")}, + {"sr", 130 UNTIC_COMMENT("scroll text down")}, + {"st", 132 UNTIC_COMMENT("set a tab in every row, current columns")}, + {"ta", 134 UNTIC_COMMENT("tab to next 8-space hardware tab stop")}, + {"te", 40 UNTIC_COMMENT("strings to end programs using cup")}, + {"ti", 28 UNTIC_COMMENT("string to start programs using cup")}, + {"ts", 135 UNTIC_COMMENT("move to status line")}, + {"u0", 287 UNTIC_COMMENT("User string #0")}, + {"u1", 288 UNTIC_COMMENT("User string #1")}, + {"u2", 289 UNTIC_COMMENT("User string #2")}, + {"u3", 290 UNTIC_COMMENT("User string #3")}, + {"u4", 291 UNTIC_COMMENT("User string #4")}, + {"u5", 292 UNTIC_COMMENT("User string #5")}, + {"u6", 293 UNTIC_COMMENT("User string #6")}, + {"u7", 294 UNTIC_COMMENT("User string #7")}, + {"u8", 295 UNTIC_COMMENT("User string #8")}, + {"u9", 296 UNTIC_COMMENT("User string #9")}, + {"uc", 136 UNTIC_COMMENT("underline char and move past it")}, + {"ue", 44 UNTIC_COMMENT("exit underline mode")}, + {"up", 19 UNTIC_COMMENT("up one line")}, + {"us", 36 UNTIC_COMMENT("begin underline mode")}, + {"vb", 45 UNTIC_COMMENT("visible bell (may not move cursor)")}, + {"ve", 16 UNTIC_COMMENT("make cursor appear normal (undo civis/cvvis)")}, + {"vi", 13 UNTIC_COMMENT("make cursor invisible")}, + {"vs", 20 UNTIC_COMMENT("make cursor very visible")}, + {"wi", 133 UNTIC_COMMENT("current window is lines #1-#2 cols #3-#4")}, + {"xl", 361 UNTIC_COMMENT("Program function key #1 to type string #2 and show string #3")}, + {"", -1 UNTIC_COMMENT(NULL)} +}; + +static int compute_cap_offset (char *cap, SLterminfo_Type *t, Tgetstr_Map_Type *map, unsigned int max_ofs) +{ + char cha, chb; + + (void) t; + cha = *cap++; chb = *cap; + + while (*map->name != 0) + { + if ((cha == *map->name) && (chb == *(map->name + 1))) + { + if (map->offset >= (int) max_ofs) return -1; + return map->offset; + } + map++; + } + return -1; +} + +char *_SLtt_tigetstr (SLterminfo_Type *t, char *cap) +{ + int offset; + + if (t == NULL) + return NULL; + + if (t->flags == SLTERMCAP) return tcap_getstr (cap, t); + + offset = compute_cap_offset (cap, t, Tgetstr_Map, t->num_string_offsets); + if (offset < 0) return NULL; + offset = make_integer (t->string_offsets + 2 * offset); + if (offset < 0) return NULL; + return t->string_table + offset; +} + +static Tgetstr_Map_Type Tgetnum_Map[] = +{ + {"BT", 30 UNTIC_COMMENT("number of buttons on mouse")}, + {"Co", 13 UNTIC_COMMENT("maximum numbers of colors on screen")}, + {"MW", 12 UNTIC_COMMENT("maxumum number of defineable windows")}, + {"NC", 15 UNTIC_COMMENT("video attributes that can't be used with colors")}, + {"Nl", 8 UNTIC_COMMENT("number of labels on screen")}, + {"Ya", 16 UNTIC_COMMENT("numbers of bytes buffered before printing")}, + {"Yb", 17 UNTIC_COMMENT("spacing of pins vertically in pins per inch")}, + {"Yc", 18 UNTIC_COMMENT("spacing of dots horizontally in dots per inch")}, + {"Yd", 19 UNTIC_COMMENT("maximum value in micro_..._address")}, + {"Ye", 20 UNTIC_COMMENT("maximum value in parm_..._micro")}, + {"Yf", 21 UNTIC_COMMENT("character size when in micro mode")}, + {"Yg", 22 UNTIC_COMMENT("line size when in micro mode")}, + {"Yh", 23 UNTIC_COMMENT("numbers of pins in print-head")}, + {"Yi", 24 UNTIC_COMMENT("horizontal resolution in units per line")}, + {"Yj", 25 UNTIC_COMMENT("vertical resolution in units per line")}, + {"Yk", 26 UNTIC_COMMENT("horizontal resolution in units per inch")}, + {"Yl", 27 UNTIC_COMMENT("vertical resolution in units per inch")}, + {"Ym", 28 UNTIC_COMMENT("print rate in chars per second")}, + {"Yn", 29 UNTIC_COMMENT("character step size when in double wide mode")}, + {"Yo", 31 UNTIC_COMMENT("number of passed for each bit-image row")}, + {"Yp", 32 UNTIC_COMMENT("type of bit-image device")}, + {"co", 0 UNTIC_COMMENT("number of columns in aline")}, + {"dB", 36 UNTIC_COMMENT("padding required for ^H")}, + {"dC", 34 UNTIC_COMMENT("pad needed for CR")}, + {"dN", 35 UNTIC_COMMENT("pad needed for LF")}, + {"dT", 37 UNTIC_COMMENT("padding required for ^I")}, + {"it", 1 UNTIC_COMMENT("tabs initially every # spaces")}, + {"kn", 38 UNTIC_COMMENT("count of function keys")}, + {"lh", 9 UNTIC_COMMENT("rows in each label")}, + {"li", 2 UNTIC_COMMENT("number of lines on screen or page")}, + {"lm", 3 UNTIC_COMMENT("lines of memory if > line. 0 => varies")}, + {"lw", 10 UNTIC_COMMENT("columns in each label")}, + {"ma", 11 UNTIC_COMMENT("maximum combined attributes terminal can handle")}, + {"pa", 14 UNTIC_COMMENT("maximum number of color-pairs on the screen")}, + {"pb", 5 UNTIC_COMMENT("lowest baud rate where padding needed")}, + {"sg", 4 UNTIC_COMMENT("number of blank chars left by smso or rmso")}, + {"ug", 33 UNTIC_COMMENT("number of blanks left by ul")}, + {"vt", 6 UNTIC_COMMENT("virtual terminal number (CB/unix)")}, + {"ws", 7 UNTIC_COMMENT("columns in status line")}, + {"", -1 UNTIC_COMMENT(NULL)} +}; + +int _SLtt_tigetnum (SLterminfo_Type *t, char *cap) +{ + int offset; + + if (t == NULL) + return -1; + + if (t->flags == SLTERMCAP) return tcap_getnum (cap, t); + + offset = compute_cap_offset (cap, t, Tgetnum_Map, t->num_numbers); + if (offset < 0) return -1; + return make_integer (t->numbers + 2 * offset); +} + +static Tgetstr_Map_Type Tgetflag_Map[] = +{ + {"5i", 22 UNTIC_COMMENT("printer won't echo on screen")}, + {"HC", 23 UNTIC_COMMENT("cursor is hard to see")}, + {"MT", 40 UNTIC_COMMENT("has meta key")}, + {"ND", 26 UNTIC_COMMENT("scrolling region is non-destructive")}, + {"NL", 41 UNTIC_COMMENT("move down with \n")}, + {"NP", 25 UNTIC_COMMENT("pad character does not exist")}, + {"NR", 24 UNTIC_COMMENT("smcup does not reverse rmcup")}, + {"YA", 30 UNTIC_COMMENT("only positive motion for hpa/mhpa caps")}, + {"YB", 31 UNTIC_COMMENT("using cr turns off micro mode")}, + {"YC", 32 UNTIC_COMMENT("printer needs operator to change character set")}, + {"YD", 33 UNTIC_COMMENT("only positive motion for vpa/mvpa caps")}, + {"YE", 34 UNTIC_COMMENT("printing in last column causes cr")}, + {"YF", 35 UNTIC_COMMENT("changing character pitch changes resolution")}, + {"YG", 36 UNTIC_COMMENT("changing line pitch changes resolution")}, + {"am", 1 UNTIC_COMMENT("terminal has automatic margins")}, + {"bs", 37 UNTIC_COMMENT("uses ^H to move left")}, + {"bw", 0 UNTIC_COMMENT("cub1 wraps from column 0 to last column")}, + {"cc", 27 UNTIC_COMMENT("terminal can re-define existing colors")}, + {"da", 11 UNTIC_COMMENT("display may be retained above the screen")}, + {"db", 12 UNTIC_COMMENT("display may be retained below the screen")}, + {"eo", 5 UNTIC_COMMENT("can erase overstrikes with a blank")}, + {"es", 16 UNTIC_COMMENT("escape can be used on the status line")}, + {"gn", 6 UNTIC_COMMENT("generic line type")}, + {"hc", 7 UNTIC_COMMENT("hardcopy terminal")}, + {"hl", 29 UNTIC_COMMENT("terminal uses only HLS color notation (tektronix)")}, + {"hs", 9 UNTIC_COMMENT("has extra status line")}, + {"hz", 18 UNTIC_COMMENT("can't print ~'s (hazeltine)")}, + {"in", 10 UNTIC_COMMENT("insert mode distinguishes nulls")}, + {"km", 8 UNTIC_COMMENT("Has a meta key, sets msb high")}, + {"mi", 13 UNTIC_COMMENT("safe to move while in insert mode")}, + {"ms", 14 UNTIC_COMMENT("safe to move while in standout mode")}, + {"nc", 39 UNTIC_COMMENT("no way to go to start of line")}, + {"ns", 38 UNTIC_COMMENT("crt cannot scroll")}, + {"nx", 21 UNTIC_COMMENT("padding won't work, xon/xoff required")}, + {"os", 15 UNTIC_COMMENT("terminal can overstrike")}, + {"pt", 42 UNTIC_COMMENT("has 8-char tabs invoked with ^I")}, + {"ul", 19 UNTIC_COMMENT("underline character overstrikes")}, + {"ut", 28 UNTIC_COMMENT("screen erased with background color")}, + {"xb", 2 UNTIC_COMMENT("beehive (f1=escape, f2=ctrl C)")}, + {"xn", 4 UNTIC_COMMENT("newline ignored after 80 cols (concept)")}, + {"xo", 20 UNTIC_COMMENT("terminal uses xon/xoff handshaking")}, + {"xr", 43 UNTIC_COMMENT("return clears the line")}, + {"xs", 3 UNTIC_COMMENT("standout not erased by overwriting (hp)")}, + {"xt", 17 UNTIC_COMMENT("tabs destructive, magic so char (t1061)")}, + {"", -1 UNTIC_COMMENT(NULL)} +}; + +int _SLtt_tigetflag (SLterminfo_Type *t, char *cap) +{ + int offset; + + if (t == NULL) return -1; + + if (t->flags == SLTERMCAP) return tcap_getflag (cap, t); + + offset = compute_cap_offset (cap, t, Tgetflag_Map, t->boolean_section_size); + + if (offset < 0) return -1; + return (int) *(t->boolean_flags + offset); +} + +/* These are my termcap routines. They only work with the TERMCAP environment + * variable. This variable must contain the termcap entry and NOT the file. + */ + +static int tcap_getflag (char *cap, SLterminfo_Type *t) +{ + char a, b; + char *f = (char *) t->boolean_flags; + char *fmax; + + if (f == NULL) return 0; + fmax = f + t->boolean_section_size; + + a = *cap; + b = *(cap + 1); + while (f < fmax) + { + if ((a == f[0]) && (b == f[1])) + return 1; + f += 2; + } + return 0; +} + +static char *tcap_get_cap (unsigned char *cap, unsigned char *caps, unsigned int len) +{ + unsigned char c0, c1; + unsigned char *caps_max; + + c0 = cap[0]; + c1 = cap[1]; + + if (caps == NULL) return NULL; + caps_max = caps + len; + while (caps < caps_max) + { + if ((c0 == caps[0]) && (c1 == caps[1])) + { + return (char *) caps + 3; + } + caps += (int) caps[2]; + } + return NULL; +} + +static int tcap_getnum (char *cap, SLterminfo_Type *t) +{ + cap = tcap_get_cap ((unsigned char *) cap, t->numbers, t->num_numbers); + if (cap == NULL) return -1; + return atoi (cap); +} + +static char *tcap_getstr (char *cap, SLterminfo_Type *t) +{ + return tcap_get_cap ((unsigned char *) cap, (unsigned char *) t->string_table, t->string_table_size); +} + +static int tcap_extract_field (unsigned char *t0) +{ + register unsigned char ch, *t = t0; + while (((ch = *t) != 0) && (ch != ':')) t++; + if (ch == ':') return (int) (t - t0); + return -1; +} + +int SLtt_Try_Termcap = 1; +static int tcap_getent (char *term, SLterminfo_Type *ti) +{ + unsigned char *termcap, ch; + unsigned char *buf, *b; + unsigned char *t; + int len; + + if (SLtt_Try_Termcap == 0) return -1; +#if 1 + /* XFREE86 xterm sets the TERMCAP environment variable to an invalid + * value. Specifically, it lacks the tc= string. + */ + if (!strncmp (term, "xterm", 5)) + return -1; +#endif + termcap = (unsigned char *) getenv ("TERMCAP"); + if ((termcap == NULL) || (*termcap == '/')) return -1; + + /* We have a termcap so lets use it provided it does not have a reference + * to another terminal via tc=. In that case, use terminfo. The alternative + * would be to parse the termcap file which I do not want to do right now. + * Besides, this is a terminfo based system and if the termcap were parsed + * terminfo would almost never get a chance to run. In addition, the tc= + * thing should not occur if tset is used to set the termcap entry. + */ + t = termcap; + while ((len = tcap_extract_field (t)) != -1) + { + if ((len > 3) && (t[0] == 't') && (t[1] == 'c') && (t[2] == '=')) + return -1; + t += (len + 1); + } + + /* malloc some extra space just in case it is needed. */ + len = strlen ((char *) termcap) + 256; + if (NULL == (buf = (unsigned char *) SLmalloc ((unsigned int) len))) return -1; + + b = buf; + + /* The beginning of the termcap entry contains the names of the entry. + * It is terminated by a colon. + */ + + ti->terminal_names = (char *) b; + t = termcap; + len = tcap_extract_field (t); + if (len < 0) + { + SLfree ((char *)buf); + return -1; + } + strncpy ((char *) b, (char *) t, (unsigned int) len); + b[len] = 0; + b += len + 1; + ti->name_section_size = len; + + /* Now, we are really at the start of the termcap entries. Point the + * termcap variable here since we want to refer to this a number of times. + */ + termcap = t + (len + 1); + + /* Process strings first. */ + ti->string_table = (char *) b; + t = termcap; + while (-1 != (len = tcap_extract_field (t))) + { + unsigned char *b1; + unsigned char *tmax; + + /* We are looking for: XX=something */ + if ((len < 4) || (t[2] != '=') || (*t == '.')) + { + t += len + 1; + continue; + } + tmax = t + len; + b1 = b; + + while (t < tmax) + { + ch = *t++; + if ((ch == '\\') && (t < tmax)) + { + t = (unsigned char *) _SLexpand_escaped_char ((char *) t, (char *) &ch); + } + else if ((ch == '^') && (t < tmax)) + { + ch = *t++; + if (ch == '?') ch = 127; + else ch = (ch | 0x20) - ('a' - 1); + } + *b++ = ch; + } + /* Null terminate it. */ + *b++ = 0; + len = (int) (b - b1); + b1[2] = (unsigned char) len; /* replace the = by the length */ + /* skip colon to next field. */ + t++; + } + ti->string_table_size = (int) (b - (unsigned char *) ti->string_table); + + /* Now process the numbers. */ + + t = termcap; + ti->numbers = b; + while (-1 != (len = tcap_extract_field (t))) + { + unsigned char *b1; + unsigned char *tmax; + + /* We are looking for: XX#NUMBER */ + if ((len < 4) || (t[2] != '#') || (*t == '.')) + { + t += len + 1; + continue; + } + tmax = t + len; + b1 = b; + + while (t < tmax) + { + *b++ = *t++; + } + /* Null terminate it. */ + *b++ = 0; + len = (int) (b - b1); + b1[2] = (unsigned char) len; /* replace the # by the length */ + t++; + } + ti->num_numbers = (int) (b - ti->numbers); + + /* Now process the flags. */ + t = termcap; + ti->boolean_flags = b; + while (-1 != (len = tcap_extract_field (t))) + { + /* We are looking for: XX#NUMBER */ + if ((len != 2) || (*t == '.') || (*t <= ' ')) + { + t += len + 1; + continue; + } + b[0] = t[0]; + b[1] = t[1]; + t += 3; + b += 2; + } + ti->boolean_section_size = (int) (b - ti->boolean_flags); + ti->flags = SLTERMCAP; + return 0; +} + + +/* These routines are provided only for backward binary compatability. + * They will vanish in V2.x + */ +char *SLtt_tigetent (char *s) +{ + return (char *) _SLtt_tigetent (s); +} + +extern char *SLtt_tigetstr (char *s, char **p) +{ + if (p == NULL) + return NULL; + return _SLtt_tigetstr ((SLterminfo_Type *) *p, s); +} + +extern int SLtt_tigetnum (char *s, char **p) +{ + if (p == NULL) + return -1; + return _SLtt_tigetnum ((SLterminfo_Type *) *p, s); +} + + diff --git a/mdk-stage1/slang/sltime.c b/mdk-stage1/slang/sltime.c new file mode 100644 index 000000000..14fc6ec16 --- /dev/null +++ b/mdk-stage1/slang/sltime.c @@ -0,0 +1,310 @@ +/* time related system calls */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include <sys/types.h> +#include <time.h> + +#if defined(__BORLANDC__) +# include <dos.h> +#endif +#if defined(__GO32__) || defined(__WATCOMC__) +# include <dos.h> +# include <bios.h> +#endif + +#include <errno.h> + +#include "slang.h" +#include "_slang.h" + +#ifdef __WIN32__ +#include <windows.h> +/* Sleep is defined badly in MSVC... */ +# ifdef _MSC_VER +# define sleep(n) _sleep((n)*1000) +# else +# ifdef sleep +# undef sleep +# endif +# define sleep(x) if(x)Sleep((x)*1000) +# endif +#endif + + +#if defined(IBMPC_SYSTEM) +/* For other system (Unix and VMS), _SLusleep is in sldisply.c */ +int _SLusleep (unsigned long s) +{ + sleep (s/1000000L); + s = s % 1000000L; + +# if defined(__WIN32__) + Sleep (s/1000); +#else +# if defined(__IBMC__) + DosSleep(s/1000); +# else +# if defined(_MSC_VER) + _sleep (s/1000); +# endif +# endif +#endif + return 0; +} +#endif + +#if defined(__IBMC__) && !defined(_AIX) +/* sleep is not a standard function in VA3. */ +unsigned int sleep (unsigned int seconds) +{ + DosSleep(1000L * ((long)seconds)); + return 0; +} +#endif + +static char *ctime_cmd (unsigned long *tt) +{ + char *t; + + t = ctime ((time_t *) tt); + t[24] = 0; /* knock off \n */ + return (t); +} + +static void sleep_cmd (void) +{ + unsigned int secs; +#if SLANG_HAS_FLOAT + unsigned long usecs; + double x; + + if (-1 == SLang_pop_double (&x, NULL, NULL)) + return; + + if (x < 0.0) + x = 0.0; + secs = (unsigned int) x; + sleep (secs); + x -= (double) secs; + usecs = (unsigned long) (1e6 * x); + if (usecs > 0) _SLusleep (usecs); +#else + if (-1 == SLang_pop_uinteger (&secs)) + return; + if (secs != 0) sleep (secs); +#endif +} + +static unsigned long _time_cmd (void) +{ + return (unsigned long) time (NULL); +} + +#if defined(__GO32__) +static char *djgpp_current_time (void) /*{{{*/ +{ + union REGS rg; + unsigned int year; + unsigned char month, day, weekday, hour, minute, sec; + char days[] = "SunMonTueWedThuFriSat"; + char months[] = "JanFebMarAprMayJunJulAugSepOctNovDec"; + static char the_date[26]; + + rg.h.ah = 0x2A; +#ifndef __WATCOMC__ + int86(0x21, &rg, &rg); + year = rg.x.cx & 0xFFFF; +#else + int386(0x21, &rg, &rg); + year = rg.x.ecx & 0xFFFF; +#endif + + month = 3 * (rg.h.dh - 1); + day = rg.h.dl; + weekday = 3 * rg.h.al; + + rg.h.ah = 0x2C; + +#ifndef __WATCOMC__ + int86(0x21, &rg, &rg); +#else + int386(0x21, &rg, &rg); +#endif + + hour = rg.h.ch; + minute = rg.h.cl; + sec = rg.h.dh; + + /* we want this form: Thu Apr 14 15:43:39 1994\n */ + sprintf(the_date, "%.3s %.3s%3d %02d:%02d:%02d %d\n", + days + weekday, months + month, + day, hour, minute, sec, year); + return the_date; +} + +/*}}}*/ + +#endif + +char *SLcurrent_time_string (void) /*{{{*/ +{ + char *the_time; +#ifndef __GO32__ + time_t myclock; + + myclock = time((time_t *) 0); + the_time = (char *) ctime(&myclock); +#else + the_time = djgpp_current_time (); +#endif + /* returns the form Sun Sep 16 01:03:52 1985\n\0 */ + the_time[24] = '\0'; + return(the_time); +} + +/*}}}*/ + +static int push_tm_struct (struct tm *tms) +{ + char *field_names [9]; + unsigned char field_types[9]; + VOID_STAR field_values [9]; + int int_values [9]; + unsigned int i; + + if (tms == NULL) + return SLang_push_null (); + + field_names [0] = "tm_sec"; int_values [0] = tms->tm_sec; + field_names [1] = "tm_min"; int_values [1] = tms->tm_min; + field_names [2] = "tm_hour"; int_values [2] = tms->tm_hour; + field_names [3] = "tm_mday"; int_values [3] = tms->tm_mday; + field_names [4] = "tm_mon"; int_values [4] = tms->tm_mon; + field_names [5] = "tm_year"; int_values [5] = tms->tm_year; + field_names [6] = "tm_wday"; int_values [6] = tms->tm_wday; + field_names [7] = "tm_yday"; int_values [7] = tms->tm_yday; + field_names [8] = "tm_isdst"; int_values [8] = tms->tm_isdst; + + for (i = 0; i < 9; i++) + { + field_types [i] = SLANG_INT_TYPE; + field_values [i] = (VOID_STAR) (int_values + i); + } + + return SLstruct_create_struct (9, field_names, field_types, field_values); +} + + +static void localtime_cmd (long *t) +{ + time_t tt = (time_t) *t; + (void) push_tm_struct (localtime (&tt)); +} + +static void gmtime_cmd (long *t) +{ +#ifdef HAVE_GMTIME + time_t tt = (time_t) *t; + (void) push_tm_struct (gmtime (&tt)); +#else + localtime_cmd (t); +#endif +} + +#ifdef HAVE_TIMES + +# ifdef HAVE_SYS_TIMES_H +# include <sys/times.h> +# endif + +#include <limits.h> + +#ifdef CLK_TCK +# define SECS_PER_TICK (1.0/(double)CLK_TCK) +#else +# ifdef CLOCKS_PER_SEC +# define SECS_PER_TICK (1.0/(double)CLOCKS_PER_SEC) +# else +# define SECS_PER_TICK (1.0/60.0) +# endif +#endif + +static void times_cmd (void) +{ + double dvals[4]; + struct tms t; + VOID_STAR field_values[4]; + char *field_names[4]; + unsigned int i; + unsigned char field_types[4]; + + (void) times (&t); + + field_names[0] = "tms_utime"; dvals[0] = (double)t.tms_utime; + field_names[1] = "tms_stime"; dvals[1] = (double)t.tms_stime; + field_names[2] = "tms_cutime"; dvals[2] = (double)t.tms_cutime; + field_names[3] = "tms_cstime"; dvals[3] = (double)t.tms_cstime; + + for (i = 0; i < 4; i++) + { + dvals[i] *= SECS_PER_TICK; + field_values[i] = (VOID_STAR) &dvals[i]; + field_types[i] = SLANG_DOUBLE_TYPE; + } + (void) SLstruct_create_struct (4, field_names, field_types, field_values); +} + +static struct tms Tic_TMS; + +static void tic_cmd (void) +{ + (void) times (&Tic_TMS); +} + +static double toc_cmd (void) +{ + struct tms t; + double d; + + (void) times (&t); + d = ((t.tms_utime - Tic_TMS.tms_utime) + + (t.tms_stime - Tic_TMS.tms_stime)) * SECS_PER_TICK; + Tic_TMS = t; + return d; +} + +#endif /* HAVE_TIMES */ + + +static SLang_Intrin_Fun_Type Time_Funs_Table [] = +{ + MAKE_INTRINSIC_1("ctime", ctime_cmd, SLANG_STRING_TYPE, SLANG_ULONG_TYPE), + MAKE_INTRINSIC_0("sleep", sleep_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("_time", _time_cmd, SLANG_ULONG_TYPE), + MAKE_INTRINSIC_0("time", SLcurrent_time_string, SLANG_STRING_TYPE), + MAKE_INTRINSIC_1("localtime", localtime_cmd, SLANG_VOID_TYPE, SLANG_LONG_TYPE), + MAKE_INTRINSIC_1("gmtime", gmtime_cmd, SLANG_VOID_TYPE, SLANG_LONG_TYPE), + +#ifdef HAVE_TIMES + MAKE_INTRINSIC_0("times", times_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("tic", tic_cmd, SLANG_VOID_TYPE), + MAKE_INTRINSIC_0("toc", toc_cmd, SLANG_DOUBLE_TYPE), +#endif + SLANG_END_INTRIN_FUN_TABLE +}; + +int _SLang_init_sltime (void) +{ +#ifdef HAVE_TIMES + (void) tic_cmd (); +#endif + return SLadd_intrin_fun_table (Time_Funs_Table, NULL); +} + diff --git a/mdk-stage1/slang/sltoken.c b/mdk-stage1/slang/sltoken.c new file mode 100644 index 000000000..d08967a24 --- /dev/null +++ b/mdk-stage1/slang/sltoken.c @@ -0,0 +1,1702 @@ +/* Copyright (c) 1998, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ +#include "slinclud.h" + +#include "slang.h" +#include "_slang.h" + +#define MAX_TOKEN_LEN 254 +#define MAX_FILE_LINE_LEN 256 + +static char Empty_Line[1] = {0}; + +static int Default_Compile_Line_Num_Info; +static char *Input_Line = Empty_Line; +static char *Input_Line_Pointer; + +static SLPreprocess_Type *This_SLpp; + +static SLang_Load_Type *LLT; + +static char *map_token_to_string (_SLang_Token_Type *tok) +{ + char *s; + static char numbuf [32]; + unsigned char type; + s = NULL; + + if (tok != NULL) type = tok->type; + else type = 0; + + switch (type) + { + case 0: + s = "??"; + break; + + case CHAR_TOKEN: + case SHORT_TOKEN: + case INT_TOKEN: + case LONG_TOKEN: + s = numbuf; + sprintf (s, "%ld", tok->v.long_val); + break; + + case UCHAR_TOKEN: + case USHORT_TOKEN: + case UINT_TOKEN: + case ULONG_TOKEN: + s = numbuf; + sprintf (s, "%lu", (unsigned long)tok->v.long_val); + break; + + case OBRACKET_TOKEN: s = "["; break; + case CBRACKET_TOKEN: s = "]"; break; + case OPAREN_TOKEN: s = "("; break; + case CPAREN_TOKEN: s = ")"; break; + case OBRACE_TOKEN: s = "{"; break; + case CBRACE_TOKEN: s = "}"; break; + case DEREF_TOKEN: s = "@"; break; + case POUND_TOKEN: s = "#"; break; + case COMMA_TOKEN: s = ","; break; + case SEMICOLON_TOKEN: s = ";"; break; + case COLON_TOKEN: s = ":"; break; + +#if SLANG_HAS_FLOAT + case FLOAT_TOKEN: + case DOUBLE_TOKEN: + case COMPLEX_TOKEN: +#endif + case IDENT_TOKEN: + if ((tok->free_sval_flag == 0) || (tok->num_refs == 0)) + break; + /* drop */ + default: + s = tok->v.s_val; + break; + } + + if (s == NULL) + { + s = numbuf; + sprintf (s, "(0x%02X)", type); + } + + return s; +} + +static char *make_line_file_error (char *buf, unsigned int buflen, + _SLang_Token_Type *tok, char *dsc, int line, char *file) +{ +#if _SLANG_HAS_DEBUG_CODE + if (tok != NULL) line = tok->line_number; +#endif + if (file == NULL) file = "??"; + + (void) _SLsnprintf (buf, buflen, "%s: found '%s', line %d, file: %s", + dsc, map_token_to_string (tok), line, file); + + return buf; +} + +void _SLparse_error(char *str, _SLang_Token_Type *tok, int flag) +{ + char buf [1024]; + + if (str == NULL) + str = "Parse Error"; + + make_line_file_error (buf, sizeof (buf), tok, str, LLT->line_num, (char *) LLT->name); + + if ((flag == 0) && SLang_Error) + return; + + SLang_verror (SL_SYNTAX_ERROR, "%s", buf); +} + +static void do_line_file_error (int line, char *file) +{ + SLang_verror (SL_SYNTAX_ERROR, + "called from line %d, file: %s", line, file); +} + +#define ALPHA_CHAR 1 +#define DIGIT_CHAR 2 +#define EXCL_CHAR 3 +#define SEP_CHAR 4 +#define OP_CHAR 5 +#define DOT_CHAR 6 +#define BOLDOT_CHAR 7 +#define DQUOTE_CHAR 8 +#define QUOTE_CHAR 9 +#define COMMENT_CHAR 10 +#define NL_CHAR 11 +#define BAD_CHAR 12 +#define WHITE_CHAR 13 + +#define CHAR_EOF 255 + +#define CHAR_CLASS(c) (Char_Type_Table[(c)][0]) +#define CHAR_DATA(c) (Char_Type_Table[(c)][1]) + +/* In this table, if a single character can represent an operator, e.g., + * '&' (BAND_TOKEN), then it must be placed before multiple-character + * operators that begin with the same character, e.g., "&=". See + * get_op_token to see how this is exploited. + * + * The third character null terminates the operator string. This is for + * the token structure. + */ +static char Operators [29][4] = +{ +#define OFS_EXCL 0 + {'!', '=', 0, NE_TOKEN}, +#define OFS_POUND 1 + {'#', 0, 0, POUND_TOKEN}, +#define OFS_BAND 2 + {'&', 0, 0, BAND_TOKEN}, + {'&', '&', 0, EOF_TOKEN}, + {'&', '=', 0, BANDEQS_TOKEN}, +#define OFS_STAR 5 + {'*', 0, 0, TIMES_TOKEN}, + {'*', '=', 0, TIMESEQS_TOKEN}, +#define OFS_PLUS 7 + {'+', 0, 0, ADD_TOKEN}, + {'+', '+', 0, PLUSPLUS_TOKEN}, + {'+', '=', 0, PLUSEQS_TOKEN}, +#define OFS_MINUS 10 + {'-', 0, 0, SUB_TOKEN}, + {'-', '-', 0, MINUSMINUS_TOKEN}, + {'-', '=', 0, MINUSEQS_TOKEN}, + {'-', '>', 0, NAMESPACE_TOKEN}, +#define OFS_DIV 14 + {'/', 0, 0, DIV_TOKEN}, + {'/', '=', 0, DIVEQS_TOKEN}, +#define OFS_LT 16 + {'<', 0, 0, LT_TOKEN}, + {'<', '=', 0, LE_TOKEN}, +#define OFS_EQS 18 + {'=', 0, 0, ASSIGN_TOKEN}, + {'=', '=', 0, EQ_TOKEN}, +#define OFS_GT 20 + {'>', 0, 0, GT_TOKEN}, + {'>', '=', 0, GE_TOKEN}, +#define OFS_AT 22 + {'@', 0, 0, DEREF_TOKEN}, +#define OFS_POW 23 + {'^', 0, 0, POW_TOKEN}, +#define OFS_BOR 24 + {'|', 0, 0, BOR_TOKEN}, + {'|', '|', 0, EOF_TOKEN}, + {'|', '=', 0, BOREQS_TOKEN}, +#define OFS_BNOT 27 + {'~', 0, 0, BNOT_TOKEN}, + { 0, 0, 0, EOF_TOKEN} +}; + +static unsigned char Char_Type_Table[256][2] = +{ + { NL_CHAR, 0 }, /* 0x0 */ { BAD_CHAR, 0 }, /* 0x1 */ + { BAD_CHAR, 0 }, /* 0x2 */ { BAD_CHAR, 0 }, /* 0x3 */ + { BAD_CHAR, 0 }, /* 0x4 */ { BAD_CHAR, 0 }, /* 0x5 */ + { BAD_CHAR, 0 }, /* 0x6 */ { BAD_CHAR, 0 }, /* 0x7 */ + { WHITE_CHAR, 0 }, /* 0x8 */ { WHITE_CHAR, 0 }, /* 0x9 */ + { NL_CHAR, 0 }, /* \n */ { WHITE_CHAR, 0 }, /* 0xb */ + { WHITE_CHAR, 0 }, /* 0xc */ { WHITE_CHAR, 0 }, /* \r */ + { BAD_CHAR, 0 }, /* 0xe */ { BAD_CHAR, 0 }, /* 0xf */ + { BAD_CHAR, 0 }, /* 0x10 */ { BAD_CHAR, 0 }, /* 0x11 */ + { BAD_CHAR, 0 }, /* 0x12 */ { BAD_CHAR, 0 }, /* 0x13 */ + { BAD_CHAR, 0 }, /* 0x14 */ { BAD_CHAR, 0 }, /* 0x15 */ + { BAD_CHAR, 0 }, /* 0x16 */ { BAD_CHAR, 0 }, /* 0x17 */ + { BAD_CHAR, 0 }, /* 0x18 */ { BAD_CHAR, 0 }, /* 0x19 */ + { BAD_CHAR, 0 }, /* 0x1a */ { BAD_CHAR, 0 }, /* 0x1b */ + { BAD_CHAR, 0 }, /* 0x1c */ { BAD_CHAR, 0 }, /* 0x1d */ + { BAD_CHAR, 0 }, /* 0x1e */ { BAD_CHAR, 0 }, /* 0x1f */ + { WHITE_CHAR, 0 }, /* 0x20 */ { EXCL_CHAR, OFS_EXCL }, /* ! */ + { DQUOTE_CHAR, 0 }, /* " */ { OP_CHAR, OFS_POUND }, /* # */ + { ALPHA_CHAR, 0 }, /* $ */ { NL_CHAR, 0 },/* % */ + { OP_CHAR, OFS_BAND }, /* & */ { QUOTE_CHAR, 0 }, /* ' */ + { SEP_CHAR, OPAREN_TOKEN }, /* ( */ { SEP_CHAR, CPAREN_TOKEN }, /* ) */ + { OP_CHAR, OFS_STAR }, /* * */ { OP_CHAR, OFS_PLUS}, /* + */ + { SEP_CHAR, COMMA_TOKEN }, /* , */ { OP_CHAR, OFS_MINUS }, /* - */ + { DOT_CHAR, 0 }, /* . */ { OP_CHAR, OFS_DIV }, /* / */ + { DIGIT_CHAR, 0 }, /* 0 */ { DIGIT_CHAR, 0 }, /* 1 */ + { DIGIT_CHAR, 0 }, /* 2 */ { DIGIT_CHAR, 0 }, /* 3 */ + { DIGIT_CHAR, 0 }, /* 4 */ { DIGIT_CHAR, 0 }, /* 5 */ + { DIGIT_CHAR, 0 }, /* 6 */ { DIGIT_CHAR, 0 }, /* 7 */ + { DIGIT_CHAR, 0 }, /* 8 */ { DIGIT_CHAR, 0 }, /* 9 */ + { SEP_CHAR, COLON_TOKEN }, /* : */ { SEP_CHAR, SEMICOLON_TOKEN }, /* ; */ + { OP_CHAR, OFS_LT }, /* < */ { OP_CHAR, OFS_EQS }, /* = */ + { OP_CHAR, OFS_GT }, /* > */ { BAD_CHAR, 0 }, /* ? */ + { OP_CHAR, OFS_AT}, /* @ */ { ALPHA_CHAR, 0 }, /* A */ + { ALPHA_CHAR, 0 }, /* B */ { ALPHA_CHAR, 0 }, /* C */ + { ALPHA_CHAR, 0 }, /* D */ { ALPHA_CHAR, 0 }, /* E */ + { ALPHA_CHAR, 0 }, /* F */ { ALPHA_CHAR, 0 }, /* G */ + { ALPHA_CHAR, 0 }, /* H */ { ALPHA_CHAR, 0 }, /* I */ + { ALPHA_CHAR, 0 }, /* J */ { ALPHA_CHAR, 0 }, /* K */ + { ALPHA_CHAR, 0 }, /* L */ { ALPHA_CHAR, 0 }, /* M */ + { ALPHA_CHAR, 0 }, /* N */ { ALPHA_CHAR, 0 }, /* O */ + { ALPHA_CHAR, 0 }, /* P */ { ALPHA_CHAR, 0 }, /* Q */ + { ALPHA_CHAR, 0 }, /* R */ { ALPHA_CHAR, 0 }, /* S */ + { ALPHA_CHAR, 0 }, /* T */ { ALPHA_CHAR, 0 }, /* U */ + { ALPHA_CHAR, 0 }, /* V */ { ALPHA_CHAR, 0 }, /* W */ + { ALPHA_CHAR, 0 }, /* X */ { ALPHA_CHAR, 0 }, /* Y */ + { ALPHA_CHAR, 0 }, /* Z */ { SEP_CHAR, OBRACKET_TOKEN }, /* [ */ + { BAD_CHAR, 0 }, /* \ */ { SEP_CHAR, CBRACKET_TOKEN }, /* ] */ + { OP_CHAR, OFS_POW }, /* ^ */ { ALPHA_CHAR, 0 }, /* _ */ + { BAD_CHAR, 0 }, /* ` */ { ALPHA_CHAR, 0 }, /* a */ + { ALPHA_CHAR, 0 }, /* b */ { ALPHA_CHAR, 0 }, /* c */ + { ALPHA_CHAR, 0 }, /* d */ { ALPHA_CHAR, 0 }, /* e */ + { ALPHA_CHAR, 0 }, /* f */ { ALPHA_CHAR, 0 }, /* g */ + { ALPHA_CHAR, 0 }, /* h */ { ALPHA_CHAR, 0 }, /* i */ + { ALPHA_CHAR, 0 }, /* j */ { ALPHA_CHAR, 0 }, /* k */ + { ALPHA_CHAR, 0 }, /* l */ { ALPHA_CHAR, 0 }, /* m */ + { ALPHA_CHAR, 0 }, /* n */ { ALPHA_CHAR, 0 }, /* o */ + { ALPHA_CHAR, 0 }, /* p */ { ALPHA_CHAR, 0 }, /* q */ + { ALPHA_CHAR, 0 }, /* r */ { ALPHA_CHAR, 0 }, /* s */ + { ALPHA_CHAR, 0 }, /* t */ { ALPHA_CHAR, 0 }, /* u */ + { ALPHA_CHAR, 0 }, /* v */ { ALPHA_CHAR, 0 }, /* w */ + { ALPHA_CHAR, 0 }, /* x */ { ALPHA_CHAR, 0 }, /* y */ + { ALPHA_CHAR, 0 }, /* z */ { SEP_CHAR, OBRACE_TOKEN }, /* { */ + { OP_CHAR, OFS_BOR }, /* | */ { SEP_CHAR, CBRACE_TOKEN }, /* } */ + { OP_CHAR, OFS_BNOT }, /* ~ */ { BAD_CHAR, 0 }, /* 0x7f */ + + { ALPHA_CHAR, 0 }, /* € */ { ALPHA_CHAR, 0 }, /* */ + { ALPHA_CHAR, 0 }, /* ‚ */ { ALPHA_CHAR, 0 }, /* ƒ */ + { ALPHA_CHAR, 0 }, /* „ */ { ALPHA_CHAR, 0 }, /* … */ + { ALPHA_CHAR, 0 }, /* † */ { ALPHA_CHAR, 0 }, /* ‡ */ + { ALPHA_CHAR, 0 }, /* ˆ */ { ALPHA_CHAR, 0 }, /* ‰ */ + { ALPHA_CHAR, 0 }, /* Š */ { ALPHA_CHAR, 0 }, /* ‹ */ + { ALPHA_CHAR, 0 }, /* Œ */ { ALPHA_CHAR, 0 }, /* */ + { ALPHA_CHAR, 0 }, /* Ž */ { ALPHA_CHAR, 0 }, /* */ + { ALPHA_CHAR, 0 }, /* */ { ALPHA_CHAR, 0 }, /* ‘ */ + { ALPHA_CHAR, 0 }, /* ’ */ { ALPHA_CHAR, 0 }, /* “ */ + { ALPHA_CHAR, 0 }, /* ” */ { ALPHA_CHAR, 0 }, /* • */ + { ALPHA_CHAR, 0 }, /* – */ { ALPHA_CHAR, 0 }, /* — */ + { ALPHA_CHAR, 0 }, /* ˜ */ { ALPHA_CHAR, 0 }, /* ™ */ + { ALPHA_CHAR, 0 }, /* š */ { ALPHA_CHAR, 0 }, /* › */ + { ALPHA_CHAR, 0 }, /* œ */ { ALPHA_CHAR, 0 }, /* */ + { ALPHA_CHAR, 0 }, /* ž */ { ALPHA_CHAR, 0 }, /* Ÿ */ + { ALPHA_CHAR, 0 }, /* */ { ALPHA_CHAR, 0 }, /* ¡ */ + { ALPHA_CHAR, 0 }, /* ¢ */ { ALPHA_CHAR, 0 }, /* £ */ + { ALPHA_CHAR, 0 }, /* ¤ */ { ALPHA_CHAR, 0 }, /* ¥ */ + { ALPHA_CHAR, 0 }, /* ¦ */ { ALPHA_CHAR, 0 }, /* § */ + { ALPHA_CHAR, 0 }, /* ¨ */ { ALPHA_CHAR, 0 }, /* © */ + { ALPHA_CHAR, 0 }, /* ª */ { ALPHA_CHAR, 0 }, /* « */ + { ALPHA_CHAR, 0 }, /* ¬ */ { ALPHA_CHAR, 0 }, /* */ + { ALPHA_CHAR, 0 }, /* ® */ { ALPHA_CHAR, 0 }, /* ¯ */ + { ALPHA_CHAR, 0 }, /* ° */ { ALPHA_CHAR, 0 }, /* ± */ + { ALPHA_CHAR, 0 }, /* ² */ { ALPHA_CHAR, 0 }, /* ³ */ + { ALPHA_CHAR, 0 }, /* ´ */ { ALPHA_CHAR, 0 }, /* µ */ + { ALPHA_CHAR, 0 }, /* ¶ */ { ALPHA_CHAR, 0 }, /* · */ + { ALPHA_CHAR, 0 }, /* ¸ */ { ALPHA_CHAR, 0 }, /* ¹ */ + { ALPHA_CHAR, 0 }, /* º */ { ALPHA_CHAR, 0 }, /* » */ + { ALPHA_CHAR, 0 }, /* ¼ */ { ALPHA_CHAR, 0 }, /* ½ */ + { ALPHA_CHAR, 0 }, /* ¾ */ { ALPHA_CHAR, 0 }, /* ¿ */ + { ALPHA_CHAR, 0 }, /* À */ { ALPHA_CHAR, 0 }, /* Á */ + { ALPHA_CHAR, 0 }, /*  */ { ALPHA_CHAR, 0 }, /* à */ + { ALPHA_CHAR, 0 }, /* Ä */ { ALPHA_CHAR, 0 }, /* Å */ + { ALPHA_CHAR, 0 }, /* Æ */ { ALPHA_CHAR, 0 }, /* Ç */ + { ALPHA_CHAR, 0 }, /* È */ { ALPHA_CHAR, 0 }, /* É */ + { ALPHA_CHAR, 0 }, /* Ê */ { ALPHA_CHAR, 0 }, /* Ë */ + { ALPHA_CHAR, 0 }, /* Ì */ { ALPHA_CHAR, 0 }, /* Í */ + { ALPHA_CHAR, 0 }, /* Î */ { ALPHA_CHAR, 0 }, /* Ï */ + { ALPHA_CHAR, 0 }, /* Ð */ { ALPHA_CHAR, 0 }, /* Ñ */ + { ALPHA_CHAR, 0 }, /* Ò */ { ALPHA_CHAR, 0 }, /* Ó */ + { ALPHA_CHAR, 0 }, /* Ô */ { ALPHA_CHAR, 0 }, /* Õ */ + { ALPHA_CHAR, 0 }, /* Ö */ { ALPHA_CHAR, 0 }, /* × */ + { ALPHA_CHAR, 0 }, /* Ø */ { ALPHA_CHAR, 0 }, /* Ù */ + { ALPHA_CHAR, 0 }, /* Ú */ { ALPHA_CHAR, 0 }, /* Û */ + { ALPHA_CHAR, 0 }, /* Ü */ { ALPHA_CHAR, 0 }, /* Ý */ + { ALPHA_CHAR, 0 }, /* Þ */ { ALPHA_CHAR, 0 }, /* ß */ + { ALPHA_CHAR, 0 }, /* à */ { ALPHA_CHAR, 0 }, /* á */ + { ALPHA_CHAR, 0 }, /* â */ { ALPHA_CHAR, 0 }, /* ã */ + { ALPHA_CHAR, 0 }, /* ä */ { ALPHA_CHAR, 0 }, /* å */ + { ALPHA_CHAR, 0 }, /* æ */ { ALPHA_CHAR, 0 }, /* ç */ + { ALPHA_CHAR, 0 }, /* è */ { ALPHA_CHAR, 0 }, /* é */ + { ALPHA_CHAR, 0 }, /* ê */ { ALPHA_CHAR, 0 }, /* ë */ + { ALPHA_CHAR, 0 }, /* ì */ { ALPHA_CHAR, 0 }, /* í */ + { ALPHA_CHAR, 0 }, /* î */ { ALPHA_CHAR, 0 }, /* ï */ + { ALPHA_CHAR, 0 }, /* ð */ { ALPHA_CHAR, 0 }, /* ñ */ + { ALPHA_CHAR, 0 }, /* ò */ { ALPHA_CHAR, 0 }, /* ó */ + { ALPHA_CHAR, 0 }, /* ô */ { ALPHA_CHAR, 0 }, /* õ */ + { ALPHA_CHAR, 0 }, /* ö */ { ALPHA_CHAR, 0 }, /* ÷ */ + { ALPHA_CHAR, 0 }, /* ø */ { ALPHA_CHAR, 0 }, /* ù */ + { ALPHA_CHAR, 0 }, /* ú */ { ALPHA_CHAR, 0 }, /* û */ + { ALPHA_CHAR, 0 }, /* ü */ { ALPHA_CHAR, 0 }, /* ý */ + { ALPHA_CHAR, 0 }, /* þ */ { ALPHA_CHAR, 0 }, /* ÿ */ +}; + +int _SLcheck_identifier_syntax (char *name) +{ + unsigned char *p; + + p = (unsigned char *) name; + if (ALPHA_CHAR == Char_Type_Table[*p][0]) while (1) + { + unsigned ch; + unsigned char type; + + ch = *++p; + + type = Char_Type_Table [ch][0]; + if ((type != ALPHA_CHAR) && (type != DIGIT_CHAR)) + { + if (ch == 0) + return 0; + break; + } + } + + SLang_verror (SL_SYNTAX_ERROR, + "Name %s contains an illegal character", name); + return -1; +} + +static unsigned char prep_get_char (void) +{ + register unsigned char ch; + + if (0 != (ch = *Input_Line_Pointer++)) + return ch; + + Input_Line_Pointer--; + return 0; +} + +static void unget_prep_char (unsigned char ch) +{ + if ((Input_Line_Pointer != Input_Line) + && (ch != 0)) + Input_Line_Pointer--; + /* *Input_Line_Pointer = ch; -- Do not modify the Input_Line */ +} + +#include "keywhash.c" + +static int get_ident_token (_SLang_Token_Type *tok, unsigned char *s, unsigned int len) +{ + unsigned char ch; + unsigned char type; + Keyword_Table_Type *table; + + while (1) + { + ch = prep_get_char (); + type = CHAR_CLASS (ch); + if ((type != ALPHA_CHAR) && (type != DIGIT_CHAR)) + { + unget_prep_char (ch); + break; + } + s [len++] = ch; + } + + s[len] = 0; + + /* check if keyword */ + table = is_keyword ((char *) s, len); + if (table != NULL) + { + tok->v.s_val = table->name; + return (tok->type = table->type); + } + + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, len, &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = IDENT_TOKEN); +} + +static int get_number_token (_SLang_Token_Type *tok, unsigned char *s, unsigned int len) +{ + unsigned char ch; + unsigned char type; + + /* Look for pattern [0-9.xX]*([eE][-+]?[digits])?[ijfhul]? */ + while (1) + { + ch = prep_get_char (); + + type = CHAR_CLASS (ch); + if ((type != DIGIT_CHAR) && (type != DOT_CHAR)) + { + if ((ch != 'x') && (ch != 'X')) + break; + /* It must be hex */ + do + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + + s[len++] = ch; + ch = prep_get_char (); + type = CHAR_CLASS (ch); + } + while ((type == DIGIT_CHAR) || (type == ALPHA_CHAR)); + break; + } + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s [len++] = ch; + } + + /* At this point, type and ch are synchronized */ + + if ((ch == 'e') || (ch == 'E')) + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s[len++] = ch; + ch = prep_get_char (); + if ((ch == '+') || (ch == '-')) + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s[len++] = ch; + ch = prep_get_char (); + } + + while (DIGIT_CHAR == (type = CHAR_CLASS(ch))) + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s[len++] = ch; + ch = prep_get_char (); + } + } + + while (ALPHA_CHAR == type) + { + if (len == (MAX_TOKEN_LEN - 1)) + goto too_long_return_error; + s[len++] = ch; + ch = prep_get_char (); + type = CHAR_CLASS(ch); + } + + unget_prep_char (ch); + s[len] = 0; + + switch (SLang_guess_type ((char *) s)) + { + default: + tok->v.s_val = (char *) s; + _SLparse_error ("Not a number", tok, 0); + return (tok->type = EOF_TOKEN); + +#if SLANG_HAS_FLOAT + case SLANG_FLOAT_TYPE: + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, len, &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = FLOAT_TOKEN); + + case SLANG_DOUBLE_TYPE: + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, len, &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = DOUBLE_TOKEN); +#endif +#if SLANG_HAS_COMPLEX + case SLANG_COMPLEX_TYPE: + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, len, &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = COMPLEX_TOKEN); +#endif + case SLANG_CHAR_TYPE: + tok->v.long_val = (char)SLatol (s); + return tok->type = CHAR_TOKEN; + case SLANG_UCHAR_TYPE: + tok->v.long_val = (unsigned char)SLatol (s); + return tok->type = UCHAR_TOKEN; + case SLANG_SHORT_TYPE: + tok->v.long_val = (short)SLatol (s); + return tok->type = SHORT_TOKEN; + case SLANG_USHORT_TYPE: + tok->v.long_val = (unsigned short)SLatoul (s); + return tok->type = USHORT_TOKEN; + case SLANG_INT_TYPE: + tok->v.long_val = (int)SLatol (s); + return tok->type = INT_TOKEN; + case SLANG_UINT_TYPE: + tok->v.long_val = (unsigned int)SLatoul (s); + return tok->type = UINT_TOKEN; + case SLANG_LONG_TYPE: + tok->v.long_val = SLatol (s); + return tok->type = LONG_TOKEN; + case SLANG_ULONG_TYPE: + tok->v.long_val = SLatoul (s); + return tok->type = ULONG_TOKEN; + } + + too_long_return_error: + _SLparse_error ("Number too long for buffer", NULL, 0); + return (tok->type == EOF_TOKEN); +} + +static int get_op_token (_SLang_Token_Type *tok, char ch) +{ + unsigned int offset; + char second_char; + unsigned char type; + char *name; + + /* operators are: + - / * ++ -- += -= = == != > < >= <= | etc.. + * These lex to the longest valid operator token. + */ + + offset = CHAR_DATA((unsigned char) ch); + if (0 == Operators [offset][1]) + { + name = Operators [offset]; + type = name [3]; + } + else + { + type = EOF_TOKEN; + name = NULL; + } + + second_char = prep_get_char (); + do + { + if (second_char == Operators[offset][1]) + { + name = Operators [offset]; + type = name [3]; + break; + } + offset++; + } + while (ch == Operators[offset][0]); + + tok->type = type; + + if (type == EOF_TOKEN) + { + _SLparse_error ("Operator not supported", NULL, 0); + return type; + } + + tok->v.s_val = name; + + if (name[1] == 0) + unget_prep_char (second_char); + + return type; +} + +/* If this returns non-zero, then it is a binary string */ +static int expand_escaped_string (register char *s, + register char *t, register char *tmax, + unsigned int *lenp) +{ + char *s0; + int is_binary = 0; + char ch; + + s0 = s; + while (t < tmax) + { + ch = *t++; + if (ch == '\\') + { + t = _SLexpand_escaped_char (t, &ch); + if (ch == 0) is_binary = 1; + } + *s++ = ch; + } + *s = 0; + + *lenp = (unsigned char) (s - s0); + return is_binary; +} + +static int get_string_token (_SLang_Token_Type *tok, unsigned char quote_char, + unsigned char *s) +{ + unsigned char ch; + unsigned int len = 0; + int has_quote = 0; + int is_binary; + + while (1) + { + ch = prep_get_char (); + if (ch == 0) + { + _SLparse_error("Expecting quote-character", NULL, 0); + return (tok->type = EOF_TOKEN); + } + if (ch == quote_char) break; + + s[len++] = ch; + + if (len == (MAX_TOKEN_LEN - 1)) + { + _SLparse_error ("String too long for buffer", NULL, 0); + return (tok->type == EOF_TOKEN); + } + + if (ch == '\\') + { + has_quote = 1; + ch = prep_get_char (); + s[len++] = ch; + } + } + + s[len] = 0; + + if (has_quote) + is_binary = expand_escaped_string ((char *) s, (char *)s, (char *)s + len, &len); + else is_binary = 0; + + if ('"' == quote_char) + { + tok->free_sval_flag = 1; + if (is_binary) + { + tok->v.b_val = SLbstring_create (s, len); + return tok->type = BSTRING_TOKEN; + } + else + { + tok->v.s_val = _SLstring_make_hashed_string ((char *)s, + len, + &tok->hash); + tok->free_sval_flag = 1; + return (tok->type = STRING_TOKEN); + } + } + + /* else single character */ + if (s[1] != 0) + { + _SLparse_error("Single char expected", NULL, 0); + return (tok->type = EOF_TOKEN); + } + + tok->v.long_val = s[0]; + return (tok->type = UCHAR_TOKEN); +} + +static int extract_token (_SLang_Token_Type *tok, unsigned char ch, unsigned char t) +{ + unsigned char s [MAX_TOKEN_LEN]; + unsigned int slen; + + s[0] = (char) ch; + slen = 1; + + switch (t) + { + case ALPHA_CHAR: + return get_ident_token (tok, s, slen); + + case OP_CHAR: + return get_op_token (tok, ch); + + case DIGIT_CHAR: + return get_number_token (tok, s, slen); + + case EXCL_CHAR: + ch = prep_get_char (); + s [slen++] = ch; + t = CHAR_CLASS(ch); + if (t == ALPHA_CHAR) return get_ident_token (tok, s, slen); + if (t == OP_CHAR) + { + unget_prep_char (ch); + return get_op_token (tok, '!'); + } + _SLparse_error("Misplaced !", NULL, 0); + return -1; + + case DOT_CHAR: + ch = prep_get_char (); + if (DIGIT_CHAR == CHAR_CLASS(ch)) + { + s [slen++] = ch; + return get_number_token (tok, s, slen); + } + unget_prep_char (ch); + return (tok->type = DOT_TOKEN); + + case SEP_CHAR: + return (tok->type = CHAR_DATA(ch)); + + case DQUOTE_CHAR: + case QUOTE_CHAR: + return get_string_token (tok, ch, s); + + default: + _SLparse_error("Invalid character", NULL, 0); + return (tok->type = EOF_TOKEN); + } +} + +int _SLget_rpn_token (_SLang_Token_Type *tok) +{ + unsigned char ch; + + tok->v.s_val = "??"; + while ((ch = *Input_Line_Pointer) != 0) + { + unsigned char t; + + Input_Line_Pointer++; + if (WHITE_CHAR == (t = CHAR_CLASS(ch))) + continue; + + if (NL_CHAR == t) + break; + + return extract_token (tok, ch, t); + } + Input_Line_Pointer = Empty_Line; + return EOF_TOKEN; +} + +int _SLget_token (_SLang_Token_Type *tok) +{ + unsigned char ch; + unsigned char t; + + tok->num_refs = 1; + tok->free_sval_flag = 0; + tok->v.s_val = "??"; +#if _SLANG_HAS_DEBUG_CODE + tok->line_number = LLT->line_num; +#endif + if (SLang_Error || (Input_Line == NULL)) + return (tok->type = EOF_TOKEN); + + while (1) + { + ch = *Input_Line_Pointer++; + if (WHITE_CHAR == (t = CHAR_CLASS (ch))) + continue; + + if (t != NL_CHAR) + return extract_token (tok, ch, t); + + do + { + LLT->line_num++; +#if _SLANG_HAS_DEBUG_CODE + tok->line_number++; +#endif + Input_Line = LLT->read(LLT); + if ((NULL == Input_Line) || SLang_Error) + { + Input_Line_Pointer = Input_Line = NULL; + return (tok->type = EOF_TOKEN); + } + } + while (0 == SLprep_line_ok(Input_Line, This_SLpp)); + + Input_Line_Pointer = Input_Line; + if (*Input_Line_Pointer == '.') + { + Input_Line_Pointer++; + return tok->type = RPN_TOKEN; + } + } +} + +static int prep_exists_function (char *line, char comment) +{ + char buf[MAX_FILE_LINE_LEN], *b, *bmax; + unsigned char ch; + + bmax = buf + (sizeof (buf) - 1); + + while (1) + { + /* skip whitespace */ + while ((ch = (unsigned char) *line), + ch && (ch != '\n') && (ch <= ' ')) + line++; + + if ((ch <= '\n') + || (ch == (unsigned char) comment)) break; + + b = buf; + while ((ch = (unsigned char) *line) > ' ') + { + if (b < bmax) *b++ = (char) ch; + line++; + } + *b = 0; + + if (SLang_is_defined (buf)) + return 1; + } + + return 0; +} + +static int prep_eval_expr (char *expr) +{ + int ret; + + if (0 != SLang_load_string (expr)) + return -1; + if (-1 == SLang_pop_integer (&ret)) + return -1; + return (ret != 0); +} + + +int SLang_load_object (SLang_Load_Type *x) +{ + SLPreprocess_Type this_pp; + SLPreprocess_Type *save_this_pp; + SLang_Load_Type *save_llt; + char *save_input_line, *save_input_line_ptr; +#if _SLANG_HAS_DEBUG_CODE + int save_compile_line_num_info; +#endif + int save_auto_declare_variables; + + if (SLprep_exists_hook == NULL) + SLprep_exists_hook = prep_exists_function; + + if (_SLprep_eval_hook == NULL) + _SLprep_eval_hook = prep_eval_expr; + + if (-1 == SLprep_open_prep (&this_pp)) return -1; + + if (-1 == _SLcompile_push_context (x)) + return -1; + +#if _SLANG_HAS_DEBUG_CODE + save_compile_line_num_info = _SLang_Compile_Line_Num_Info; +#endif + save_this_pp = This_SLpp; + save_input_line = Input_Line; + save_input_line_ptr = Input_Line_Pointer; + save_llt = LLT; + save_auto_declare_variables = _SLang_Auto_Declare_Globals; + + This_SLpp = &this_pp; + Input_Line_Pointer = Input_Line = Empty_Line; + LLT = x; + + x->line_num = 0; + x->parse_level = 0; + _SLang_Auto_Declare_Globals = x->auto_declare_globals; + +#if _SLANG_HAS_DEBUG_CODE + _SLang_Compile_Line_Num_Info = Default_Compile_Line_Num_Info; +#endif + + _SLparse_start (x); + if (SLang_Error) + do_line_file_error (x->line_num, x->name); + + _SLang_Auto_Declare_Globals = save_auto_declare_variables; + + if (SLang_Error) SLang_restart (0); + + (void) _SLcompile_pop_context (); + + Input_Line = save_input_line; + Input_Line_Pointer = save_input_line_ptr; + LLT = save_llt; + This_SLpp = save_this_pp; + +#if _SLANG_HAS_DEBUG_CODE + _SLang_Compile_Line_Num_Info = save_compile_line_num_info; +#endif + + if (SLang_Error) return -1; + return 0; +} + +SLang_Load_Type *SLallocate_load_type (char *name) +{ + SLang_Load_Type *x; + + if (NULL == (x = (SLang_Load_Type *)SLmalloc (sizeof (SLang_Load_Type)))) + return NULL; + memset ((char *) x, 0, sizeof (SLang_Load_Type)); + + if (name == NULL) name = ""; + + x->name = SLang_create_slstring (name); + if (x->name == NULL) + { + SLfree ((char *) x); + return NULL; + } + return x; +} + +void SLdeallocate_load_type (SLang_Load_Type *x) +{ + if (x != NULL) + { + SLang_free_slstring (x->name); + SLfree ((char *) x); + } +} + +typedef struct +{ + char *string; + char *ptr; +} +String_Client_Data_Type; + +static char *read_from_string (SLang_Load_Type *x) +{ + String_Client_Data_Type *data; + char *s, *s1, ch; + + data = (String_Client_Data_Type *)x->client_data; + s1 = s = data->ptr; + + if (*s == 0) + return NULL; + + while ((ch = *s) != 0) + { + s++; + if (ch == '\n') + break; + } + + data->ptr = s; + return s1; +} + +int SLang_load_string (char *string) +{ + SLang_Load_Type *x; + String_Client_Data_Type data; + int ret; + + if (string == NULL) + return -1; + + /* Grab a private copy in case loading modifies string */ + if (NULL == (string = SLang_create_slstring (string))) + return -1; + + /* To avoid creating a static data space for every string loaded, + * all string objects will be regarded as identical. So, identify + * all of them by ***string*** + */ + if (NULL == (x = SLallocate_load_type ("***string***"))) + { + SLang_free_slstring (string); + return -1; + } + + x->client_data = (VOID_STAR) &data; + x->read = read_from_string; + + data.ptr = data.string = string; + if (-1 == (ret = SLang_load_object (x))) + SLang_verror (SLang_Error, "called from eval: %s", string); + + SLang_free_slstring (string); + SLdeallocate_load_type (x); + return ret; +} + +typedef struct +{ + char *buf; + FILE *fp; +} +File_Client_Data_Type; + +char *SLang_User_Prompt; +static char *read_from_file (SLang_Load_Type *x) +{ + FILE *fp; + File_Client_Data_Type *c; + + c = (File_Client_Data_Type *)x->client_data; + fp = c->fp; + + if ((fp == stdin) && (SLang_User_Prompt != NULL)) + { + fputs (SLang_User_Prompt, stdout); + fflush (stdout); + } + + return fgets (c->buf, MAX_FILE_LINE_LEN, c->fp); +} + +/* Note that file could be freed from Slang during run of this routine + * so get it and store it !! (e.g., autoloading) + */ +int (*SLang_Load_File_Hook) (char *); +int SLang_load_file (char *f) +{ + File_Client_Data_Type client_data; + SLang_Load_Type *x; + char *name, *buf; + FILE *fp; + + if (SLang_Load_File_Hook != NULL) + return (*SLang_Load_File_Hook) (f); + + if (f == NULL) name = "<stdin>"; else name = f; + + name = SLang_create_slstring (name); + if (name == NULL) + return -1; + + if (NULL == (x = SLallocate_load_type (name))) + { + SLang_free_slstring (name); + return -1; + } + + buf = NULL; + + if (f != NULL) + fp = fopen (f, "r"); + else + fp = stdin; + + if (fp == NULL) + SLang_verror (SL_OBJ_NOPEN, "Unable to open %s", name); + else if (NULL != (buf = SLmalloc (MAX_FILE_LINE_LEN + 1))) + { + client_data.fp = fp; + client_data.buf = buf; + x->client_data = (VOID_STAR) &client_data; + x->read = read_from_file; + + (void) SLang_load_object (x); + } + + if ((fp != NULL) && (fp != stdin)) + fclose (fp); + + SLfree (buf); + SLang_free_slstring (name); + SLdeallocate_load_type (x); + + if (SLang_Error) + return -1; + + return 0; +} + +int SLang_guess_type (char *t) +{ + char *p; + register char ch; + int modifier = 0; + + if (*t == '-') t++; + p = t; + +#if SLANG_HAS_FLOAT + if (*p != '.') + { +#endif + modifier = 0; + while ((*p >= '0') && (*p <= '9')) p++; + if (t == p) return (SLANG_STRING_TYPE); + if ((*p == 'x') && (p == t + 1)) /* 0x?? */ + { + modifier |= 8; + p++; + while (ch = *p, + ((ch >= '0') && (ch <= '9')) + || (((ch | 0x20) >= 'a') && ((ch | 0x20) <= 'f'))) p++; + } + + /* Now look for UL, LU, UH, HU, L, H modifiers */ + while ((ch = *p) != 0) + { + ch |= 0x20; + if (ch == 'h') modifier |= 1; + else if (ch == 'l') modifier |= 2; + else if (ch == 'u') modifier |= 4; + else break; + p++; + } + if ((1|2) == (modifier & (1|2))) /* hl present */ + return SLANG_STRING_TYPE; + + if (ch == 0) + { + if ((modifier & 0x7) == 0) return SLANG_INT_TYPE; + if (modifier & 4) + { + if (modifier & 1) return SLANG_USHORT_TYPE; + if (modifier & 2) return SLANG_ULONG_TYPE; + return SLANG_UINT_TYPE; + } + if (modifier & 1) return SLANG_SHORT_TYPE; + if (modifier & 2) return SLANG_LONG_TYPE; + return SLANG_INT_TYPE; + } + + if (modifier) return SLANG_STRING_TYPE; +#if SLANG_HAS_FLOAT + } + + /* now down to double case */ + if (*p == '.') + { + p++; + while ((*p >= '0') && (*p <= '9')) p++; + } + if (*p == 0) return(SLANG_DOUBLE_TYPE); + if ((*p != 'e') && (*p != 'E')) + { +# if SLANG_HAS_COMPLEX + if (((*p == 'i') || (*p == 'j')) + && (p[1] == 0)) + return SLANG_COMPLEX_TYPE; +# endif + if (((*p | 0x20) == 'f') && (p[1] == 0)) + return SLANG_FLOAT_TYPE; + + return SLANG_STRING_TYPE; + } + + p++; + if ((*p == '-') || (*p == '+')) p++; + while ((*p >= '0') && (*p <= '9')) p++; + if (*p != 0) + { +# if SLANG_HAS_COMPLEX + if (((*p == 'i') || (*p == 'j')) + && (p[1] == 0)) + return SLANG_COMPLEX_TYPE; +# endif + if (((*p | 0x20) == 'f') && (p[1] == 0)) + return SLANG_FLOAT_TYPE; + + return SLANG_STRING_TYPE; + } + return SLANG_DOUBLE_TYPE; +#else + return SLANG_STRING_TYPE; +#endif /* SLANG_HAS_FLOAT */ +} + +static int hex_atoul (unsigned char *s, unsigned long *ul) +{ + register unsigned char ch; + register unsigned long value; + register int base; + + s++; /* skip the leading 0 */ + + /* look for 'x' which indicates hex */ + if ((*s | 0x20) == 'x') + { + base = 16; + s++; + if (*s == 0) + { + SLang_Error = SL_SYNTAX_ERROR; + return -1; + } + } + else base = 8; + + value = 0; + while ((ch = *s++) != 0) + { + char ch1 = ch | 0x20; + switch (ch1) + { + default: + SLang_Error = SL_SYNTAX_ERROR; + break; + + case 'u': + case 'l': + case 'h': + *ul = value; + return 0; + + case '8': + case '9': + if (base != 16) SLang_Error = SL_SYNTAX_ERROR; + /* drop */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + ch1 -= '0'; + break; + + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + if (base != 16) SLang_Error = SL_SYNTAX_ERROR; + ch1 = (ch1 - 'a') + 10; + break; + } + value = value * base + ch1; + } + *ul = value; + return 0; +} + +/* Note: These routines do not check integer overflow. I would use the C + * library functions atol and atoul but some implementations check overflow + * and some do not. The following implementations provide a consistent + * behavior. + */ +unsigned long SLatoul (unsigned char *s) +{ + int sign; + unsigned long value; + + if (*s == '-') sign = -1; + else + { + sign = 1; + if (*s == '+') s++; + } + + if (*s == '0') + { + if (-1 == hex_atoul (s, &value)) + return (unsigned long) -1; + } + else + { + while (WHITE_CHAR == CHAR_CLASS(*s)) + s++; + + value = 0; + while (DIGIT_CHAR == CHAR_CLASS(*s)) + { + value = value * 10 + (unsigned long) (*s - '0'); + s++; + } + } + + if (sign == -1) + value = (unsigned long)-1L * value; + + return value; +} + +long SLatol (unsigned char *s) +{ + while (WHITE_CHAR == CHAR_CLASS(*s)) + s++; + + if (*s == '-') + { + long value = (long) SLatoul (s+1); + return -value; + } + return (long) SLatoul (s); +} + +int SLatoi (unsigned char *s) +{ + return (int) SLatol (s); +} + +static char *check_byte_compiled_token (char *buf) +{ + unsigned int len_lo, len_hi, len; + + len_lo = (unsigned char) *Input_Line_Pointer++; + if ((len_lo < 32) + || ((len_hi = (unsigned char)*Input_Line_Pointer++) < 32) + || ((len = (len_lo - 32) | ((len_hi - 32) << 7)) >= MAX_TOKEN_LEN)) + { + SLang_doerror ("Byte compiled file appears corrupt"); + return NULL; + } + + SLMEMCPY (buf, Input_Line_Pointer, len); + buf += len; + Input_Line_Pointer += len; + *buf = 0; + return buf; +} + +void _SLcompile_byte_compiled (void) +{ + unsigned char type; + _SLang_Token_Type tok; + char buf[MAX_TOKEN_LEN]; + char *ebuf; + unsigned int len; + + memset ((char *) &tok, 0, sizeof (_SLang_Token_Type)); + + while (SLang_Error == 0) + { + top_of_switch: + type = (unsigned char) *Input_Line_Pointer++; + switch (type) + { + case '\n': + case 0: + if (NULL == (Input_Line = LLT->read(LLT))) + { + Input_Line_Pointer = Input_Line = NULL; + return; + } + Input_Line_Pointer = Input_Line; + goto top_of_switch; + + case LINE_NUM_TOKEN: + case CHAR_TOKEN: + case UCHAR_TOKEN: + case SHORT_TOKEN: + case USHORT_TOKEN: + case INT_TOKEN: + case UINT_TOKEN: + case LONG_TOKEN: + case ULONG_TOKEN: + if (NULL == check_byte_compiled_token (buf)) + return; + tok.v.long_val = atol (buf); + break; + + case COMPLEX_TOKEN: + case FLOAT_TOKEN: + case DOUBLE_TOKEN: + if (NULL == check_byte_compiled_token (buf)) + return; + tok.v.s_val = buf; + break; + + case ESC_STRING_TOKEN: + if (NULL == (ebuf = check_byte_compiled_token (buf))) + return; + tok.v.s_val = buf; + if (expand_escaped_string (buf, buf, ebuf, &len)) + { + tok.hash = len; + type = _BSTRING_TOKEN; + } + else + { + tok.hash = _SLstring_hash ((unsigned char *)buf, (unsigned char *)buf + len); + type = STRING_TOKEN; + } + break; + + case TMP_TOKEN: + case DEFINE_TOKEN: + case DEFINE_STATIC_TOKEN: + case DEFINE_PRIVATE_TOKEN: + case DEFINE_PUBLIC_TOKEN: + case DOT_TOKEN: + case STRING_TOKEN: + case IDENT_TOKEN: + case _REF_TOKEN: + case _DEREF_ASSIGN_TOKEN: + case _SCALAR_ASSIGN_TOKEN: + case _SCALAR_PLUSEQS_TOKEN: + case _SCALAR_MINUSEQS_TOKEN: + case _SCALAR_TIMESEQS_TOKEN: + case _SCALAR_DIVEQS_TOKEN: + case _SCALAR_BOREQS_TOKEN: + case _SCALAR_BANDEQS_TOKEN: + case _SCALAR_PLUSPLUS_TOKEN: + case _SCALAR_POST_PLUSPLUS_TOKEN: + case _SCALAR_MINUSMINUS_TOKEN: + case _SCALAR_POST_MINUSMINUS_TOKEN: + case _STRUCT_ASSIGN_TOKEN: + case _STRUCT_PLUSEQS_TOKEN: + case _STRUCT_MINUSEQS_TOKEN: + case _STRUCT_TIMESEQS_TOKEN: + case _STRUCT_DIVEQS_TOKEN: + case _STRUCT_BOREQS_TOKEN: + case _STRUCT_BANDEQS_TOKEN: + case _STRUCT_POST_MINUSMINUS_TOKEN: + case _STRUCT_MINUSMINUS_TOKEN: + case _STRUCT_POST_PLUSPLUS_TOKEN: + case _STRUCT_PLUSPLUS_TOKEN: + if (NULL == (ebuf = check_byte_compiled_token (buf))) + return; + tok.v.s_val = buf; + tok.hash = _SLstring_hash ((unsigned char *)buf, (unsigned char *)ebuf); + break; + + default: + break; + } + tok.type = type; + + (*_SLcompile_ptr) (&tok); + } +} + +static int escape_string (unsigned char *s, unsigned char *smax, + unsigned char *buf, unsigned char *buf_max, + int *is_escaped) +{ + unsigned char ch; + + *is_escaped = 0; + while (buf < buf_max) + { + if (s == smax) + { + *buf = 0; + return 0; + } + + ch = *s++; + switch (ch) + { + default: + *buf++ = ch; + break; + + case 0: + *buf++ = '\\'; + if (buf < buf_max) *buf++ = 'x'; + if (buf < buf_max) *buf++ = '0'; + if (buf < buf_max) *buf++ = '0'; + *is_escaped = 1; + break; /* return 0; */ + + case '\n': + *buf++ = '\\'; + if (buf < buf_max) *buf++ = 'n'; + *is_escaped = 1; + break; + + case '\r': + *buf++ = '\\'; + if (buf < buf_max) *buf++ = 'r'; + *is_escaped = 1; + break; + + case 0x1A: /* ^Z */ + *buf++ = '\\'; + if (buf < buf_max) *buf++ = 'x'; + if (buf < buf_max) *buf++ = '1'; + if (buf < buf_max) *buf++ = 'A'; + *is_escaped = 1; + break; + + case '\\': + *buf++ = ch; + if (buf < buf_max) *buf++ = ch; + *is_escaped = 1; + break; + } + } + _SLparse_error ("String too long to byte-compile", NULL, 0); + return -1; +} + +static FILE *Byte_Compile_Fp; +static unsigned int Byte_Compile_Line_Len; + +static int bytecomp_write_data (char *buf, unsigned int len) +{ + char *err = "Write Error"; + + if ((Byte_Compile_Line_Len + len + 1) >= MAX_FILE_LINE_LEN) + { + if (EOF == fputs ("\n", Byte_Compile_Fp)) + { + SLang_doerror (err); + return -1; + } + Byte_Compile_Line_Len = 0; + } + + if (EOF == fputs (buf, Byte_Compile_Fp)) + { + SLang_doerror (err); + return -1; + } + Byte_Compile_Line_Len += len; + return 0; +} + +static void byte_compile_token (_SLang_Token_Type *tok) +{ + unsigned char buf [MAX_TOKEN_LEN + 4], *buf_max; + unsigned int len; + char *b3; + int is_escaped; + unsigned char *s; + + if (SLang_Error) return; + + buf [0] = (unsigned char) tok->type; + buf [1] = 0; + + buf_max = buf + sizeof(buf); + b3 = (char *) buf + 3; + + switch (tok->type) + { + case LINE_NUM_TOKEN: + case CHAR_TOKEN: + case SHORT_TOKEN: + case INT_TOKEN: + case LONG_TOKEN: + sprintf (b3, "%ld", tok->v.long_val); + break; + + case UCHAR_TOKEN: + case USHORT_TOKEN: + case UINT_TOKEN: + case ULONG_TOKEN: + sprintf (b3, "%lu", tok->v.long_val); + break; + + case _BSTRING_TOKEN: + s = (unsigned char *) tok->v.s_val; + len = (unsigned int) tok->hash; + + if (-1 == escape_string (s, s + len, + (unsigned char *)b3, buf_max, + &is_escaped)) + return; + + buf[0] = ESC_STRING_TOKEN; + break; + + case BSTRING_TOKEN: + if (NULL == (s = SLbstring_get_pointer (tok->v.b_val, &len))) + return; + + if (-1 == escape_string (s, s + len, + (unsigned char *)b3, buf_max, + &is_escaped)) + return; + buf[0] = ESC_STRING_TOKEN; + break; + + case STRING_TOKEN: + s = (unsigned char *)tok->v.s_val; + + if (-1 == escape_string (s, s + strlen ((char *)s), + (unsigned char *)b3, buf_max, + &is_escaped)) + return; + + if (is_escaped) + buf[0] = ESC_STRING_TOKEN; + break; + + /* a _SCALAR_* token is attached to an identifier. */ + case _DEREF_ASSIGN_TOKEN: + case _SCALAR_ASSIGN_TOKEN: + case _SCALAR_PLUSEQS_TOKEN: + case _SCALAR_MINUSEQS_TOKEN: + case _SCALAR_TIMESEQS_TOKEN: + case _SCALAR_DIVEQS_TOKEN: + case _SCALAR_BOREQS_TOKEN: + case _SCALAR_BANDEQS_TOKEN: + case _SCALAR_PLUSPLUS_TOKEN: + case _SCALAR_POST_PLUSPLUS_TOKEN: + case _SCALAR_MINUSMINUS_TOKEN: + case _SCALAR_POST_MINUSMINUS_TOKEN: + case DOT_TOKEN: + case TMP_TOKEN: + case DEFINE_TOKEN: + case DEFINE_STATIC_TOKEN: + case DEFINE_PRIVATE_TOKEN: + case DEFINE_PUBLIC_TOKEN: + case FLOAT_TOKEN: + case DOUBLE_TOKEN: + case COMPLEX_TOKEN: + case IDENT_TOKEN: + case _REF_TOKEN: + case _STRUCT_ASSIGN_TOKEN: + case _STRUCT_PLUSEQS_TOKEN: + case _STRUCT_MINUSEQS_TOKEN: + case _STRUCT_TIMESEQS_TOKEN: + case _STRUCT_DIVEQS_TOKEN: + case _STRUCT_BOREQS_TOKEN: + case _STRUCT_BANDEQS_TOKEN: + case _STRUCT_POST_MINUSMINUS_TOKEN: + case _STRUCT_MINUSMINUS_TOKEN: + case _STRUCT_POST_PLUSPLUS_TOKEN: + case _STRUCT_PLUSPLUS_TOKEN: + strcpy (b3, tok->v.s_val); + break; + + default: + b3 = NULL; + } + + if (b3 != NULL) + { + len = strlen (b3); + buf[1] = (unsigned char) ((len & 0x7F) + 32); + buf[2] = (unsigned char) (((len >> 7) & 0x7F) + 32); + len += 3; + } + else len = 1; + + (void) bytecomp_write_data ((char *)buf, len); +} + +int SLang_byte_compile_file (char *name, int method) +{ + char file [1024]; + + (void) method; + if (strlen (name) + 2 >= sizeof (file)) + { + SLang_verror (SL_INVALID_PARM, "Filename too long"); + return -1; + } + sprintf (file, "%sc", name); + if (NULL == (Byte_Compile_Fp = fopen (file, "w"))) + { + SLang_verror(SL_OBJ_NOPEN, "%s: unable to open", file); + return -1; + } + + Byte_Compile_Line_Len = 0; + if (-1 != bytecomp_write_data (".#", 2)) + { + _SLcompile_ptr = byte_compile_token; + (void) SLang_load_file (name); + _SLcompile_ptr = _SLcompile; + + (void) bytecomp_write_data ("\n", 1); + } + + if (EOF == fclose (Byte_Compile_Fp)) + SLang_doerror ("Write Error"); + + if (SLang_Error) + { + SLang_verror (0, "Error processing %s", name); + return -1; + } + return 0; +} + +int SLang_generate_debug_info (int x) +{ + int y = Default_Compile_Line_Num_Info; + Default_Compile_Line_Num_Info = x; + return y; +} diff --git a/mdk-stage1/slang/sltypes.c b/mdk-stage1/slang/sltypes.c new file mode 100644 index 000000000..05b8741b1 --- /dev/null +++ b/mdk-stage1/slang/sltypes.c @@ -0,0 +1,966 @@ +/* Basic type operations for S-Lang */ +/* Copyright (c) 1992, 1996, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#if SLANG_HAS_FLOAT +# include <math.h> +#endif + +#define SL_APP_WANTS_FOREACH /* for String_Type */ +#include "slang.h" +#include "_slang.h" + +int SLpop_string (char **s) /*{{{*/ +{ + char *sls; + + *s = NULL; + + if (-1 == SLang_pop_slstring (&sls)) + return -1; + + if (NULL == (*s = SLmake_string (sls))) + { + SLang_free_slstring (sls); + return -1; + } + + SLang_free_slstring (sls); + return 0; +} + +/*}}}*/ + +int SLang_pop_slstring (char **s) /*{{{*/ +{ + return SLclass_pop_ptr_obj (SLANG_STRING_TYPE, (VOID_STAR *)s); +} + +/*}}}*/ + +/* if *data != 0, string should be freed upon use. */ +int SLang_pop_string(char **s, int *data) /*{{{*/ +{ + if (SLpop_string (s)) + return -1; + + *data = 1; + return 0; +} + +/*}}}*/ + +int _SLang_push_slstring (char *s) +{ + if (0 == SLclass_push_ptr_obj (SLANG_STRING_TYPE, (VOID_STAR)s)) + return 0; + + SLang_free_slstring (s); + return -1; +} + +int _SLpush_alloced_slstring (char *s, unsigned int len) +{ + if (NULL == (s = _SLcreate_via_alloced_slstring (s, len))) + return -1; + + return _SLang_push_slstring (s); +} + +int SLang_push_string (char *t) /*{{{*/ +{ + if (t == NULL) + return SLang_push_null (); + + if (NULL == (t = SLang_create_slstring (t))) + return -1; + + return _SLang_push_slstring (t); +} + +/*}}}*/ + +int _SLang_dup_and_push_slstring (char *s) +{ + if (NULL == (s = _SLstring_dup_slstring (s))) + return SLang_push_null (); + + return _SLang_push_slstring (s); +} + + +/* This function _always_ frees the malloced string */ +int SLang_push_malloced_string (char *c) /*{{{*/ +{ + int ret; + + ret = SLang_push_string (c); + SLfree (c); + + return ret; +} + +/*}}}*/ + +#if 0 +static int int_int_power (int a, int b) +{ + int r, s; + + if (a == 0) return 0; + if (b < 0) return 0; + if (b == 0) return 1; + + s = 1; + if (a < 0) + { + if ((b % 2) == 1) s = -1; + a = -a; + } + + /* FIXME: Priority=low + * This needs optimized + */ + r = 1; + while (b) + { + r = r * a; + b--; + } + return r * s; +} +#endif + +static int +string_string_bin_op_result (int op, unsigned char a, unsigned char b, + unsigned char *c) +{ + (void) a; + (void) b; + switch (op) + { + default: + return 0; + + case SLANG_PLUS: + *c = SLANG_STRING_TYPE; + break; + + case SLANG_GT: + case SLANG_GE: + case SLANG_LT: + case SLANG_LE: + case SLANG_EQ: + case SLANG_NE: + *c = SLANG_CHAR_TYPE; + break; + } + return 1; +} + +static int +string_string_bin_op (int op, + unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp, unsigned int nb, + VOID_STAR cp) +{ + char *ic; + char **a, **b, **c; + unsigned int n, n_max; + unsigned int da, db; + + (void) a_type; + (void) b_type; + + if (na == 1) da = 0; else da = 1; + if (nb == 1) db = 0; else db = 1; + + if (na > nb) n_max = na; else n_max = nb; + + a = (char **) ap; + b = (char **) bp; + for (n = 0; n < n_max; n++) + { + if ((*a == NULL) || (*b == NULL)) + { + SLang_verror (SL_VARIABLE_UNINITIALIZED, "String element[%u] not initialized for binary operation", n); + return -1; + } + a += da; b += db; + } + + a = (char **) ap; + b = (char **) bp; + ic = (char *) cp; + c = NULL; + + switch (op) + { + case SLANG_DIVIDE: + case SLANG_MINUS: + default: + return 0; + + case SLANG_PLUS: + /* Concat */ + c = (char **) cp; + for (n = 0; n < n_max; n++) + { + if (NULL == (c[n] = SLang_concat_slstrings (*a, *b))) + goto return_error; + + a += da; b += db; + } + break; + + case SLANG_NE: + for (n = 0; n < n_max; n++) + { + ic [n] = (0 != strcmp (*a, *b)); + a += da; + b += db; + } + break; + case SLANG_GT: + for (n = 0; n < n_max; n++) + { + ic [n] = (strcmp (*a, *b) > 0); + a += da; + b += db; + } + break; + case SLANG_GE: + for (n = 0; n < n_max; n++) + { + ic [n] = (strcmp (*a, *b) >= 0); + a += da; + b += db; + } + break; + case SLANG_LT: + for (n = 0; n < n_max; n++) + { + ic [n] = (strcmp (*a, *b) < 0); + a += da; + b += db; + } + break; + case SLANG_LE: + for (n = 0; n < n_max; n++) + { + ic [n] = (strcmp (*a, *b) <= 0); + a += da; + b += db; + } + break; + case SLANG_EQ: + for (n = 0; n < n_max; n++) + { + ic [n] = (strcmp (*a, *b) == 0); + a += da; + b += db; + } + break; + } + return 1; + + return_error: + if (c != NULL) + { + unsigned int nn; + for (nn = 0; nn < n; nn++) + { + SLang_free_slstring (c[nn]); + c[nn] = NULL; + } + for (nn = n; nn < n_max; nn++) + c[nn] = NULL; + } + return -1; +} + +static void string_destroy (unsigned char unused, VOID_STAR s) +{ + (void) unused; + SLang_free_slstring (*(char **) s); +} + +static int string_push (unsigned char unused, VOID_STAR sptr) +{ + (void) unused; + return SLang_push_string (*(char **) sptr); +} + +static int string_cmp (unsigned char unused, VOID_STAR ap, VOID_STAR bp, int *c) +{ + char *a, *b; + (void) unused; + + a = *(char **) ap; + b = *(char **) bp; + if (a != b) + { + if (a == NULL) *c = -1; + else if (b == NULL) *c = 1; + else *c = strcmp (a, b); + return 0; + } + *c = 0; + return 0; +} + +static int string_to_int (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + char **s; + unsigned int i; + int *b; + + (void) a_type; + (void) b_type; + + s = (char **) ap; + b = (int *) bp; + for (i = 0; i < na; i++) + { + if (s[i] == NULL) b[i] = 0; + else b[i] = s[i][0]; + } + return 1; +} + +struct _SLang_Foreach_Context_Type +{ + char *string; + unsigned int n; +}; + +static SLang_Foreach_Context_Type * +string_foreach_open (unsigned char type, unsigned int num) +{ + char *s; + SLang_Foreach_Context_Type *c; + + (void) type; + if (num != 0) + { + SLang_verror (SL_NOT_IMPLEMENTED, + "'foreach using' form not supported by String_Type"); + SLdo_pop_n (num + 1); + return NULL; + } + if (-1 == SLang_pop_slstring (&s)) + return NULL; + + c = (SLang_Foreach_Context_Type *)SLmalloc (sizeof (SLang_Foreach_Context_Type)); + if (c == NULL) + { + SLang_free_slstring (s); + return NULL; + } + + memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); + c->string = s; + + return c; +} + +static void string_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + if (c == NULL) return; + SLang_free_slstring (c->string); + SLfree ((char *) c); +} + +static int string_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + char ch; + + (void) type; + ch = c->string[c->n]; + if (ch == 0) + return 0; /* done */ + + c->n += 1; + + if (-1 == SLclass_push_int_obj (SLANG_INT_TYPE, ch)) + return -1; + + return 1; +} + +int _SLstring_list_push (_SLString_List_Type *p) +{ + unsigned int num; + int inum; + SLang_Array_Type *at; + char **buf; + + if ((buf = p->buf) == NULL) + return SLang_push_null (); + + num = p->num; + inum = (int) num; + + if (num == 0) num++; + if (num != p->max_num) + { + if (NULL == (buf = (char **)SLrealloc ((char *) buf, sizeof (char *) * num))) + { + _SLstring_list_delete (p); + return -1; + } + p->max_num = num; + p->buf = buf; + } + + if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) buf, &inum, 1))) + { + _SLstring_list_delete (p); + return -1; + } + p->buf = NULL; + _SLstring_list_delete (p); + return SLang_push_array (at, 1); +} + +int _SLstring_list_init (_SLString_List_Type *p, unsigned int max_num, unsigned int delta_num) +{ + if (NULL == (p->buf = (char **) SLmalloc (max_num * sizeof (char *)))) + return -1; + + p->max_num = max_num; + p->num = 0; + p->delta_num = delta_num; + return 0; +} + +int _SLstring_list_append (_SLString_List_Type *p, char *s) +{ + if (s == NULL) + { + _SLstring_list_delete (p); + return -1; + } + + if (p->max_num == p->num) + { + char **b; + unsigned int max_num = p->num + p->delta_num; + b = (char **)SLrealloc ((char *)p->buf, max_num * sizeof (char *)); + if (b == NULL) + { + _SLstring_list_delete (p); + SLang_free_slstring (s); + return -1; + } + p->buf = b; + p->max_num = max_num; + } + + p->buf[p->num] = s; + p->num++; + return 0; +} + +void _SLstring_list_delete (_SLString_List_Type *p) +{ + if (p->buf != NULL) + { + unsigned int i, imax; + char **buf = p->buf; + imax = p->num; + for (i = 0; i < imax; i++) + SLang_free_slstring (buf[i]); + SLfree ((char *)buf); + p->buf = NULL; + } +} + +/* Ref type */ +int SLang_pop_ref (SLang_Ref_Type **ref) +{ + return SLclass_pop_ptr_obj (SLANG_REF_TYPE, (VOID_STAR *)ref); +} + +/* Note: This is ok if ptr is NULL. Some routines rely on this behavior */ +int _SLang_push_ref (int is_global, VOID_STAR ptr) +{ + SLang_Ref_Type *r; + + if (ptr == NULL) + return SLang_push_null (); + + r = (SLang_Ref_Type *) SLmalloc (sizeof (SLang_Ref_Type)); + if (r == NULL) return -1; + + r->is_global = is_global; + r->v.nt = (SLang_Name_Type *) ptr; + + if (-1 == SLclass_push_ptr_obj (SLANG_REF_TYPE, (VOID_STAR) r)) + { + SLfree ((char *) r); + return -1; + } + return 0; +} + +static void ref_destroy (unsigned char type, VOID_STAR ptr) +{ + (void) type; + SLfree ((char *) *(SLang_Ref_Type **)ptr); +} + +void SLang_free_ref (SLang_Ref_Type *ref) +{ + SLfree ((char *) ref); +} + +static int ref_push (unsigned char type, VOID_STAR ptr) +{ + SLang_Ref_Type *ref; + + (void) type; + + ref = *(SLang_Ref_Type **) ptr; + + if (ref == NULL) + return SLang_push_null (); + + return _SLang_push_ref (ref->is_global, (VOID_STAR) ref->v.nt); +} + +int SLang_assign_to_ref (SLang_Ref_Type *ref, unsigned char type, VOID_STAR v) +{ + SLang_Object_Type *stkptr; + SLang_Class_Type *cl; + + cl = _SLclass_get_class (type); + + /* Use apush since this function is passing ``array'' bytes rather than the + * address of the data. I need to somehow make this more consistent. To + * see what I mean, consider: + * + * double z[2]; + * char *s = "silly"; + * int i; + * + * SLang_assign_to_ref (ref, SLANG_INT_TYPE, &i); + * SLang_assign_to_ref (ref, SLANG_STRING_TYPE, &s); + * SLang_assign_to_ref (ref, SLANG_COMPLEX_TYPE, z); + * + * That is, all external routines that take a VOID_STAR argument need to + * be documented such that how the function should be called with the + * various class_types. + */ + if (-1 == (*cl->cl_apush) (type, v)) + return -1; + + stkptr = _SLStack_Pointer; + if (0 == _SLang_deref_assign (ref)) + return 0; + + if (stkptr != _SLStack_Pointer) + SLdo_pop (); + + return -1; +} + +static char *ref_string (unsigned char type, VOID_STAR ptr) +{ + SLang_Ref_Type *ref; + + (void) type; + ref = *(SLang_Ref_Type **) ptr; + if (ref->is_global) + { + char *name, *s; + + name = ref->v.nt->name; + if ((name != NULL) + && (NULL != (s = SLmalloc (strlen(name) + 2)))) + { + *s = '&'; + strcpy (s + 1, name); + return s; + } + + return NULL; + } + return SLmake_string ("Local Variable Reference"); +} + +static int ref_dereference (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return _SLang_dereference_ref (*(SLang_Ref_Type **) ptr); +} + +static int ref_cmp (unsigned char type, VOID_STAR a, VOID_STAR b, int *c) +{ + SLang_Ref_Type *ra, *rb; + + (void) type; + + ra = *(SLang_Ref_Type **)a; + rb = *(SLang_Ref_Type **)b; + + if (ra == NULL) + { + if (rb == NULL) *c = 0; + else *c = -1; + return 0; + } + if (rb == NULL) + { + *c = 1; + return 0; + } + + if (ra->v.nt == rb->v.nt) + *c = 0; + else *c = strcmp (ra->v.nt->name, rb->v.nt->name); + return 0; +} + + +SLang_Name_Type *SLang_pop_function (void) +{ + SLang_Ref_Type *ref; + SLang_Name_Type *f; + + if (SLang_peek_at_stack () == SLANG_STRING_TYPE) + { + char *name; + + if (-1 == SLang_pop_slstring (&name)) + return NULL; + + if (NULL == (f = SLang_get_function (name))) + { + SLang_verror (SL_UNDEFINED_NAME, "Function %s does not exist", name); + SLang_free_slstring (name); + return NULL; + } + SLang_free_slstring (name); + return f; + } + + if (-1 == SLang_pop_ref (&ref)) + return NULL; + + f = SLang_get_fun_from_ref (ref); + SLang_free_ref (ref); + return f; +} + +/* This is a placeholder for version 2 */ +void SLang_free_function (SLang_Name_Type *f) +{ + (void) f; +} + +/* NULL type */ +int SLang_push_null (void) +{ + return SLclass_push_ptr_obj (SLANG_NULL_TYPE, NULL); +} + +int SLang_pop_null (void) +{ + SLang_Object_Type obj; + return _SLang_pop_object_of_type (SLANG_NULL_TYPE, &obj, 0); +} + +static int null_push (unsigned char unused, VOID_STAR ptr_unused) +{ + (void) unused; (void) ptr_unused; + return SLang_push_null (); +} + +static int null_pop (unsigned char type, VOID_STAR ptr) +{ + (void) type; + + if (-1 == SLang_pop_null ()) + return -1; + + *(char **) ptr = NULL; + return 0; +} + +/* Implement foreach (NULL) using (whatever) to do nothing. This is useful + * because suppose that X is a list but is NULL in some situations. Then + * when it is NULL, we want foreach(X) to do nothing. + */ +static SLang_Foreach_Context_Type * +null_foreach_open (unsigned char type, unsigned int num) +{ + (void) type; + SLdo_pop_n (num + 1); + return (SLang_Foreach_Context_Type *)1; +} + +static void null_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + (void) c; +} + +static int null_foreach (unsigned char type, SLang_Foreach_Context_Type *c) +{ + (void) type; + (void) c; + return 0; +} + +static int null_to_bool (unsigned char type, int *t) +{ + (void) type; + *t = 0; + return SLang_pop_null (); +} + +/* AnyType */ +int _SLanytype_typecast (unsigned char a_type, VOID_STAR ap, unsigned int na, + unsigned char b_type, VOID_STAR bp) +{ + SLang_Class_Type *cl; + SLang_Any_Type **any; + unsigned int i; + unsigned int sizeof_type; + + (void) b_type; + + any = (SLang_Any_Type **) bp; + + cl = _SLclass_get_class (a_type); + sizeof_type = cl->cl_sizeof_type; + + for (i = 0; i < na; i++) + { + if ((-1 == (*cl->cl_apush) (a_type, ap)) + || (-1 == SLang_pop_anytype (&any[i]))) + { + while (i != 0) + { + i--; + SLang_free_anytype (any[i]); + any[i] = NULL; + } + return -1; + } + ap = (VOID_STAR)((char *)ap + sizeof_type); + } + + return 1; +} + +int SLang_pop_anytype (SLang_Any_Type **any) +{ + SLang_Object_Type *obj; + + *any = NULL; + + if (NULL == (obj = (SLang_Object_Type *) SLmalloc (sizeof (SLang_Object_Type)))) + return -1; + + if (-1 == SLang_pop (obj)) + { + SLfree ((char *) obj); + return -1; + } + *any = (SLang_Any_Type *)obj; + return 0; +} + +/* This function will result in an object that is represented by the + * anytype object. + */ +int SLang_push_anytype (SLang_Any_Type *any) +{ + return _SLpush_slang_obj ((SLang_Object_Type *)any); +} + +/* After this call, the stack will contain an Any_Type object */ +static int anytype_push (unsigned char type, VOID_STAR ptr) +{ + SLang_Any_Type *obj; + + /* Push the object onto the stack, then pop it back off into our anytype + * container. That way, any memory managing associated with the type + * will be performed automatically. Another way to think of it is that + * pushing an Any_Type onto the stack will create another copy of the + * object represented by it. + */ + if (-1 == _SLpush_slang_obj (*(SLang_Object_Type **)ptr)) + return -1; + + if (-1 == SLang_pop_anytype (&obj)) + return -1; + + /* There is no need to reference count the anytype objects since every + * push results in a new anytype container. + */ + if (-1 == SLclass_push_ptr_obj (type, (VOID_STAR) obj)) + { + SLang_free_anytype (obj); + return -1; + } + + return 0; +} + +static void anytype_destroy (unsigned char type, VOID_STAR ptr) +{ + SLang_Object_Type *obj; + + (void) type; + obj = *(SLang_Object_Type **)ptr; + SLang_free_object (obj); + SLfree ((char *) obj); +} + +void SLang_free_anytype (SLang_Any_Type *any) +{ + if (any != NULL) + anytype_destroy (SLANG_ANY_TYPE, (VOID_STAR) &any); +} + +static int anytype_dereference (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return _SLpush_slang_obj (*(SLang_Object_Type **) ptr); +} + +/* SLANG_INTP_TYPE */ +static int intp_push (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return SLclass_push_int_obj (SLANG_INT_TYPE, **(int **)ptr); +} + +static int intp_pop (unsigned char unused, VOID_STAR ptr) +{ + (void) unused; + return SLang_pop_integer (*(int **) ptr); +} + +static int undefined_push (unsigned char t, VOID_STAR p) +{ + (void) t; (void) p; + if (SLang_Error == 0) + SLang_Error = SL_VARIABLE_UNINITIALIZED; + return -1; +} + +int _SLregister_types (void) +{ + SLang_Class_Type *cl; + + /* A good compiler should optimize this code away. */ + if ((sizeof(short) != SIZEOF_SHORT) + || (sizeof(int) != SIZEOF_INT) + || (sizeof(long) != SIZEOF_LONG) + || (sizeof(float) != SIZEOF_FLOAT) + || (sizeof(double) != SIZEOF_DOUBLE)) + SLang_exit_error ("S-Lang Library not built properly. Fix SIZEOF_* in config.h and recompile"); + + if (-1 == _SLclass_init ()) + return -1; + + /* Undefined Type */ + if (NULL == (cl = SLclass_allocate_class ("Undefined_Type"))) + return -1; + (void) SLclass_set_push_function (cl, undefined_push); + (void) SLclass_set_pop_function (cl, undefined_push); + if (-1 == SLclass_register_class (cl, SLANG_UNDEFINED_TYPE, sizeof (int), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + /* Make Void_Type a synonym for Undefined_Type. Note that this does + * not mean that Void_Type represents SLANG_VOID_TYPE. Void_Type is + * used by array_map to indicate no array is to be created. + */ + if (-1 == SLclass_create_synonym ("Void_Type", SLANG_UNDEFINED_TYPE)) + return -1; + + if (-1 == _SLarith_register_types ()) + return -1; + + /* SLANG_INTP_TYPE */ + if (NULL == (cl = SLclass_allocate_class ("_IntegerP_Type"))) + return -1; + (void) SLclass_set_push_function (cl, intp_push); + (void) SLclass_set_pop_function (cl, intp_pop); + if (-1 == SLclass_register_class (cl, SLANG_INTP_TYPE, sizeof (int), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + + /* String Type */ + + if (NULL == (cl = SLclass_allocate_class ("String_Type"))) + return -1; + (void) SLclass_set_destroy_function (cl, string_destroy); + (void) SLclass_set_push_function (cl, string_push); + cl->cl_foreach_open = string_foreach_open; + cl->cl_foreach_close = string_foreach_close; + cl->cl_foreach = string_foreach; + cl->cl_cmp = string_cmp; + if (-1 == SLclass_register_class (cl, SLANG_STRING_TYPE, sizeof (char *), + SLANG_CLASS_TYPE_PTR)) + return -1; + + /* ref Type */ + if (NULL == (cl = SLclass_allocate_class ("Ref_Type"))) + return -1; + cl->cl_dereference = ref_dereference; + cl->cl_push = ref_push; + cl->cl_destroy = ref_destroy; + cl->cl_string = ref_string; + cl->cl_cmp = ref_cmp; + if (-1 == SLclass_register_class (cl, SLANG_REF_TYPE, + sizeof (SLang_Ref_Type *), + SLANG_CLASS_TYPE_PTR)) + return -1; + + /* NULL Type */ + + if (NULL == (cl = SLclass_allocate_class ("Null_Type"))) + return -1; + cl->cl_push = null_push; + cl->cl_pop = null_pop; + cl->cl_foreach_open = null_foreach_open; + cl->cl_foreach_close = null_foreach_close; + cl->cl_foreach = null_foreach; + cl->cl_to_bool = null_to_bool; + if (-1 == SLclass_register_class (cl, SLANG_NULL_TYPE, sizeof (char *), + SLANG_CLASS_TYPE_SCALAR)) + return -1; + + /* AnyType */ + if (NULL == (cl = SLclass_allocate_class ("Any_Type"))) + return -1; + (void) SLclass_set_push_function (cl, anytype_push); + (void) SLclass_set_destroy_function (cl, anytype_destroy); + cl->cl_dereference = anytype_dereference; + if (-1 == SLclass_register_class (cl, SLANG_ANY_TYPE, sizeof (VOID_STAR), + SLANG_CLASS_TYPE_PTR)) + return -1; + + if (-1 == _SLang_init_bstring ()) + return -1; + + if ((-1 == SLclass_add_typecast (SLANG_STRING_TYPE, SLANG_INT_TYPE, string_to_int, 0)) + || (-1 == SLclass_add_binary_op (SLANG_STRING_TYPE, SLANG_STRING_TYPE, string_string_bin_op, string_string_bin_op_result))) + return -1; + + return 0; +} + diff --git a/mdk-stage1/slang/slutty.c b/mdk-stage1/slang/slutty.c new file mode 100644 index 000000000..636c1bb90 --- /dev/null +++ b/mdk-stage1/slang/slutty.c @@ -0,0 +1,596 @@ +/* slutty.c --- Unix Low level terminal (tty) functions for S-Lang */ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +#include "slinclud.h" + +#include <signal.h> +/* sequent support thanks to Kenneth Lorber <keni@oasys.dt.navy.mil> */ +/* SYSV (SYSV ISC R3.2 v3.0) provided by iain.lea@erlm.siemens.de */ + +#if defined (_AIX) && !defined (_ALL_SOURCE) +# define _ALL_SOURCE /* so NBBY is defined in <sys/types.h> */ +#endif + +#include <sys/time.h> +#include <sys/types.h> + +#ifdef SYSV +# include <fcntl.h> +# ifndef CRAY +# include <sys/termio.h> +# include <sys/stream.h> +# include <sys/ptem.h> +# include <sys/tty.h> +# endif +#endif + +#ifdef __BEOS__ +/* Prototype for select */ +# include <net/socket.h> +#endif + +#include <sys/file.h> + +#ifndef sun +# include <sys/ioctl.h> +#endif + +#ifdef __QNX__ +# include <sys/select.h> +#endif + +#include <sys/stat.h> +#include <errno.h> + +#if defined (_AIX) && !defined (FD_SET) +# include <sys/select.h> /* for FD_ISSET, FD_SET, FD_ZERO */ +#endif + +#ifndef O_RDWR +# include <fcntl.h> +#endif + +#include "slang.h" +#include "_slang.h" + +int SLang_TT_Read_FD = -1; +int SLang_TT_Baud_Rate; + +#ifdef HAVE_TERMIOS_H +# if !defined(HAVE_TCGETATTR) || !defined(HAVE_TCSETATTR) +# undef HAVE_TERMIOS_H +# endif +#endif + +#ifndef HAVE_TERMIOS_H + +# if !defined(CBREAK) && defined(sun) +# ifndef BSD_COMP +# define BSD_COMP 1 +# endif +# include <sys/ioctl.h> +# endif + +typedef struct + { + struct tchars t; + struct ltchars lt; + struct sgttyb s; + } +TTY_Termio_Type; +#else +# include <termios.h> +typedef struct termios TTY_Termio_Type; +#endif + +static TTY_Termio_Type Old_TTY; + +#ifdef HAVE_TERMIOS_H +typedef struct +{ + unsigned int key; + unsigned int value; +} Baud_Rate_Type; + +static Baud_Rate_Type Baud_Rates [] = +{ +#ifdef B0 + {B0, 0}, +#endif +#ifdef B50 + {B50, 50}, +#endif +#ifdef B75 + {B75, 75}, +#endif +#ifdef B110 + {B110, 110}, +#endif +#ifdef B134 + {B134, 134}, +#endif +#ifdef B150 + {B150, 150}, +#endif +#ifdef B200 + {B200, 200}, +#endif +#ifdef B300 + {B300, 300}, +#endif +#ifdef B600 + {B600, 600}, +#endif +#ifdef B1200 + {B1200, 1200}, +#endif +#ifdef B1800 + {B1800, 1800}, +#endif +#ifdef B2400 + {B2400, 2400}, +#endif +#ifdef B4800 + {B4800, 4800}, +#endif +#ifdef B9600 + {B9600, 9600}, +#endif +#ifdef B19200 + {B19200, 19200}, +#endif +#ifdef B38400 + {B38400, 38400}, +#endif +#ifdef B57600 + {B57600, 57600}, +#endif +#ifdef B115200 + {B115200, 115200}, +#endif +#ifdef B230400 + {B230400, 230400}, +#endif + {0, 0} +}; + +static void +set_baud_rate (TTY_Termio_Type *tty) +{ +#ifdef HAVE_CFGETOSPEED + unsigned int speed; + Baud_Rate_Type *b, *bmax; + + if (SLang_TT_Baud_Rate) + return; /* already set */ + + speed = (unsigned int) cfgetospeed (tty); + + b = Baud_Rates; + bmax = b + (sizeof (Baud_Rates)/sizeof(Baud_Rates[0])); + while (b < bmax) + { + if (b->key == speed) + { + SLang_TT_Baud_Rate = b->value; + return; + } + b++; + } +#else + (void) tty; +#endif +} + +#endif /* HAVE_TERMIOS_H */ + +#ifdef HAVE_TERMIOS_H +# define GET_TERMIOS(fd, x) tcgetattr(fd, x) +# define SET_TERMIOS(fd, x) tcsetattr(fd, TCSADRAIN, x) +#else +# ifdef TCGETS +# define GET_TERMIOS(fd, x) ioctl(fd, TCGETS, x) +# define SET_TERMIOS(fd, x) ioctl(fd, TCSETS, x) +# else +# define X(x,m) &(((TTY_Termio_Type *)(x))->m) +# define GET_TERMIOS(fd, x) \ + ((ioctl(fd, TIOCGETC, X(x,t)) || \ + ioctl(fd, TIOCGLTC, X(x,lt)) || \ + ioctl(fd, TIOCGETP, X(x,s))) ? -1 : 0) +# define SET_TERMIOS(fd, x) \ + ((ioctl(fd, TIOCSETC, X(x,t)) ||\ + ioctl(fd, TIOCSLTC, X(x,lt)) || \ + ioctl(fd, TIOCSETP, X(x,s))) ? -1 : 0) +# endif +#endif + +static int TTY_Inited = 0; +static int TTY_Open = 0; + +#ifdef ultrix /* Ultrix gets _POSIX_VDISABLE wrong! */ +# define NULL_VALUE -1 +#else +# ifdef _POSIX_VDISABLE +# define NULL_VALUE _POSIX_VDISABLE +# else +# define NULL_VALUE 255 +# endif +#endif + +int SLang_init_tty (int abort_char, int no_flow_control, int opost) +{ + TTY_Termio_Type newtty; + + SLsig_block_signals (); + + if (TTY_Inited) + { + SLsig_unblock_signals (); + return 0; + } + + TTY_Open = 0; + + if ((SLang_TT_Read_FD == -1) + || (1 != isatty (SLang_TT_Read_FD))) + { +#ifdef O_RDWR +# ifndef __BEOS__ /* I have been told that BEOS will HANG if passed /dev/tty */ + if ((SLang_TT_Read_FD = open("/dev/tty", O_RDWR)) >= 0) + { + TTY_Open = 1; + } +# endif +#endif + if (TTY_Open == 0) + { + SLang_TT_Read_FD = fileno (stderr); + if (1 != isatty (SLang_TT_Read_FD)) + { + SLang_TT_Read_FD = fileno (stdin); + if (1 != isatty (SLang_TT_Read_FD)) + { + fprintf (stderr, "Failed to open terminal."); + return -1; + } + } + } + } + + SLang_Abort_Char = abort_char; + + /* Some systems may not permit signals to be blocked. As a result, the + * return code must be checked. + */ + while (-1 == GET_TERMIOS(SLang_TT_Read_FD, &Old_TTY)) + { + if (errno != EINTR) + { + SLsig_unblock_signals (); + return -1; + } + } + + while (-1 == GET_TERMIOS(SLang_TT_Read_FD, &newtty)) + { + if (errno != EINTR) + { + SLsig_unblock_signals (); + return -1; + } + } + +#ifndef HAVE_TERMIOS_H + newtty.s.sg_flags &= ~(ECHO); + newtty.s.sg_flags &= ~(CRMOD); + /* if (Flow_Control == 0) newtty.s.sg_flags &= ~IXON; */ + newtty.t.t_eofc = 1; + if (abort_char == -1) SLang_Abort_Char = newtty.t.t_intrc; + newtty.t.t_intrc = SLang_Abort_Char; /* ^G */ + newtty.t.t_quitc = 255; + newtty.lt.t_suspc = 255; /* to ignore ^Z */ + newtty.lt.t_dsuspc = 255; /* to ignore ^Y */ + newtty.lt.t_lnextc = 255; + newtty.s.sg_flags |= CBREAK; /* do I want cbreak or raw????? */ +#else + + /* get baud rate */ + + newtty.c_iflag &= ~(ECHO | INLCR | ICRNL); +#ifdef ISTRIP + /* newtty.c_iflag &= ~ISTRIP; */ +#endif + if (opost == 0) newtty.c_oflag &= ~OPOST; + + set_baud_rate (&newtty); + + if (no_flow_control) newtty.c_iflag &= ~IXON; else newtty.c_iflag |= IXON; + + newtty.c_cc[VEOF] = 1; + newtty.c_cc[VMIN] = 1; + newtty.c_cc[VTIME] = 0; + newtty.c_lflag = ISIG | NOFLSH; + if (abort_char == -1) SLang_Abort_Char = newtty.c_cc[VINTR]; + newtty.c_cc[VINTR] = SLang_Abort_Char; /* ^G */ + newtty.c_cc[VQUIT] = NULL_VALUE; + newtty.c_cc[VSUSP] = NULL_VALUE; /* to ignore ^Z */ +#ifdef VDSUSP + newtty.c_cc[VDSUSP] = NULL_VALUE; /* to ignore ^Y */ +#endif +#ifdef VLNEXT + newtty.c_cc[VLNEXT] = NULL_VALUE; /* to ignore ^V ? */ +#endif +#ifdef VSWTCH + newtty.c_cc[VSWTCH] = NULL_VALUE; /* to ignore who knows what */ +#endif +#endif /* NOT HAVE_TERMIOS_H */ + + while (-1 == SET_TERMIOS(SLang_TT_Read_FD, &newtty)) + { + if (errno != EINTR) + { + SLsig_unblock_signals (); + return -1; + } + } + + TTY_Inited = 1; + SLsig_unblock_signals (); + return 0; +} + +void SLtty_set_suspend_state (int mode) +{ + TTY_Termio_Type newtty; + + SLsig_block_signals (); + + if (TTY_Inited == 0) + { + SLsig_unblock_signals (); + return; + } + + while ((-1 == GET_TERMIOS (SLang_TT_Read_FD, &newtty)) + && (errno == EINTR)) + ; + +#ifndef HAVE_TERMIOS_H + /* I do not know if all systems define the t_dsuspc field */ + if (mode == 0) + { + newtty.lt.t_suspc = 255; + newtty.lt.t_dsuspc = 255; + } + else + { + newtty.lt.t_suspc = Old_TTY.lt.t_suspc; + newtty.lt.t_dsuspc = Old_TTY.lt.t_dsuspc; + } +#else + if (mode == 0) + { + newtty.c_cc[VSUSP] = NULL_VALUE; +#ifdef VDSUSP + newtty.c_cc[VDSUSP] = NULL_VALUE; +#endif + } + else + { + newtty.c_cc[VSUSP] = Old_TTY.c_cc[VSUSP]; +#ifdef VDSUSP + newtty.c_cc[VDSUSP] = Old_TTY.c_cc[VDSUSP]; +#endif + } +#endif + + while ((-1 == SET_TERMIOS (SLang_TT_Read_FD, &newtty)) + && (errno == EINTR)) + ; + + SLsig_unblock_signals (); +} + +void SLang_reset_tty (void) +{ + SLsig_block_signals (); + + if (TTY_Inited == 0) + { + SLsig_unblock_signals (); + return; + } + + while ((-1 == SET_TERMIOS(SLang_TT_Read_FD, &Old_TTY)) + && (errno == EINTR)) + ; + + if (TTY_Open) + { + while ((-1 == close (SLang_TT_Read_FD)) + && (errno == EINTR)) + ; + + TTY_Open = 0; + SLang_TT_Read_FD = -1; + } + + TTY_Inited = 0; + SLsig_unblock_signals (); +} + +static void default_sigint (int sig) +{ + sig = errno; /* use parameter */ + + SLKeyBoard_Quit = 1; + if (SLang_Ignore_User_Abort == 0) SLang_Error = SL_USER_BREAK; + SLsignal_intr (SIGINT, default_sigint); + errno = sig; +} + +int SLang_set_abort_signal (void (*hand)(int)) +{ + int save_errno = errno; + SLSig_Fun_Type *f; + + if (hand == NULL) hand = default_sigint; + f = SLsignal_intr (SIGINT, hand); + + errno = save_errno; + + if (f == (SLSig_Fun_Type *) SIG_ERR) + return -1; + + return 0; +} + +#ifndef FD_SET +#define FD_SET(fd, tthis) *(tthis) = 1 << (fd) +#define FD_ZERO(tthis) *(tthis) = 0 +#define FD_ISSET(fd, tthis) (*(tthis) & (1 << fd)) +typedef int fd_set; +#endif + +static fd_set Read_FD_Set; + +/* HACK: If > 0, use 1/10 seconds. If < 0, use 1/1000 seconds */ + +int _SLsys_input_pending(int tsecs) +{ + struct timeval wait; + long usecs, secs; + + if (TTY_Inited == 0) return -1; + + if (tsecs >= 0) + { + secs = tsecs / 10; + usecs = (tsecs % 10) * 100000; + } + else + { + tsecs = -tsecs; + secs = tsecs / 1000; + usecs = (tsecs % 1000) * 1000; + } + + wait.tv_sec = secs; + wait.tv_usec = usecs; + + FD_ZERO(&Read_FD_Set); + FD_SET(SLang_TT_Read_FD, &Read_FD_Set); + + return select(SLang_TT_Read_FD + 1, &Read_FD_Set, NULL, NULL, &wait); +} + +int (*SLang_getkey_intr_hook) (void); + +static int handle_interrupt (void) +{ + if (SLang_getkey_intr_hook != NULL) + { + int save_tty_fd = SLang_TT_Read_FD; + + if (-1 == (*SLang_getkey_intr_hook) ()) + return -1; + + if (save_tty_fd != SLang_TT_Read_FD) + return -1; + } + + return 0; +} + +unsigned int _SLsys_getkey (void) +{ + unsigned char c; + + if (TTY_Inited == 0) + { + int ic = fgetc (stdin); + if (ic == EOF) return SLANG_GETKEY_ERROR; + return (unsigned int) ic; + } + + while (1) + { + int ret; + + if (SLKeyBoard_Quit) + return SLang_Abort_Char; + + if (0 == (ret = _SLsys_input_pending (100))) + continue; + + if (ret != -1) + break; + + if (SLKeyBoard_Quit) + return SLang_Abort_Char; + + if (errno == EINTR) + { + if (-1 == handle_interrupt ()) + return SLANG_GETKEY_ERROR; + + continue; + } + + break; /* let read handle it */ + } + + while (1) + { + int status = read(SLang_TT_Read_FD, (char *) &c, 1); + + if (status > 0) + break; + + if (status == 0) + { + /* We are at the end of a file. Let application handle it. */ + return SLANG_GETKEY_ERROR; + } + + if (errno == EINTR) + { + if (-1 == handle_interrupt ()) + return SLANG_GETKEY_ERROR; + + if (SLKeyBoard_Quit) + return SLang_Abort_Char; + + continue; + } +#ifdef EAGAIN + if (errno == EAGAIN) + { + sleep (1); + continue; + } +#endif +#ifdef EWOULDBLOCK + if (errno == EWOULDBLOCK) + { + sleep (1); + continue; + } +#endif +#ifdef EIO + if (errno == EIO) + { + SLang_exit_error ("_SLsys_getkey: EIO error."); + } +#endif + return SLANG_GETKEY_ERROR; + } + + return((unsigned int) c); +} + diff --git a/mdk-stage1/slang/slxstrng.c b/mdk-stage1/slang/slxstrng.c new file mode 100644 index 000000000..3f8a4dffa --- /dev/null +++ b/mdk-stage1/slang/slxstrng.c @@ -0,0 +1,43 @@ +/* Copyright (c) 1992, 1999, 2001 John E. Davis + * This file is part of the S-Lang library. + * + * You may distribute under the terms of either the GNU General Public + * License or the Perl Artistic License. + */ + +/* These routines are simple and inefficient. They were designed to work on + * SunOS when using Electric Fence. + */ + +#include "slang.h" +#include "_slang.h" +char *SLstrcpy(register char *aa, register char *b) +{ + char *a = aa; + while ((*a++ = *b++) != 0); + return aa; +} + +int SLstrcmp(register char *a, register char *b) +{ + while (*a && (*a == *b)) + { + a++; + b++; + } + if (*a) return((unsigned char) *a - (unsigned char) *b); + else if (*b) return ((unsigned char) *a - (unsigned char) *b); + else return 0; +} + +char *SLstrncpy(char *a, register char *b,register int n) +{ + register char *aa = a; + while ((n > 0) && *b) + { + *aa++ = *b++; + n--; + } + while (n-- > 0) *aa++ = 0; + return (a); +} |