ase/cmd/stx/helper.st

@@ -0,0 +1,13 @@
+| x |
+"print the reverse hierarchy of a class"
+x := Class.
+[x isNil] whileFalse: [
+	Transcript show: x printString; cr.
+	x := x superclass].
+
+| x |
+"print the reverse hierarchy of a metaclass"
+x := Class class.
+[x isNil] whileFalse: [
+	Transcript show: x printString; cr.
+	x := x superclass].

ase/cmd/stx/makefile.bcc

@@ -0,0 +1,21 @@
+CC = bcc32
+CFLAGS = -I..\..\..
+LDFLAGS = -L..\..\..\xp\bas -L..\..\..\xp\stx
+LIBS = import32.lib cw32mt.lib xpbas.lib xpstx.lib
+STARTUP = c0x32w.obj
+
+all: stx parser
+
+stx: stx.obj
+	ilink32 $(LDFLAGS) $(STARTUP) stx.obj,stx.exe,,$(LIBS),,
+
+parser: parser.obj
+	ilink32 $(LDFLAGS) $(STARTUP) parser.obj,parser.exe,,$(LIBS),,
+
+clean:
+	del $(OBJS) *.obj $(OUT)
+
+.SUFFIXES: .c .obj
+.c.obj:
+	$(CC) $(CFLAGS) -c $< 
+

ase/cmd/stx/makefile.cl

@@ -0,0 +1,20 @@
+CC = cl
+CFLAGS = /nologo /MT /GX /W3 /GR- -I..\..\..
+LDFLAGS = /libpath:..\..\cmn /libpath:..\..\stx
+LIBS = asecmn.lib asestx.lib
+
+all: stx parser
+
+stx: stx.obj
+	link /nologo /out:stx.exe $(LDFLAGS) $(LIBS) stx.obj
+
+parser: parser.obj
+	link /nologo /out:parser.exe $(LDFLAGS) $(LIBS) parser.obj
+
+clean:
+	del $(OBJS) *.obj stx.exe parser.exe
+
+.SUFFIXES: .c .obj
+.c.obj:
+	$(CC) /c $(CFLAGS) $< 
+

ase/cmd/stx/makefile.in

@@ -0,0 +1,19 @@
+CC = @CC@
+CFLAGS = @CFLAGS@ -I@abs_top_builddir@
+LDFLAGS = @LDFLAGS@ -L@abs_top_builddir@/xp/bas -L@abs_top_builddir@/xp/stx
+LIBS = @LIBS@ -lxpstx -lxpbas
+
+all: stx parser
+
+stx: stx.o
+	$(CC) $(LDFLAGS) -o $@.x stx.o $(LIBS)
+
+parser: parser.o
+	$(CC) $(LDFLAGS) -o $@.x parser.o $(LIBS)
+
+clean:
+	rm -rf *.x *.o
+
+.SUFFIXES: .c .o
+.c.o:
+	$(CC) $(CFLAGS) -c $<

ase/cmd/stx/makefile.lcc

@@ -0,0 +1,24 @@
+CC = lcc
+CFLAGS = -I../../.. -A -ansic -libcdll 
+#LDFLAGS = -L../../../xp/bas -L../../../xp/stx
+#LIBS = -lxpstx -lxpbas
+#LDFLAGS = -subsystem console -dynamic -s
+LDFLAGS = -subsystem console -s
+LIBS = ..\..\..\xp\stx\xpstx.lib ..\..\..\xp\bas\xpbas.lib 
+
+all: stx parser
+
+stx: stx.obj
+	lcclnk $(LDFLAGS) -o stx.exe stx.obj $(LIBS)
+
+parser: parser.obj
+	lcclnk $(LDFLAGS) -o parser.exe parser.obj $(LIBS)
+
+
+clean:
+	del $(OBJS) *.obj $(OUT)
+
+.SUFFIXES: .c .obj
+.c.obj:
+	$(CC) $(CFLAGS) -c $< 
+

ase/cmd/stx/makefile.tcc

@@ -0,0 +1,19 @@
+SRCS = stx.c
+OBJS = stx.obj
+OUT = stx.exe
+
+TC = \dos\tc
+CC = $(TC)\tcc
+CFLAGS = -I..\..\.. -ml -D_DOS -w
+LIBS = $(TC)\lib\cl.lib $(TC)\lib\c0l.obj ..\..\..\xp\stx\xpstx.lib
+
+all: $(OBJS)
+	$(TC)\tlink $(OBJS),$(OUT),,$(LIBS)
+
+clean:
+	del $(OBJS) *.obj $(OUT)
+
+.SUFFIXES: .c .obj
+.c.obj:
+	$(CC) $(CFLAGS) -c $< 
+

ase/cmd/stx/parser.c

@@ -0,0 +1,230 @@
+#include <xp/stx/stx.h>
+
+#ifdef _DOS
+	#include <stdio.h>
+	#define xp_printf printf
+#else
+	#include <xp/bas/stdio.h>
+	#include <xp/bas/locale.h>
+#endif
+
+#include <xp/stx/parser.h>
+#include <xp/stx/bootstrp.h>
+#include <xp/stx/class.h>
+#include <xp/stx/bytecode.h>
+#include <xp/stx/interp.h>
+
+#ifdef __linux
+#include <mcheck.h>
+#endif
+
+struct ss_t
+{
+	const xp_char_t* text;
+	xp_size_t index;
+};
+
+typedef struct ss_t ss_t;
+
+int ss_func (int cmd, void* owner, void* arg)
+{
+
+	if (cmd == XP_STX_PARSER_INPUT_OPEN) {
+		ss_t* ss = *(ss_t**)owner;
+		ss->text = (const xp_char_t*)arg;
+		ss->index = 0;
+		return 0;
+	}
+	else if (cmd == XP_STX_PARSER_INPUT_CLOSE) {
+		/*ss_t* ss = (ss_t*)owner; */
+		return 0;
+	}
+	else if (cmd == XP_STX_PARSER_INPUT_CONSUME) {
+		ss_t* ss = (ss_t*)owner;
+		xp_cint_t* c = (xp_cint_t*)arg;
+		if (ss->text[ss->index] == XP_CHAR('\0')) {
+			*c = XP_CHAR_EOF;
+		}
+		else *c = ss->text[ss->index++];
+		return 0;
+	}
+	else if (cmd == XP_STX_PARSER_INPUT_REWIND) {
+		return 0;
+	}
+	return -1;
+}
+
+struct stdio_t
+{
+	XP_FILE* stdio;
+};
+
+typedef struct stdio_t stdio_t;
+
+int stdio_func (int cmd, void* owner, void* arg)
+{
+
+	if (cmd == XP_STX_PARSER_INPUT_OPEN) {
+		stdio_t* p = *(stdio_t**)owner;
+		p->stdio = xp_fopen ((const xp_char_t*)arg, XP_TEXT("r"));
+		if (p->stdio == XP_NULL) return -1;
+		return 0;
+	}
+	else if (cmd == XP_STX_PARSER_INPUT_CLOSE) {
+		stdio_t* p = (stdio_t*)owner;
+		xp_fclose (p->stdio);
+		return 0;
+	}
+	else if (cmd == XP_STX_PARSER_INPUT_CONSUME) {
+		stdio_t* p = (stdio_t*)owner;
+		xp_cint_t* c = (xp_cint_t*)arg;
+		xp_cint_t t = xp_fgetc (p->stdio);	
+		if (t == XP_CHAR_EOF) {
+			if (xp_ferror (p->stdio)) return -1;
+			*c = XP_CHAR_EOF;
+		}
+		else *c = t;
+		return 0;
+	}
+	else if (cmd == XP_STX_PARSER_INPUT_REWIND) {
+		return 0;
+	}
+	return -1;
+}
+
+int xp_main (int argc, xp_char_t* argv[])
+{
+	xp_stx_t stx;
+	xp_stx_parser_t parser;
+
+#ifdef __linux
+	mtrace ();
+#endif
+
+/*
+#ifndef _DOS
+	if (xp_setlocale () == -1) {
+		printf ("cannot set locale\n");
+		return -1;
+	}
+#endif
+*/
+
+	if (argc != 2) {
+		xp_printf (XP_TEXT("usage: %s class_name\n"), argv[0]);
+		return -1;
+	}
+
+	if (xp_stx_open (&stx, 10000) == XP_NULL) {
+		xp_printf (XP_TEXT("cannot open stx\n"));
+		return -1;
+	}
+
+	if (xp_stx_bootstrap(&stx) == -1) {
+		xp_stx_close (&stx);
+		xp_printf (XP_TEXT("cannot bootstrap\n"));
+		return -1;
+	}
+
+
+	if (xp_stx_parser_open(&parser, &stx) == XP_NULL) {
+		xp_printf (XP_TEXT("cannot open parser\n"));
+		return -1;
+	}
+
+
+	{
+	/*
+		ss_t ss;
+		parser.input_owner = (void*)&ss;
+		parser.input_func = ss_func;
+		xp_stx_parser_parse_method (&parser, 0, 
+			XP_TEXT("isNil\n^true"));
+	*/
+		stdio_t stdio;
+		xp_word_t n = xp_stx_lookup_class (&stx, argv[1]);
+		xp_word_t m;
+
+		parser.input_owner = (void*)&stdio;
+		parser.input_func = stdio_func;
+
+		if (n == stx.nil) {
+			xp_printf (XP_TEXT("Cannot find class - %s\n"), argv[1]);
+			goto exit_program;
+		}
+
+		/* compile the method to n's class */
+		if (xp_stx_parser_parse_method (&parser, XP_STX_CLASS(&stx,n), 
+			(void*)XP_TEXT("test.st")) == -1) {
+			xp_printf (XP_TEXT("parser error <%s>\n"), 
+				xp_stx_parser_error_string (&parser));
+		}
+
+		if (xp_stx_parser_parse_method (&parser, stx.class_symbol,
+			(void*)XP_TEXT("test1.st")) == -1) {
+			xp_printf (XP_TEXT("parser error <%s>\n"), 
+				xp_stx_parser_error_string (&parser));
+		}
+
+		if (xp_stx_parser_parse_method (&parser, stx.class_symbol,
+			(void*)XP_TEXT("test2.st")) == -1) {
+			xp_printf (XP_TEXT("parser error <%s>\n"), 
+				xp_stx_parser_error_string (&parser));
+		}
+
+		if (xp_stx_parser_parse_method (&parser, stx.class_string,
+			(void*)XP_TEXT("test3.st")) == -1) {
+			xp_printf (XP_TEXT("parser error <%s>\n"), 
+				xp_stx_parser_error_string (&parser));
+		}
+
+		xp_printf (XP_TEXT("\n== Decoded Methods ==\n"));
+		if (xp_stx_decode(&stx, XP_STX_CLASS(&stx,n)) == -1) {
+			xp_printf (XP_TEXT("parser error <%s>\n"), 
+				xp_stx_parser_error_string (&parser));
+		}
+
+		xp_printf (XP_TEXT("\n== Decoded Methods for Symbol ==\n"));
+		if (xp_stx_decode(&stx, stx.class_symbol) == -1) {
+			xp_printf (XP_TEXT("parser error <%s>\n"), 
+				xp_stx_parser_error_string (&parser));
+		}
+
+		xp_printf (XP_TEXT("\n== Decoded Methods for String ==\n"));
+		if (xp_stx_decode(&stx, stx.class_string) == -1) {
+			xp_printf (XP_TEXT("parser error <%s>\n"), 
+				xp_stx_parser_error_string (&parser));
+		}
+
+		xp_printf (XP_TEXT("== Running the main method ==\n"));
+		m = xp_stx_lookup_method (
+			&stx, XP_STX_CLASS(&stx,n), XP_TEXT("main"), xp_false);
+		if (m == stx.nil) {	
+			xp_printf (XP_TEXT("cannot lookup method main\n"));
+		}
+		else {
+			xp_stx_interp (&stx, n, m);
+		}
+	}
+
+exit_program:
+	xp_stx_parser_close (&parser);
+	xp_stx_close (&stx);
+	xp_printf (XP_TEXT("== End of program ==\n"));
+
+#ifdef __linux
+	muntrace ();
+#endif
+	
+/*
+#ifdef __linux
+	{
+		char buf[1000];
+		snprintf (buf, sizeof(buf), "ls -l /proc/%u/fd", getpid());
+		system (buf);
+	}
+#endif
+*/
+	return 0;
+}
+

ase/cmd/stx/stx.c

@@ -0,0 +1,237 @@
+#include <xp/stx/stx.h>
+
+#ifdef _DOS
+	#include <stdio.h>
+	#define xp_printf printf
+#else
+	#include <xp/bas/stdio.h>
+	#include <xp/bas/locale.h>
+#endif
+
+#include <xp/stx/bootstrp.h>
+#include <xp/stx/object.h>
+#include <xp/stx/symbol.h>
+#include <xp/stx/context.h>
+#include <xp/stx/class.h>
+#include <xp/stx/dict.h>
+
+void print_symbol_names (xp_stx_t* stx, xp_word_t sym, void* unused)
+{
+	xp_printf (XP_TEXT("%lu [%s]\n"), (unsigned long)sym, XP_STX_DATA(stx,sym));
+}
+
+void print_symbol_names_2 (xp_stx_t* stx, xp_word_t idx, void* unused)
+{
+	xp_word_t key = XP_STX_WORD_AT(stx,idx,XP_STX_ASSOCIATION_KEY);
+	xp_word_t value = XP_STX_WORD_AT(stx,idx,XP_STX_ASSOCIATION_VALUE);
+	xp_printf (XP_TEXT("%lu [%s] %lu\n"), 
+		(unsigned long)key, XP_STX_DATA(stx,key), (unsigned long)value);
+}
+
+void print_superclasses (xp_stx_t* stx, const xp_char_t* name)
+{
+	xp_word_t n;
+	xp_stx_class_t* obj;
+
+	n = xp_stx_lookup_class (stx, name);
+	xp_printf (XP_TEXT("Class hierarchy for the class '%s'\n"), name);
+
+	while (n != stx->nil) {
+		obj = (xp_stx_class_t*)XP_STX_WORD_OBJECT(stx,n);
+		xp_printf (XP_TEXT("%lu, %s\n"), 
+			(unsigned long)obj->name,
+			XP_STX_DATA(stx, obj->name));
+		n = obj->superclass;
+	}
+}
+
+void print_metaclass_superclasses (xp_stx_t* stx, const xp_char_t* name)
+{
+	xp_word_t n, x;
+	xp_stx_metaclass_t* obj;
+	xp_stx_class_t* xobj;
+
+	n = xp_stx_lookup_class (stx, name);
+	n = XP_STX_CLASS(stx,n);
+	xp_printf (XP_TEXT("Class hierarchy for the metaclass '%s class'\n"), name);
+
+	while (n != stx->nil) {
+		/*if (n == stx->class_class) break; */
+		if (XP_STX_CLASS(stx,n) != stx->class_metaclass) break;
+
+		obj = (xp_stx_metaclass_t*)XP_STX_WORD_OBJECT(stx,n);
+		x = obj->instance_class;
+		xobj = (xp_stx_class_t*)XP_STX_WORD_OBJECT(stx,x);
+		xp_printf (XP_TEXT("%lu, %s class\n"), 
+			(unsigned long)xobj->name,
+			XP_STX_DATA(stx, xobj->name));
+		n = obj->superclass;
+	}
+	while (n != stx->nil) {
+		xobj = (xp_stx_class_t*)XP_STX_WORD_OBJECT(stx,n);
+		xp_printf (XP_TEXT("%lu, %s\n"), 
+			(unsigned long)xobj->name,
+			XP_STX_DATA(stx, xobj->name));
+		n = xobj->superclass;
+	}
+}
+
+void print_class_name (xp_stx_t* stx, xp_word_t class, int tabs)
+{
+	xp_stx_class_t* xobj;
+	xobj = (xp_stx_class_t*)XP_STX_WORD_OBJECT(stx,class);
+
+	while (tabs-- > 0) xp_printf (XP_TEXT("  "));
+
+	xp_printf (XP_TEXT("%s [%lu]\n"), 
+		XP_STX_DATA(stx, xobj->name),
+		(unsigned long)class);
+}
+
+void print_metaclass_name (xp_stx_t* stx, xp_word_t class, int tabs)
+{
+	xp_stx_metaclass_t* obj;
+	xp_stx_class_t* xobj;
+
+	obj = (xp_stx_metaclass_t*)XP_STX_WORD_OBJECT(stx,class);
+	xobj = (xp_stx_class_t*)XP_STX_WORD_OBJECT(stx,obj->instance_class);
+
+	while (tabs-- > 0) xp_printf (XP_TEXT("  "));
+
+	xp_printf (XP_TEXT("%s class [%lu]\n"), 
+		XP_STX_DATA(stx, xobj->name),
+		(unsigned long)class);
+}
+
+void print_subclass_names (xp_stx_t* stx, xp_word_t class, int tabs)
+{
+	xp_stx_class_t* obj;
+
+	obj = (xp_stx_class_t*)XP_STX_WORD_OBJECT(stx,class);
+	if (obj->header.class == stx->class_metaclass) {
+		print_metaclass_name (stx, class, tabs);
+	}
+	else {
+		print_class_name (stx, class, tabs);
+	}
+
+	if (obj->subclasses != stx->nil) {
+		xp_word_t count = XP_STX_SIZE(stx, obj->subclasses);
+		while (count-- > 0) {
+			print_subclass_names (stx, 
+				XP_STX_WORD_AT(stx,obj->subclasses,count), tabs + 1);
+		}
+	}
+}
+
+void print_subclasses (xp_stx_t* stx, const xp_char_t* name)
+{
+	xp_word_t class;
+	class = xp_stx_lookup_class (stx, name);	
+	xp_printf (XP_TEXT("== NORMAL == \n"));
+	print_subclass_names (stx, class, 0);
+	xp_printf (XP_TEXT("== META == \n"));
+	print_subclass_names (stx, XP_STX_CLASS(stx,class), 0);
+}
+
+int xp_main (int argc, xp_char_t* argv[])
+{
+	xp_stx_t stx;
+	//xp_word_t i;
+
+#ifndef _DOS
+	if (xp_setlocale () == -1) {
+		printf ("cannot set locale\n");
+		return -1;
+	}
+#endif
+
+	if (argc != 2) { /* TODO: argument processing */
+		xp_printf (XP_TEXT("Usage: %s [-f imageFile] MainClass\n"), argv[0]);
+		return -1;
+	}
+
+	if (xp_stx_open (&stx, 10000) == XP_NULL) {
+		xp_printf (XP_TEXT("cannot open stx\n"));
+		return -1;
+	}
+
+	if (xp_stx_bootstrap(&stx) == -1) {
+		xp_stx_close (&stx);
+		xp_printf (XP_TEXT("cannot bootstrap\n"));
+		return -1;
+	}	
+
+	xp_printf (XP_TEXT("stx.nil %lu\n"), (unsigned long)stx.nil);
+	xp_printf (XP_TEXT("stx.true %lu\n"), (unsigned long)stx.true);
+	xp_printf (XP_TEXT("stx.false %lu\n"), (unsigned long)stx.false);
+	xp_printf (XP_TEXT("-------------\n"));
+	
+	
+	xp_printf (XP_TEXT(">> SYMBOL_TABLE (%u/%u symbols/slots) <<\n"), 
+		(unsigned int)stx.symtab.size, (unsigned int)stx.symtab.capacity);
+	xp_stx_traverse_symbol_table (&stx, print_symbol_names, XP_NULL);
+	xp_printf (XP_TEXT("-------------\n"));
+
+	xp_stx_dict_traverse (&stx, stx.smalltalk, print_symbol_names_2, XP_NULL);
+	xp_printf (XP_TEXT("-------------\n"));
+
+	print_superclasses (&stx, XP_TEXT("Array"));
+	xp_printf (XP_TEXT("-------------\n"));
+	print_metaclass_superclasses (&stx, XP_TEXT("Array"));
+	xp_printf (XP_TEXT("-------------\n"));
+	print_superclasses (&stx, XP_TEXT("False"));
+	xp_printf (XP_TEXT("-------------\n"));
+	print_metaclass_superclasses (&stx, XP_TEXT("False"));
+	xp_printf (XP_TEXT("-------------\n"));
+	print_superclasses (&stx, XP_TEXT("Metaclass"));
+	xp_printf (XP_TEXT("-------------\n"));
+	print_metaclass_superclasses (&stx, XP_TEXT("Metaclass"));
+	xp_printf (XP_TEXT("-------------\n"));
+	print_superclasses (&stx, XP_TEXT("Class"));
+	xp_printf (XP_TEXT("-------------\n"));
+	print_metaclass_superclasses (&stx, XP_TEXT("Class"));
+	xp_printf (XP_TEXT("-------------\n"));
+
+	print_subclasses (&stx, XP_TEXT("Object"));
+	xp_printf (XP_TEXT("-------------\n"));
+
+#if 0
+	{
+		xp_word_t method_name;
+		xp_word_t main_class;
+		xp_word_t method, context;
+
+		method_name = xp_stx_new_symbol (&stx,XP_TEXT("main"));
+
+		main_class = xp_stx_lookup_class (&stx,argv[1]);
+		if (main_class == stx.nil) {
+			xp_printf (XP_TEXT("non-existent class: %s\n"), argv[1]);
+			return -1;
+		}
+
+		/*
+		method = xp_stx_alloc_byte_object (&stx,100);
+		XP_STX_CLASS(&stx,method) = stx.class_method;
+		*/
+		method = xp_stx_instantiate (&stx, XP_TEXT("Method"));
+
+		XP_STX_BYTEAT(&stx,method,0) = PUSH_OBJECT;
+		XP_STX_BYTEAT(&stx,method,1) = main_class;
+		XP_STX_BYTEAT(&stx,method,2) = SEND_UNARY_MESSAGE;
+		XP_STX_BYTEAT(&stx,method,3) = method_name;
+		XP_STX_BYTEAT(&stx,method,4) = HALT;
+
+		/*
+		context = xp_stx_new_context (&stx, method, stx.nil, stx.nil);
+		*/
+		context = xp_stx_instantiate (&stx, XP_TEXT("Context"));
+		xp_stx_run_context (&stx, context);
+	}
+#endif
+
+	xp_stx_close (&stx);
+	xp_printf (XP_TEXT("== End of program ==\n"));
+	return 0;
+}
+

ase/cmd/stx/test.st

@@ -0,0 +1,13 @@
+main
+	| a |
+	<primitive: 0>
+
+	"a := 10.
+	#abc xxx.
+	#abc xxx: 1.
+	^nil	"
+
+	a := #abc print: 123 and: 2345.
+	#abc print: a and: a.
+	1234567.
+	^nil.

ase/cmd/stx/test1.st

@@ -0,0 +1,10 @@
+print: a1 and: a2
+	| t1 t2 |
+	<primitive: 3>
+	t1 := #abcdefg.
+	"a1 := 2341 arguments are not assignable"
+	t2 := a2.
+	t1 prim2: t2.
+	super prim2: 999999.
+	self prim2: 999999.
+	^67891.

ase/cmd/stx/test2.st

@@ -0,0 +1,2 @@
+prim2: n
+	<primitive: 2>

ase/cmd/stx/test3.st

@@ -0,0 +1,2 @@
+prim2: n
+	<primitive: 20>