Initial revision

Grammar/Grammar

@@ -0,0 +1,71 @@
+# Grammar for Python, version 3
+
+# Changes compared to version 2:
+#	The syntax of Boolean operations is changed to use more
+#	conventional priorities: or < and < not.
+
+# Changes compared to version 1:
+#	modules and scripts are unified;
+#	'quit' is gone (use ^D);
+#	empty_stmt is gone, replaced by explicit NEWLINE where appropriate;
+#	'import' and 'def' aren't special any more;
+#	added 'from' NAME option on import clause, and '*' to import all;
+#	added class definition.
+# TO DO:
+#	replace 'dir' by something more general?
+
+# Start symbols for the grammar:
+#	single_input is a single interactive statement;
+#	file_input is a module or sequence of commands read from an input file;
+#	expr_input is the input for the input() function;
+#	eval_input is the input for the eval() function.
+
+# NB: compound_stmt in single_input is followed by extra NEWLINE!
+single_input: NEWLINE | simple_stmt | compound_stmt NEWLINE
+file_input: (NEWLINE | stmt)* ENDMARKER
+expr_input: testlist NEWLINE
+eval_input: testlist ENDMARKER
+
+funcdef: 'def' NAME parameters ':' suite
+parameters: '(' [fplist] ')'
+fplist: fpdef (',' fpdef)*
+fpdef: NAME | '(' fplist ')'
+
+stmt: simple_stmt | compound_stmt
+simple_stmt: expr_stmt | print_stmt  | pass_stmt | del_stmt | dir_stmt | flow_stmt | import_stmt
+expr_stmt: (exprlist '=')* exprlist NEWLINE
+# For assignments, additional restrictions enforced by the interpreter
+print_stmt: 'print' (test ',')* [test] NEWLINE
+del_stmt: 'del' exprlist NEWLINE
+dir_stmt: 'dir' [expr] NEWLINE
+pass_stmt: 'pass' NEWLINE
+flow_stmt: break_stmt | return_stmt | raise_stmt
+break_stmt: 'break' NEWLINE
+return_stmt: 'return' [testlist] NEWLINE
+raise_stmt: 'raise' expr [',' expr] NEWLINE
+import_stmt: 'import' NAME (',' NAME)* NEWLINE | 'from' NAME 'import' ('*' | NAME (',' NAME)*) NEWLINE
+compound_stmt: if_stmt | while_stmt | for_stmt | try_stmt | funcdef | classdef
+if_stmt: 'if' test ':' suite ('elif' test ':' suite)* ['else' ':' suite]
+while_stmt: 'while' test ':' suite ['else' ':' suite]
+for_stmt: 'for' exprlist 'in' exprlist ':' suite ['else' ':' suite]
+try_stmt: 'try' ':' suite (except_clause ':' suite)* ['finally' ':' suite]
+except_clause: 'except' [expr [',' expr]]
+suite: simple_stmt | NEWLINE INDENT NEWLINE* (stmt NEWLINE*)+ DEDENT
+
+test: and_test ('or' and_test)*
+and_test: not_test ('and' not_test)*
+not_test: 'not' not_test | comparison
+comparison: expr (comp_op expr)*
+comp_op: '<'|'>'|'='|'>' '='|'<' '='|'<' '>'|'in'|'not' 'in'|'is'|'is' 'not'
+expr: term (('+'|'-') term)*
+term: factor (('*'|'/'|'%') factor)*
+factor: ('+'|'-') factor | atom trailer*
+atom: '(' [testlist] ')' | '[' [testlist] ']' | '{' '}' | '`' testlist '`' | NAME | NUMBER | STRING
+trailer: '(' [exprlist] ')' | '[' subscript ']' | '.' NAME
+subscript: expr | [expr] ':' [expr]
+exprlist: expr (',' expr)* [',']
+testlist: test (',' test)* [',']
+
+classdef: 'class' NAME parameters ['=' baselist] ':' suite
+baselist: atom arguments (',' atom arguments)*
+arguments: '(' [testlist] ')'

Include/assert.h

@@ -0,0 +1 @@
+#define assert(e) { if (!(e)) { printf("Assertion failed\n"); abort(); } }

Include/bitset.h

@@ -0,0 +1,22 @@
+/* Bitset interface */
+
+#define BYTE		char
+
+typedef BYTE *bitset;
+
+bitset newbitset PROTO((int nbits));
+void delbitset PROTO((bitset bs));
+/* int testbit PROTO((bitset bs, int ibit)); /* Now a macro, see below */
+int addbit PROTO((bitset bs, int ibit)); /* Returns 0 if already set */
+int samebitset PROTO((bitset bs1, bitset bs2, int nbits));
+void mergebitset PROTO((bitset bs1, bitset bs2, int nbits));
+
+#define BITSPERBYTE	(8*sizeof(BYTE))
+#define NBYTES(nbits)	(((nbits) + BITSPERBYTE - 1) / BITSPERBYTE)
+
+#define BIT2BYTE(ibit)	((ibit) / BITSPERBYTE)
+#define BIT2SHIFT(ibit)	((ibit) % BITSPERBYTE)
+#define BIT2MASK(ibit)	(1 << BIT2SHIFT(ibit))
+#define BYTE2BIT(ibyte)	((ibyte) * BITSPERBYTE)
+
+#define testbit(ss, ibit) (((ss)[BIT2BYTE(ibit)] & BIT2MASK(ibit)) != 0)

Include/cgensupport.h

@@ -0,0 +1,15 @@
+/* Definitions used by cgen output */
+
+typedef char *string;
+
+#define mknewlongobject(x) newintobject(x)
+#define mknewshortobject(x) newintobject((long)x)
+#define mknewfloatobject(x) newfloatobject(x)
+
+extern object *mknewcharobject PROTO((int c));
+
+extern int getiobjectarg PROTO((object *args, int nargs, int i, object **p_a));
+extern int getilongarg PROTO((object *args, int nargs, int i, long *p_a));
+extern int getishortarg PROTO((object *args, int nargs, int i, short *p_a));
+extern int getifloatarg PROTO((object *args, int nargs, int i, float *p_a));
+extern int getistringarg PROTO((object *args, int nargs, int i, string *p_a));

Include/classobject.h

@@ -0,0 +1,20 @@
+/* Class object interface */
+
+/*
+Classes are really hacked in at the last moment.
+It should be possible to use other object types as base classes,
+but currently it isn't.  We'll see if we can fix that later, sigh...
+*/
+
+extern typeobject Classtype, Classmembertype, Classmethodtype;
+
+#define is_classobject(op) ((op)->ob_type == &Classtype)
+#define is_classmemberobject(op) ((op)->ob_type == &Classmembertype)
+#define is_classmethodobject(op) ((op)->ob_type == &Classmethodtype)
+
+extern object *newclassobject PROTO((node *, object *, object *));
+extern object *newclassmemberobject PROTO((object *));
+extern object *newclassmethodobject PROTO((object *, object *));
+
+extern object *classmethodgetfunc PROTO((object *));
+extern object *classmethodgetself PROTO((object *));

Include/dictobject.h

@@ -0,0 +1,25 @@
+/*
+Dictionary object type -- mapping from char * to object.
+NB: the key is given as a char *, not as a stringobject.
+These functions set errno for errors.  Functions dictremove() and
+dictinsert() return nonzero for errors, getdictsize() returns -1,
+the others NULL.  A successful call to dictinsert() calls INCREF()
+for the inserted item.
+*/
+
+extern typeobject Dicttype;
+
+#define is_dictobject(op) ((op)->ob_type == &Dicttype)
+
+extern object *newdictobject PROTO((void));
+extern object *dictlookup PROTO((object *dp, char *key));
+extern int dictinsert PROTO((object *dp, char *key, object *item));
+extern int dictremove PROTO((object *dp, char *key));
+extern int getdictsize PROTO((object *dp));
+extern char *getdictkey PROTO((object *dp, int i));
+
+/* New interface with (string)object * instead of char * arguments */
+extern object *dict2lookup PROTO((object *dp, object *key));
+extern int dict2insert PROTO((object *dp, object *key, object *item));
+extern int dict2remove PROTO((object *dp, object *key));
+extern object *getdict2key PROTO((object *dp, int i));

Include/errcode.h

@@ -0,0 +1,12 @@
+/* Error codes passed around between file input, tokenizer, parser and
+   interpreter.  This was necessary so we can turn them into Python
+   exceptions at a higher level. */
+
+#define E_OK		10	/* No error */
+#define E_EOF		11	/* (Unexpected) EOF read */
+#define E_INTR		12	/* Interrupted */
+#define E_TOKEN		13	/* Bad token */
+#define E_SYNTAX	14	/* Syntax error */
+#define E_NOMEM		15	/* Ran out of memory */
+#define E_DONE		16	/* Parsing complete */
+#define E_ERROR		17	/* Execution error */

Include/errors.h

@@ -0,0 +1,17 @@
+/* Error handling definitions */
+
+void err_set PROTO((object *));
+void err_setval PROTO((object *, object *));
+void err_setstr PROTO((object *, char *));
+int err_occurred PROTO((void));
+void err_get PROTO((object **, object **));
+void err_clear PROTO((void));
+
+/* Predefined exceptions (in run.c) */
+object *RuntimeError;		/* Raised by error() */
+object *EOFError;		/* Raised by eof_error() */
+object *TypeError;		/* Rased by type_error() */
+object *MemoryError;		/* Raised by mem_error() */
+object *NameError;		/* Raised by name_error() */
+object *SystemError;		/* Raised by sys_error() */
+object *KeyboardInterrupt;	/* Raised by intr_error() */

Include/fileobject.h

@@ -0,0 +1,9 @@
+/* File object interface */
+
+extern typeobject Filetype;
+
+#define is_fileobject(op) ((op)->ob_type == &Filetype)
+
+extern object *newfileobject PROTO((char *, char *));
+extern object *newopenfileobject PROTO((FILE *, char *, char *));
+extern FILE *getfilefile PROTO((object *));

Include/floatobject.h

@@ -0,0 +1,20 @@
+/* Float object interface */
+
+/*
+floatobject represents a (double precision) floating point number.
+*/
+
+typedef struct {
+	OB_HEAD
+	double ob_fval;
+} floatobject;
+
+extern typeobject Floattype;
+
+#define is_floatobject(op) ((op)->ob_type == &Floattype)
+
+extern object *newfloatobject PROTO((double));
+extern double getfloatvalue PROTO((object *));
+
+/* Macro, trading safety for speed */
+#define GETFLOATVALUE(op) ((op)->ob_fval)

Include/funcobject.h

@@ -0,0 +1,9 @@
+/* Function object interface */
+
+extern typeobject Functype;
+
+#define is_funcobject(op) ((op)->ob_type == &Functype)
+
+extern object *newfuncobject PROTO((node *, object *));
+extern node *getfuncnode PROTO((object *));
+extern object *getfuncglobals PROTO((object *));

Include/graminit.h

@@ -0,0 +1,43 @@
+#define single_input 256
+#define file_input 257
+#define expr_input 258
+#define eval_input 259
+#define funcdef 260
+#define parameters 261
+#define fplist 262
+#define fpdef 263
+#define stmt 264
+#define simple_stmt 265
+#define expr_stmt 266
+#define print_stmt 267
+#define del_stmt 268
+#define dir_stmt 269
+#define pass_stmt 270
+#define flow_stmt 271
+#define break_stmt 272
+#define return_stmt 273
+#define raise_stmt 274
+#define import_stmt 275
+#define compound_stmt 276
+#define if_stmt 277
+#define while_stmt 278
+#define for_stmt 279
+#define try_stmt 280
+#define except_clause 281
+#define suite 282
+#define test 283
+#define and_test 284
+#define not_test 285
+#define comparison 286
+#define comp_op 287
+#define expr 288
+#define term 289
+#define factor 290
+#define atom 291
+#define trailer 292
+#define subscript 293
+#define exprlist 294
+#define testlist 295
+#define classdef 296
+#define baselist 297
+#define arguments 298

Include/grammar.h

@@ -0,0 +1,78 @@
+/* Grammar interface */
+
+#include "bitset.h" /* Sigh... */
+
+/* A label of an arc */
+
+typedef struct _label {
+	int	lb_type;
+	char	*lb_str;
+} label;
+
+#define EMPTY 0		/* Label number 0 is by definition the empty label */
+
+/* A list of labels */
+
+typedef struct _labellist {
+	int	ll_nlabels;
+	label	*ll_label;
+} labellist;
+
+/* An arc from one state to another */
+
+typedef struct _arc {
+	short		a_lbl;		/* Label of this arc */
+	short		a_arrow;	/* State where this arc goes to */
+} arc;
+
+/* A state in a DFA */
+
+typedef struct _state {
+	int		 s_narcs;
+	arc		*s_arc;		/* Array of arcs */
+	
+	/* Optional accelerators */
+	int		 s_lower;	/* Lowest label index */
+	int		 s_upper;	/* Highest label index */
+	int		*s_accel;	/* Accelerator */
+	int		 s_accept;	/* Nonzero for accepting state */
+} state;
+
+/* A DFA */
+
+typedef struct _dfa {
+	int		 d_type;	/* Non-terminal this represents */
+	char		*d_name;	/* For printing */
+	int		 d_initial;	/* Initial state */
+	int		 d_nstates;
+	state		*d_state;	/* Array of states */
+	bitset		 d_first;
+} dfa;
+
+/* A grammar */
+
+typedef struct _grammar {
+	int		 g_ndfas;
+	dfa		*g_dfa;		/* Array of DFAs */
+	labellist	 g_ll;
+	int		 g_start;	/* Start symbol of the grammar */
+	int		 g_accel;	/* Set if accelerators present */
+} grammar;
+
+/* FUNCTIONS */
+
+grammar *newgrammar PROTO((int start));
+dfa *adddfa PROTO((grammar *g, int type, char *name));
+int addstate PROTO((dfa *d));
+void addarc PROTO((dfa *d, int from, int to, int lbl));
+dfa *finddfa PROTO((grammar *g, int type));
+char *typename PROTO((grammar *g, int lbl));
+
+int addlabel PROTO((labellist *ll, int type, char *str));
+int findlabel PROTO((labellist *ll, int type, char *str));
+char *labelrepr PROTO((label *lb));
+void translatelabels PROTO((grammar *g));
+
+void addfirstsets PROTO((grammar *g));
+
+void addaccellerators PROTO((grammar *g));

Include/import.h

@@ -0,0 +1,7 @@
+/* Module definition and import interface */
+
+void init_modules PROTO(());
+void close_modules PROTO(());
+object *new_module PROTO((char *name));
+void define_module PROTO((struct _context *ctx, char *name));
+object *import_module PROTO((struct _context *ctx, char *name));

Include/intobject.h

@@ -0,0 +1,48 @@
+/* Integer object interface */
+
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+intobject represents a (long) integer.  This is an immutable object;
+an integer cannot change its value after creation.
+
+There are functions to create new integer objects, to test an object
+for integer-ness, and to get the integer value.  The latter functions
+returns -1 and sets errno to EBADF if the object is not an intobject.
+None of the functions should be applied to nil objects.
+
+The type intobject is (unfortunately) exposed bere so we can declare
+TrueObject and FalseObject below; don't use this.
+*/
+
+typedef struct {
+	OB_HEAD
+	long ob_ival;
+} intobject;
+
+extern typeobject Inttype;
+
+#define is_intobject(op) ((op)->ob_type == &Inttype)
+
+extern object *newintobject PROTO((long));
+extern long getintvalue PROTO((object *));
+
+
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+False and True are special intobjects used by Boolean expressions.
+All values of type Boolean must point to either of these; but in
+contexts where integers are required they are integers (valued 0 and 1).
+Hope these macros don't conflict with other people's.
+
+Don't forget to apply INCREF() when returning True or False!!!
+*/
+
+extern intobject FalseObject, TrueObject; /* Don't use these directly */
+
+#define False ((object *) &FalseObject)
+#define True ((object *) &TrueObject)
+
+/* Macro, trading safety for speed */
+#define GETINTVALUE(op) ((op)->ob_ival)

Include/listobject.h

@@ -0,0 +1,26 @@
+/* List object interface */
+
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+Another generally useful object type is an list of object pointers.
+This is a mutable type: the list items can be changed, and items can be
+added or removed.  Out-of-range indices or non-list objects are ignored.
+
+*** WARNING *** setlistitem does not increment the new item's reference
+count, but does decrement the reference count of the item it replaces,
+if not nil.  It does *decrement* the reference count if it is *not*
+inserted in the list.  Similarly, getlistitem does not increment the
+returned item's reference count.
+*/
+
+extern typeobject Listtype;
+
+#define is_listobject(op) ((op)->ob_type == &Listtype)
+
+extern object *newlistobject PROTO((int size));
+extern int getlistsize PROTO((object *));
+extern object *getlistitem PROTO((object *, int));
+extern int setlistitem PROTO((object *, int, object *));
+extern int inslistitem PROTO((object *, int, object *));
+extern int addlistitem PROTO((object *, object *));

Include/metagrammar.h

@@ -0,0 +1,6 @@
+#define MSTART 256
+#define RULE 257
+#define RHS 258
+#define ALT 259
+#define ITEM 260
+#define ATOM 261

Include/methodobject.h

@@ -0,0 +1,11 @@
+/* Method object interface */
+
+extern typeobject Methodtype;
+
+#define is_methodobject(op) ((op)->ob_type == &Methodtype)
+
+typedef object *(*method) FPROTO((object *, object *));
+
+extern object *newmethodobject PROTO((char *, method, object *));
+extern method getmethod PROTO((object *));
+extern object *getself PROTO((object *));

Include/modsupport.h

@@ -0,0 +1,11 @@
+/* Module support interface */
+
+struct methodlist {
+	char *ml_name;
+	method ml_meth;
+};
+
+extern object *findmethod PROTO((struct methodlist *, object *, char *));
+extern object *initmodule PROTO((char *, struct methodlist *));
+extern int err_badargs PROTO((void));
+extern object *err_nomem PROTO((void));

Include/moduleobject.h

@@ -0,0 +1,9 @@
+/* Module object interface */
+
+extern typeobject Moduletype;
+
+#define is_moduleobject(op) ((op)->ob_type == &Moduletype)
+
+extern object *newmoduleobject PROTO((char *));
+extern object *getmoduledict PROTO((object *));
+extern int setmoduledict PROTO((object *, object *));

Include/node.h

@@ -0,0 +1,29 @@
+/* Parse tree node interface */
+
+typedef struct _node {
+	int		n_type;
+	char		*n_str;
+	int		n_nchildren;
+	struct _node	*n_child;
+} node;
+
+extern node *newnode PROTO((int type));
+extern node *addchild PROTO((node *n, int type, char *str));
+
+/* Node access functions */
+#define NCH(n)		((n)->n_nchildren)
+#define CHILD(n, i)	(&(n)->n_child[i])
+#define TYPE(n)		((n)->n_type)
+#define STR(n)		((n)->n_str)
+
+/* Assert that the type of a node is what we expect */
+#ifndef DEBUG
+#define REQ(n, type) { /*pass*/ ; }
+#else
+#define REQ(n, type) \
+	{ if (TYPE(n) != (type)) { \
+		fprintf(stderr, "FATAL: node type %d, required %d\n", \
+			TYPE(n), type); \
+		abort(); \
+	} }
+#endif

Include/object.h

@@ -0,0 +1,310 @@
+/* Object and type object interface */
+
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+Objects are structures allocated on the heap.  Special rules apply to
+the use of objects to ensure they are properly garbage-collected.
+Objects are never allocated statically or on the stack; they must be
+accessed through special macros and functions only.  (Type objects are
+exceptions to the first rule; the standard types are represented by
+statically initialized type objects.)
+
+An object has a 'reference count' that is increased or decreased when a
+pointer to the object is copied or deleted; when the reference count
+reaches zero there are no references to the object left and it can be
+removed from the heap.
+
+An object has a 'type' that determines what it represents and what kind
+of data it contains.  An object's type is fixed when it is created.
+Types themselves are represented as objects; an object contains a
+pointer to the corresponding type object.  The type itself has a type
+pointer pointing to the object representing the type 'type', which
+contains a pointer to itself!).
+
+Objects do not float around in memory; once allocated an object keeps
+the same size and address.  Objects that must hold variable-size data
+can contain pointers to variable-size parts of the object.  Not all
+objects of the same type have the same size; but the size cannot change
+after allocation.  (These restrictions are made so a reference to an
+object can be simply a pointer -- moving an object would require
+updating all the pointers, and changing an object's size would require
+moving it if there was another object right next to it.)
+
+Objects are always accessed through pointers of the type 'object *'.
+The type 'object' is a structure that only contains the reference count
+and the type pointer.  The actual memory allocated for an object
+contains other data that can only be accessed after casting the pointer
+to a pointer to a longer structure type.  This longer type must start
+with the reference count and type fields; the macro OB_HEAD should be
+used for this (to accomodate for future changes).  The implementation
+of a particular object type can cast the object pointer to the proper
+type and back.
+
+A standard interface exists for objects that contain an array of items
+whose size is determined when the object is allocated.
+
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+*/
+
+#ifdef THINK_C
+/* Debugging options for THINK_C (which has no -D compiler option): */
+/*#define TRACE_REFS*/
+/*#define REF_DEBUG*/
+#endif
+
+#ifdef TRACE_REFS
+#define OB_HEAD \
+	struct _object *_ob_next, *_ob_prev; \
+	unsigned int ob_refcnt; \
+	struct _typeobject *ob_type;
+#define OB_HEAD_INIT(type) 0, 0, 1, type,
+#else
+#define OB_HEAD \
+	unsigned int ob_refcnt; \
+	struct _typeobject *ob_type;
+#define OB_HEAD_INIT(type) 1, type,
+#endif
+
+#define OB_VARHEAD \
+	OB_HEAD \
+	unsigned int ob_size; /* Number of items in variable part */
+ 
+typedef struct _object {
+	OB_HEAD
+} object;
+
+typedef struct {
+	OB_VARHEAD
+} varobject;
+
+
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+Type objects contain a string containing the type name (to help somewhat
+in debugging), the allocation parameters (see newobj() and newvarobj()),
+and methods for accessing objects of the type.  Methods are optional,a
+nil pointer meaning that particular kind of access is not available for
+this type.  The DECREF() macro uses the tp_dealloc method without
+checking for a nil pointer; it should always be implemented except if
+the implementation can guarantee that the reference count will never
+reach zero (e.g., for type objects).
+
+NB: the methods for certain type groups are now contained in separate
+method blocks.
+*/
+
+typedef struct {
+	object *(*nb_add) FPROTO((object *, object *));
+	object *(*nb_subtract) FPROTO((object *, object *));
+	object *(*nb_multiply) FPROTO((object *, object *));
+	object *(*nb_divide) FPROTO((object *, object *));
+	object *(*nb_remainder) FPROTO((object *, object *));
+	object *(*nb_power) FPROTO((object *, object *));
+	object *(*nb_negative) FPROTO((object *));
+	object *(*nb_positive) FPROTO((object *));
+} number_methods;
+
+typedef struct {
+	int (*sq_length) FPROTO((object *));
+	object *(*sq_concat) FPROTO((object *, object *));
+	object *(*sq_repeat) FPROTO((object *, int));
+	object *(*sq_item) FPROTO((object *, int));
+	object *(*sq_slice) FPROTO((object *, int, int));
+	int (*sq_ass_item) FPROTO((object *, int, object *));
+	int (*sq_ass_slice) FPROTO((object *, int, int, object *));
+} sequence_methods;
+
+typedef struct {
+	int (*mp_length) FPROTO((object *));
+	object *(*mp_subscript) FPROTO((object *, object *));
+	int (*mp_ass_subscript) FPROTO((object *, object *, object *));
+} mapping_methods;
+
+typedef struct _typeobject {
+	OB_VARHEAD
+	char *tp_name; /* For printing */
+	unsigned int tp_basicsize, tp_itemsize; /* For allocation */
+	
+	/* Methods to implement standard operations */
+	
+	void (*tp_dealloc) FPROTO((object *));
+	void (*tp_print) FPROTO((object *, FILE *, int));
+	object *(*tp_getattr) FPROTO((object *, char *));
+	int (*tp_setattr) FPROTO((object *, char *, object *));
+	int (*tp_compare) FPROTO((object *, object *));
+	object *(*tp_repr) FPROTO((object *));
+	
+	/* Method suites for standard classes */
+	
+	number_methods *tp_as_number;
+	sequence_methods *tp_as_sequence;
+	mapping_methods *tp_as_mapping;
+} typeobject;
+
+extern typeobject Typetype; /* The type of type objects */
+
+#define is_typeobject(op) ((op)->ob_type == &Typetype)
+
+extern void printobject PROTO((object *, FILE *, int));
+extern object * reprobject PROTO((object *));
+extern int cmpobject PROTO((object *, object *));
+
+/* Flag bits for printing: */
+#define PRINT_RAW	1	/* No string quotes etc. */
+
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+The macros INCREF(op) and DECREF(op) are used to increment or decrement
+reference counts.  DECREF calls the object's deallocator function; for
+objects that don't contain references to other objects or heap memory
+this can be the standard function free().  Both macros can be used
+whereever a void expression is allowed.  The argument shouldn't be a
+NIL pointer.  The macro NEWREF(op) is used only to initialize reference
+counts to 1; it is defined here for convenience.
+
+We assume that the reference count field can never overflow; this can
+be proven when the size of the field is the same as the pointer size
+but even with a 16-bit reference count field it is pretty unlikely so
+we ignore the possibility.  (If you are paranoid, make it a long.)
+
+Type objects should never be deallocated; the type pointer in an object
+is not considered to be a reference to the type object, to save
+complications in the deallocation function.  (This is actually a
+decision that's up to the implementer of each new type so if you want,
+you can count such references to the type object.)
+
+*** WARNING*** The DECREF macro must have a side-effect-free argument
+since it may evaluate its argument multiple times.  (The alternative
+would be to mace it a proper function or assign it to a global temporary
+variable first, both of which are slower; and in a multi-threaded
+environment the global variable trick is not safe.)
+*/
+
+#ifdef TRACE_REFS
+#ifndef REF_DEBUG
+#define REF_DEBUG
+#endif
+#endif
+
+#ifndef TRACE_REFS
+#define DELREF(op) (*(op)->ob_type->tp_dealloc)((object *)(op))
+#endif
+
+#ifdef REF_DEBUG
+extern long ref_total;
+#ifndef TRACE_REFS
+#define NEWREF(op) (ref_total++, (op)->ob_refcnt = 1)
+#endif
+#define INCREF(op) (ref_total++, (op)->ob_refcnt++)
+#define DECREF(op) \
+	if (--ref_total, --(op)->ob_refcnt != 0) \
+		; \
+	else \
+		DELREF(op)
+#else
+#define NEWREF(op) ((op)->ob_refcnt = 1)
+#define INCREF(op) ((op)->ob_refcnt++)
+#define DECREF(op) \
+	if (--(op)->ob_refcnt != 0) \
+		; \
+	else \
+		DELREF(op)
+#endif
+
+
+/* Definition of NULL, so you don't have to include <stdio.h> */
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+
+/*
+NoObject is an object of undefined type which can be used in contexts
+where NULL (nil) is not suitable (since NULL often means 'error').
+
+Don't forget to apply INCREF() when returning this value!!!
+*/
+
+extern object NoObject; /* Don't use this directly */
+
+#define None (&NoObject)
+
+
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+More conventions
+================
+
+Argument Checking
+-----------------
+
+Functions that take objects as arguments normally don't check for nil
+arguments, but they do check the type of the argument, and return an
+error if the function doesn't apply to the type.
+
+Failure Modes
+-------------
+
+Functions may fail for a variety of reasons, including running out of
+memory.  This is communicated to the caller in two ways: 'errno' is set
+to indicate the error, and the function result differs: functions that
+normally return a pointer return nil for failure, functions returning
+an integer return -1 (which can be a legal return value too!), and
+other functions return 0 for success and the error number for failure.
+Callers should always check for errors before using the result.  The
+following error codes are used:
+
+	EBADF		bad object type (first argument only)
+	EINVAL		bad argument type (second and further arguments)
+	ENOMEM		no memory (malloc failed)
+	ENOENT		key not found in dictionary
+	EDOM		index out of range or division by zero
+	ERANGE		result not representable
+	
+	XXX any others?
+
+Reference Counts
+----------------
+
+It takes a while to get used to the proper usage of reference counts.
+
+Functions that create an object set the reference count to 1; such new
+objects must be stored somewhere or destroyed again with DECREF().
+Functions that 'store' objects such as settupleitem() and dictinsert()
+don't increment the reference count of the object, since the most
+frequent use is to store a fresh object.  Functions that 'retrieve'
+objects such as gettupleitem() and dictlookup() also don't increment
+the reference count, since most frequently the object is only looked at
+quickly.  Thus, to retrieve an object and store it again, the caller
+must call INCREF() explicitly.
+
+NOTE: functions that 'consume' a reference count like dictinsert() even
+consume the reference if the object wasn't stored, to simplify error
+handling.
+
+It seems attractive to make other functions that take an object as
+argument consume a reference count; however this may quickly get
+confusing (even the current practice is already confusing).  Consider
+it carefully, it may safe lots of calls to INCREF() and DECREF() at
+times.
+
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+*/
+
+/* Error number interface */
+#include <errno.h>
+
+#ifndef errno
+extern int errno;
+#endif
+
+#ifdef THINK_C
+/* Lightspeed C doesn't define these in <errno.h> */
+#define EDOM 33
+#define ERANGE 34
+#endif

Include/objimpl.h

@@ -0,0 +1,31 @@
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+Additional macros for modules that implement new object types.
+You must first include "object.h".
+
+NEWOBJ(type, typeobj) allocates memory for a new object of the given
+type; here 'type' must be the C structure type used to represent the
+object and 'typeobj' the address of the corresponding type object.
+Reference count and type pointer are filled in; the rest of the bytes of
+the object are *undefined*!  The resulting expression type is 'type *'.
+The size of the object is actually determined by the tp_basicsize field
+of the type object.
+
+NEWVAROBJ(type, typeobj, n) is similar but allocates a variable-size
+object with n extra items.  The size is computer as tp_basicsize plus
+n * tp_itemsize.  This fills in the ob_size field as well.
+*/
+
+extern object *newobject PROTO((typeobject *));
+extern varobject *newvarobject PROTO((typeobject *, unsigned int));
+
+#define NEWOBJ(type, typeobj) ((type *) newobject(typeobj))
+#define NEWVAROBJ(type, typeobj, n) ((type *) newvarobject(typeobj, n))
+
+extern int StopPrint; /* Set when printing is interrupted */
+
+/* Malloc interface */
+#include "malloc.h"
+
+extern char *strdup PROTO((char *));

Include/parsetok.h

@@ -0,0 +1,9 @@
+/* Parser-tokenizer link interface */
+
+#if 0
+extern int parsetok PROTO((struct tok_state *, grammar *, int start,
+							node **n_ret));
+#endif
+extern int parsestring PROTO((char *, grammar *, int start, node **n_ret));
+extern int parsefile PROTO((FILE *, grammar *, int start,
+					char *ps1, char *ps2, node **n_ret));

Include/pyerrors.h

@@ -0,0 +1,17 @@
+/* Error handling definitions */
+
+void err_set PROTO((object *));
+void err_setval PROTO((object *, object *));
+void err_setstr PROTO((object *, char *));
+int err_occurred PROTO((void));
+void err_get PROTO((object **, object **));
+void err_clear PROTO((void));
+
+/* Predefined exceptions (in run.c) */
+object *RuntimeError;		/* Raised by error() */
+object *EOFError;		/* Raised by eof_error() */
+object *TypeError;		/* Rased by type_error() */
+object *MemoryError;		/* Raised by mem_error() */
+object *NameError;		/* Raised by name_error() */
+object *SystemError;		/* Raised by sys_error() */
+object *KeyboardInterrupt;	/* Raised by intr_error() */

Include/stringobject.h

@@ -0,0 +1,39 @@
+/* String object interface */
+
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+Type stringobject represents a character string.  An extra zero byte is
+reserved at the end to ensure it is zero-terminated, but a size is
+present so strings with null bytes in them can be represented.  This
+is an immutable object type.
+
+There are functions to create new string objects, to test
+an object for string-ness, and to get the
+string value.  The latter function returns a null pointer
+if the object is not of the proper type.
+There is a variant that takes an explicit size as well as a
+variant that assumes a zero-terminated string.  Note that none of the
+functions should be applied to nil objects.
+*/
+
+/* NB The type is revealed here only because it is used in dictobject.c */
+
+typedef struct {
+	OB_VARHEAD
+	char ob_sval[1];
+} stringobject;
+
+extern typeobject Stringtype;
+
+#define is_stringobject(op) ((op)->ob_type == &Stringtype)
+
+extern object *newsizedstringobject PROTO((char *, int));
+extern object *newstringobject PROTO((char *));
+extern unsigned int getstringsize PROTO((object *));
+extern char *getstringvalue PROTO((object *));
+extern void joinstring PROTO((object **, object *));
+extern int resizestring PROTO((object **, int));
+
+/* Macro, trading safety for speed */
+#define GETSTRINGVALUE(op) ((op)->ob_sval)

Include/sysmodule.h

@@ -0,0 +1,6 @@
+/* System module interface */
+
+object *sysget PROTO((char *));
+int sysset PROTO((char *, object *));
+FILE *sysgetfile PROTO((char *, FILE *));
+void initsys PROTO((int, char **));

Include/token.h

@@ -0,0 +1,45 @@
+/* Token types */
+
+#define ENDMARKER	0
+#define NAME		1
+#define NUMBER		2
+#define STRING		3
+#define NEWLINE		4
+#define INDENT		5
+#define DEDENT		6
+#define LPAR		7
+#define RPAR		8
+#define LSQB		9
+#define RSQB		10
+#define COLON		11
+#define COMMA		12
+#define SEMI		13
+#define PLUS		14
+#define MINUS		15
+#define STAR		16
+#define SLASH		17
+#define VBAR		18
+#define AMPER		19
+#define LESS		20
+#define GREATER		21
+#define EQUAL		22
+#define DOT		23
+#define PERCENT		24
+#define BACKQUOTE	25
+#define LBRACE		26
+#define RBRACE		27
+#define OP		28
+#define ERRORTOKEN	29
+#define N_TOKENS	30
+
+/* Special definitions for cooperation with parser */
+
+#define NT_OFFSET		256
+
+#define ISTERMINAL(x)		((x) < NT_OFFSET)
+#define ISNONTERMINAL(x)	((x) >= NT_OFFSET)
+#define ISEOF(x)		((x) == ENDMARKER)
+
+
+extern char *tok_name[]; /* Token names */
+extern int tok_1char PROTO((int));

Include/tupleobject.h

@@ -0,0 +1,24 @@
+/* Tuple object interface */
+
+/*
+123456789-123456789-123456789-123456789-123456789-123456789-123456789-12
+
+Another generally useful object type is an tuple of object pointers.
+This is a mutable type: the tuple items can be changed (but not their
+number).  Out-of-range indices or non-tuple objects are ignored.
+
+*** WARNING *** settupleitem does not increment the new item's reference
+count, but does decrement the reference count of the item it replaces,
+if not nil.  It does *decrement* the reference count if it is *not*
+inserted in the tuple.  Similarly, gettupleitem does not increment the
+returned item's reference count.
+*/
+
+extern typeobject Tupletype;
+
+#define is_tupleobject(op) ((op)->ob_type == &Tupletype)
+
+extern object *newtupleobject PROTO((int size));
+extern int gettuplesize PROTO((object *));
+extern object *gettupleitem PROTO((object *, int));
+extern int settupleitem PROTO((object *, int, object *));

Modules/cgen.py

@@ -0,0 +1,458 @@
+# Python script to parse cstubs file for gl and generate C stubs.
+# usage: python cgen <cstubs >glmodule.c
+#
+# XXX BUG return arrays generate wrong code
+# XXX need to change error returns into gotos to free mallocked arrays
+
+
+import string
+import sys
+
+
+# Function to print to stderr
+#
+def err(args):
+	savestdout = sys.stdout
+	try:
+		sys.stdout = sys.stderr
+		for i in args:
+			print i,
+		print
+	finally:
+		sys.stdout = savestdout
+
+
+# The set of digits that form a number
+#
+digits = '0123456789'
+
+
+# Function to extract a string of digits from the front of the string.
+# Returns the leading string of digits and the remaining string.
+# If no number is found, returns '' and the original string.
+#
+def getnum(s):
+	n = ''
+	while s[:1] in digits:
+		n = n + s[:1]
+		s = s[1:]
+	return n, s
+
+
+# Function to check if a string is a number
+#
+def isnum(s):
+	if not s: return 0
+	for c in s:
+		if not c in digits: return 0
+	return 1
+
+
+# Allowed function return types
+#
+return_types = ['void', 'short', 'long']
+
+
+# Allowed function argument types
+#
+arg_types = ['char', 'string', 'short', 'float', 'long', 'double']
+
+
+# Need to classify arguments as follows
+#	simple input variable
+#	simple output variable
+#	input array
+#	output array
+#	input giving size of some array
+#
+# Array dimensions can be specified as follows
+#	constant
+#	argN
+#	constant * argN
+#	retval
+#	constant * retval
+#
+# The dimensions given as constants * something are really
+# arrays of points where points are 2- 3- or 4-tuples
+#
+# We have to consider three lists:
+#	python input arguments
+#	C stub arguments (in & out)
+#	python output arguments (really return values)
+#
+# There is a mapping from python input arguments to the input arguments
+# of the C stub, and a further mapping from C stub arguments to the
+# python return values
+
+
+# Exception raised by checkarg() and generate()
+#
+arg_error = 'bad arg'
+
+
+# Function to check one argument.
+# Arguments: the type and the arg "name" (really mode plus subscript).
+# Raises arg_error if something's wrong.
+# Return type, mode, factor, rest of subscript; factor and rest may be empty.
+#
+def checkarg(type, arg):
+	#
+	# Turn "char *x" into "string x".
+	#
+	if type = 'char' and arg[0] = '*':
+		type = 'string'
+		arg = arg[1:]
+	#
+	# Check that the type is supported.
+	#
+	if type not in arg_types:
+		raise arg_error, ('bad type', type)
+	#
+	# Split it in the mode (first character) and the rest.
+	#
+	mode, rest = arg[:1], arg[1:]
+	#
+	# The mode must be 's' for send (= input) or 'r' for return argument.
+	#
+	if mode not in ('r', 's'):
+		raise arg_error, ('bad arg mode', mode)
+	#
+	# Is it a simple argument: if so, we are done.
+	#
+	if not rest:
+		return type, mode, '', ''
+	#	
+	# Not a simple argument; must be an array.
+	# The 'rest' must be a subscript enclosed in [ and ].
+	# The subscript must be one of the following forms,
+	# otherwise we don't handle it (where N is a number):
+	#	N
+	#	argN
+	#	retval
+	#	N*argN
+	#	N*retval
+	#
+	if rest[:1] <> '[' or rest[-1:] <> ']':
+		raise arg_error, ('subscript expected', rest)
+	sub = rest[1:-1]
+	#
+	# Is there a leading number?
+	#
+	num, sub = getnum(sub)
+	if num:
+		# There is a leading number
+		if not sub:
+			# The subscript is just a number
+			return type, mode, num, ''
+		if sub[:1] = '*':
+			# There is a factor prefix
+			sub = sub[1:]
+		else:
+			raise arg_error, ('\'*\' expected', sub)
+	if sub = 'retval':
+		# size is retval -- must be a reply argument
+		if mode <> 'r':
+			raise arg_error, ('non-r mode with [retval]', mode)
+	elif sub[:3] <> 'arg' or not isnum(sub[3:]):
+		raise arg_error, ('bad subscript', sub)
+	#
+	return type, mode, num, sub
+
+
+# List of functions for which we have generated stubs
+#
+functions = []
+
+
+# Generate the stub for the given function, using the database of argument
+# information build by successive calls to checkarg()
+#
+def generate(type, func, database):
+	#
+	# Check that we can handle this case:
+	# no variable size reply arrays yet
+	#
+	n_in_args = 0
+	n_out_args = 0
+	#
+	for a_type, a_mode, a_factor, a_sub in database:
+		if a_mode = 's':
+			n_in_args = n_in_args + 1
+		elif a_mode = 'r':
+			n_out_args = n_out_args + 1
+		else:
+			# Can't happen
+			raise arg_error, ('bad a_mode', a_mode)
+		if (a_mode = 'r' and a_sub) or a_sub = 'retval':
+			e = 'Function', func, 'too complicated:'
+			err(e + (a_type, a_mode, a_factor, a_sub))
+			print '/* XXX Too complicated to generate code for */'
+			return
+	#
+	functions.append(func)
+	#
+	# Stub header
+	#
+	print
+	print 'static object *'
+	print 'gl_' + func + '(self, args)'
+	print '\tobject *self;'
+	print '\tobject *args;'
+	print '{'
+	#
+	# Declare return value if any
+	#
+	if type <> 'void':
+		print '\t' + type, 'retval;'
+	#
+	# Declare arguments
+	#
+	for i in range(len(database)):
+		a_type, a_mode, a_factor, a_sub = database[i]
+		print '\t' + a_type,
+		if a_sub:
+			print '*',
+		print 'arg' + `i+1`,
+		if a_factor and not a_sub:
+			print '[', a_factor, ']',
+		print ';'
+	#
+	# Find input arguments derived from array sizes
+	#
+	for i in range(len(database)):
+		a_type, a_mode, a_factor, a_sub = database[i]
+		if a_mode = 's' and a_sub[:3] = 'arg' and isnum(a_sub[3:]):
+			# Sending a variable-length array
+			n = eval(a_sub[3:])
+			if 1 <= n <= len(database):
+			    b_type, b_mode, b_factor, b_sub = database[n-1]
+			    if b_mode = 's':
+			        database[n-1] = b_type, 'i', a_factor, `i`
+			        n_in_args = n_in_args - 1
+	#
+	# Assign argument positions in the Python argument list
+	#
+	in_pos = []
+	i_in = 0
+	for i in range(len(database)):
+		a_type, a_mode, a_factor, a_sub = database[i]
+		if a_mode = 's':
+			in_pos.append(i_in)
+			i_in = i_in + 1
+		else:
+			in_pos.append(-1)
+	#
+	# Get input arguments
+	#
+	for i in range(len(database)):
+		a_type, a_mode, a_factor, a_sub = database[i]
+		if a_mode = 'i':
+			#
+			# Implicit argument;
+			# a_factor is divisor if present,
+			# a_sub indicates which arg (`database index`)
+			#
+			j = eval(a_sub)
+			print '\tif',
+			print '(!geti' + a_type + 'arraysize(args,',
+			print `n_in_args` + ',',
+			print `in_pos[j]` + ',',
+			print '&arg' + `i+1` + '))'
+			print '\t\treturn NULL;'
+			if a_factor:
+				print '\targ' + `i+1`,
+				print '= arg' + `i+1`,
+				print '/', a_factor + ';'
+		elif a_mode = 's':
+			if a_sub: # Allocate memory for varsize array
+				print '\tif ((arg' + `i+1`, '=',
+				print 'NEW(' + a_type + ',',
+				if a_factor: print a_factor, '*',
+				print a_sub, ')) == NULL)'
+				print '\t\treturn err_nomem();'
+			print '\tif',
+			if a_factor or a_sub: # Get a fixed-size array array
+				print '(!geti' + a_type + 'array(args,',
+				print `n_in_args` + ',',
+				print `in_pos[i]` + ',',
+				if a_factor: print a_factor,
+				if a_factor and a_sub: print '*',
+				if a_sub: print a_sub,
+				print ', arg' + `i+1` + '))'
+			else: # Get a simple variable
+				print '(!geti' + a_type + 'arg(args,',
+				print `n_in_args` + ',',
+				print `in_pos[i]` + ',',
+				print '&arg' + `i+1` + '))'
+			print '\t\treturn NULL;'
+	#
+	# Begin of function call
+	#
+	if type <> 'void':
+		print '\tretval =', func + '(',
+	else:
+		print '\t' + func + '(',
+	#
+	# Argument list
+	#
+	for i in range(len(database)):
+		if i > 0: print ',',
+		a_type, a_mode, a_factor, a_sub = database[i]
+		if a_mode = 'r' and not a_factor:
+			print '&',
+		print 'arg' + `i+1`,
+	#
+	# End of function call
+	#
+	print ');'
+	#
+	# Free varsize arrays
+	#
+	for i in range(len(database)):
+		a_type, a_mode, a_factor, a_sub = database[i]
+		if a_mode = 's' and a_sub:
+			print '\tDEL(arg' + `i+1` + ');'
+	#
+	# Return
+	#
+	if n_out_args:
+		#
+		# Multiple return values -- construct a tuple
+		#
+		if type <> 'void':
+			n_out_args = n_out_args + 1
+		if n_out_args = 1:
+			for i in range(len(database)):
+				a_type, a_mode, a_factor, a_sub = database[i]
+				if a_mode = 'r':
+					break
+			else:
+				raise arg_error, 'expected r arg not found'
+			print '\treturn',
+			print mkobject(a_type, 'arg' + `i+1`) + ';'
+		else:
+			print '\t{ object *v = newtupleobject(',
+			print n_out_args, ');'
+			print '\t  if (v == NULL) return NULL;'
+			i_out = 0
+			if type <> 'void':
+				print '\t  settupleitem(v,',
+				print `i_out` + ',',
+				print mkobject(type, 'retval') + ');'
+				i_out = i_out + 1
+			for i in range(len(database)):
+				a_type, a_mode, a_factor, a_sub = database[i]
+				if a_mode = 'r':
+					print '\t  settupleitem(v,',
+					print `i_out` + ',',
+					s = mkobject(a_type, 'arg' + `i+1`)
+					print s + ');'
+					i_out = i_out + 1
+			print '\t  return v;'
+			print '\t}'
+	else:
+		#
+		# Simple function return
+		# Return None or return value
+		#
+		if type = 'void':
+			print '\tINCREF(None);'
+			print '\treturn None;'
+		else:
+			print '\treturn', mkobject(type, 'retval') + ';'
+	#
+	# Stub body closing brace
+	#
+	print '}'
+
+
+# Subroutine to return a function call to mknew<type>object(<arg>)
+#
+def mkobject(type, arg):
+	return 'mknew' + type + 'object(' + arg + ')'
+
+
+# Input line number
+lno = 0
+
+
+# Input is divided in two parts, separated by a line containing '%%'.
+#	<part1>		-- literally copied to stdout
+#	<part2>		-- stub definitions
+
+# Variable indicating the current input part.
+#
+part = 1
+
+# Main loop over the input
+#
+while 1:
+	try:
+		line = raw_input()
+	except EOFError:
+		break
+	#
+	lno = lno+1
+	words = string.split(line)
+	#
+	if part = 1:
+		#
+		# In part 1, copy everything literally
+		# except look for a line of just '%%'
+		#
+		if words = ['%%']:
+			part = part + 1
+		else:
+			#
+			# Look for names of manually written
+			# stubs: a single percent followed by the name
+			# of the function in Python.
+			# The stub name is derived by prefixing 'gl_'.
+			#
+			if words and words[0][0] = '%':
+				func = words[0][1:]
+				if (not func) and words[1:]:
+					func = words[1]
+				if func:
+					functions.append(func)
+			else:
+				print line
+	elif not words:
+		pass			# skip empty line
+	elif words[0] = '#include':
+		print line
+	elif words[0][:1] = '#':
+		pass			# ignore comment
+	elif words[0] not in return_types:
+		err('Line', lno, ': bad return type :', words[0])
+	elif len(words) < 2:
+		err('Line', lno, ': no funcname :', line)
+	else:
+		if len(words) % 2 <> 0:
+			err('Line', lno, ': odd argument list :', words[2:])
+		else:
+			database = []
+			try:
+				for i in range(2, len(words), 2):
+					x = checkarg(words[i], words[i+1])
+					database.append(x)
+				print
+				print '/*',
+				for w in words: print w,
+				print '*/'
+				generate(words[0], words[1], database)
+			except arg_error, msg:
+				err('Line', lno, ':', msg)
+
+
+print
+print 'static struct methodlist gl_methods[] = {'
+for func in functions:
+	print '\t{"' + func + '", gl_' + func + '},'
+print '\t{NULL, NULL} /* Sentinel */'
+print '};'
+print
+print 'initgl()'
+print '{'
+print '\tinitmodule("gl", gl_methods);'
+print '}'

Modules/cgensupport.c

@@ -0,0 +1,369 @@
+/* Functions used by cgen output */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "intobject.h"
+#include "floatobject.h"
+#include "stringobject.h"
+#include "tupleobject.h"
+#include "listobject.h"
+#include "methodobject.h"
+#include "moduleobject.h"
+#include "modsupport.h"
+#include "import.h"
+#include "cgensupport.h"
+#include "errors.h"
+
+
+/* Functions to construct return values */
+
+object *
+mknewcharobject(c)
+	int c;
+{
+	char ch[1];
+	ch[0] = c;
+	return newsizedstringobject(ch, 1);
+}
+
+/* Functions to extract arguments.
+   These needs to know the total number of arguments supplied,
+   since the argument list is a tuple only of there is more than
+   one argument. */
+
+int
+getiobjectarg(args, nargs, i, p_arg)
+	register object *args;
+	int nargs, i;
+	object **p_arg;
+{
+	if (nargs != 1) {
+		if (args == NULL || !is_tupleobject(args) ||
+				nargs != gettuplesize(args) ||
+				i < 0 || i >= nargs) {
+			return err_badarg();
+		}
+		else {
+			args = gettupleitem(args, i);
+		}
+	}
+	if (args == NULL) {
+		return err_badarg();
+	}
+	*p_arg = args;
+	return 1;
+}
+
+int
+getilongarg(args, nargs, i, p_arg)
+	register object *args;
+	int nargs, i;
+	long *p_arg;
+{
+	if (nargs != 1) {
+		if (args == NULL || !is_tupleobject(args) ||
+				nargs != gettuplesize(args) ||
+				i < 0 || i >= nargs) {
+			return err_badarg();
+		}
+		args = gettupleitem(args, i);
+	}
+	if (args == NULL || !is_intobject(args)) {
+		return err_badarg();
+	}
+	*p_arg = getintvalue(args);
+	return 1;
+}
+
+int
+getishortarg(args, nargs, i, p_arg)
+	register object *args;
+	int nargs, i;
+	short *p_arg;
+{
+	long x;
+	if (!getilongarg(args, nargs, i, &x))
+		return 0;
+	*p_arg = x;
+	return 1;
+}
+
+static int
+extractdouble(v, p_arg)
+	register object *v;
+	double *p_arg;
+{
+	if (v == NULL) {
+		/* Fall through to error return at end of function */
+	}
+	else if (is_floatobject(v)) {
+		*p_arg = GETFLOATVALUE((floatobject *)v);
+		return 1;
+	}
+	else if (is_intobject(v)) {
+		*p_arg = GETINTVALUE((intobject *)v);
+		return 1;
+	}
+	return err_badarg();
+}
+
+static int
+extractfloat(v, p_arg)
+	register object *v;
+	float *p_arg;
+{
+	if (v == NULL) {
+		/* Fall through to error return at end of function */
+	}
+	else if (is_floatobject(v)) {
+		*p_arg = GETFLOATVALUE((floatobject *)v);
+		return 1;
+	}
+	else if (is_intobject(v)) {
+		*p_arg = GETINTVALUE((intobject *)v);
+		return 1;
+	}
+	return err_badarg();
+}
+
+int
+getifloatarg(args, nargs, i, p_arg)
+	register object *args;
+	int nargs, i;
+	float *p_arg;
+{
+	object *v;
+	float x;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (!extractfloat(v, &x))
+		return 0;
+	*p_arg = x;
+	return 1;
+}
+
+int
+getistringarg(args, nargs, i, p_arg)
+	object *args;
+	int nargs, i;
+	string *p_arg;
+{
+	object *v;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return NULL;
+	if (!is_stringobject(v)) {
+		return err_badarg();
+	}
+	*p_arg = getstringvalue(v);
+	return 1;
+}
+
+int
+getichararg(args, nargs, i, p_arg)
+	object *args;
+	int nargs, i;
+	char *p_arg;
+{
+	string x;
+	if (!getistringarg(args, nargs, i, &x))
+		return 0;
+	if (x[0] == '\0' || x[1] != '\0') {
+		/* Not exactly one char */
+		return err_badarg();
+	}
+	*p_arg = x[0];
+	return 1;
+}
+
+int
+getilongarraysize(args, nargs, i, p_arg)
+	object *args;
+	int nargs, i;
+	long *p_arg;
+{
+	object *v;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		*p_arg = gettuplesize(v);
+		return 1;
+	}
+	if (is_listobject(v)) {
+		*p_arg = getlistsize(v);
+		return 1;
+	}
+	return err_badarg();
+}
+
+int
+getishortarraysize(args, nargs, i, p_arg)
+	object *args;
+	int nargs, i;
+	short *p_arg;
+{
+	long x;
+	if (!getilongarraysize(args, nargs, i, &x))
+		return 0;
+	*p_arg = x;
+	return 1;
+}
+
+/* XXX The following four are too similar.  Should share more code. */
+
+int
+getilongarray(args, nargs, i, n, p_arg)
+	object *args;
+	int nargs, i;
+	int n;
+	long *p_arg; /* [n] */
+{
+	object *v, *w;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		if (gettuplesize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = gettupleitem(v, i);
+			if (!is_intobject(w)) {
+				return err_badarg();
+			}
+			p_arg[i] = getintvalue(w);
+		}
+		return 1;
+	}
+	else if (is_listobject(v)) {
+		if (getlistsize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = getlistitem(v, i);
+			if (!is_intobject(w)) {
+				return err_badarg();
+			}
+			p_arg[i] = getintvalue(w);
+		}
+		return 1;
+	}
+	else {
+		return err_badarg();
+	}
+}
+
+int
+getishortarray(args, nargs, i, n, p_arg)
+	object *args;
+	int nargs, i;
+	int n;
+	short *p_arg; /* [n] */
+{
+	object *v, *w;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		if (gettuplesize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = gettupleitem(v, i);
+			if (!is_intobject(w)) {
+				return err_badarg();
+			}
+			p_arg[i] = getintvalue(w);
+		}
+		return 1;
+	}
+	else if (is_listobject(v)) {
+		if (getlistsize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = getlistitem(v, i);
+			if (!is_intobject(w)) {
+				return err_badarg();
+			}
+			p_arg[i] = getintvalue(w);
+		}
+		return 1;
+	}
+	else {
+		return err_badarg();
+	}
+}
+
+int
+getidoublearray(args, nargs, i, n, p_arg)
+	object *args;
+	int nargs, i;
+	int n;
+	double *p_arg; /* [n] */
+{
+	object *v, *w;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		if (gettuplesize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = gettupleitem(v, i);
+			if (!extractdouble(w, &p_arg[i]))
+				return 0;
+		}
+		return 1;
+	}
+	else if (is_listobject(v)) {
+		if (getlistsize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = getlistitem(v, i);
+			if (!extractdouble(w, &p_arg[i]))
+				return 0;
+		}
+		return 1;
+	}
+	else {
+		return err_badarg();
+	}
+}
+
+int
+getifloatarray(args, nargs, i, n, p_arg)
+	object *args;
+	int nargs, i;
+	int n;
+	float *p_arg; /* [n] */
+{
+	object *v, *w;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		if (gettuplesize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = gettupleitem(v, i);
+			if (!extractfloat(w, &p_arg[i]))
+				return 0;
+		}
+		return 1;
+	}
+	else if (is_listobject(v)) {
+		if (getlistsize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = getlistitem(v, i);
+			if (!extractfloat(w, &p_arg[i]))
+				return 0;
+		}
+		return 1;
+	}
+	else {
+		return err_badarg();
+	}
+}

Modules/cgensupport.h

@@ -0,0 +1,15 @@
+/* Definitions used by cgen output */
+
+typedef char *string;
+
+#define mknewlongobject(x) newintobject(x)
+#define mknewshortobject(x) newintobject((long)x)
+#define mknewfloatobject(x) newfloatobject(x)
+
+extern object *mknewcharobject PROTO((int c));
+
+extern int getiobjectarg PROTO((object *args, int nargs, int i, object **p_a));
+extern int getilongarg PROTO((object *args, int nargs, int i, long *p_a));
+extern int getishortarg PROTO((object *args, int nargs, int i, short *p_a));
+extern int getifloatarg PROTO((object *args, int nargs, int i, float *p_a));
+extern int getistringarg PROTO((object *args, int nargs, int i, string *p_a));

Modules/mathmodule.c

@@ -0,0 +1,167 @@
+/* Math module -- standard C math library functions, pi and e */
+
+#include <stdio.h>
+#include <math.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "intobject.h"
+#include "tupleobject.h"
+#include "floatobject.h"
+#include "dictobject.h"
+#include "methodobject.h"
+#include "moduleobject.h"
+#include "objimpl.h"
+#include "import.h"
+#include "modsupport.h"
+
+static int
+getdoublearg(args, px)
+	register object *args;
+	double *px;
+{
+	if (args == NULL)
+		return err_badarg();
+	if (is_floatobject(args)) {
+		*px = getfloatvalue(args);
+		return 1;
+	}
+	if (is_intobject(args)) {
+		*px = getintvalue(args);
+		return 1;
+	}
+	return err_badarg();
+}
+
+static int
+get2doublearg(args, px, py)
+	register object *args;
+	double *px, *py;
+{
+	if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 2)
+		return err_badarg();
+	return getdoublearg(gettupleitem(args, 0), px) &&
+		getdoublearg(gettupleitem(args, 1), py);
+}
+
+static object *
+math_1(args, func)
+	object *args;
+	double (*func) FPROTO((double));
+{
+	double x;
+	if (!getdoublearg(args, &x))
+		return NULL;
+	errno = 0;
+	x = (*func)(x);
+	if (errno != 0)
+		return NULL;
+	else
+		return newfloatobject(x);
+}
+
+static object *
+math_2(args, func)
+	object *args;
+	double (*func) FPROTO((double, double));
+{
+	double x, y;
+	if (!get2doublearg(args, &x, &y))
+		return NULL;
+	errno = 0;
+	x = (*func)(x, y);
+	if (errno != 0)
+		return NULL;
+	else
+		return newfloatobject(x);
+}
+
+#define FUNC1(stubname, func) \
+	static object * stubname(self, args) object *self, *args; { \
+		return math_1(args, func); \
+	}
+
+#define FUNC2(stubname, func) \
+	static object * stubname(self, args) object *self, *args; { \
+		return math_2(args, func); \
+	}
+
+FUNC1(math_acos, acos)
+FUNC1(math_asin, asin)
+FUNC1(math_atan, atan)
+FUNC2(math_atan2, atan2)
+FUNC1(math_ceil, ceil)
+FUNC1(math_cos, cos)
+FUNC1(math_cosh, cosh)
+FUNC1(math_exp, exp)
+FUNC1(math_fabs, fabs)
+FUNC1(math_floor, floor)
+#if 0
+/* XXX This one is not in the Amoeba library yet, so what the heck... */
+FUNC2(math_fmod, fmod)
+#endif
+FUNC1(math_log, log)
+FUNC1(math_log10, log10)
+FUNC2(math_pow, pow)
+FUNC1(math_sin, sin)
+FUNC1(math_sinh, sinh)
+FUNC1(math_sqrt, sqrt)
+FUNC1(math_tan, tan)
+FUNC1(math_tanh, tanh)
+
+#if 0
+/* What about these? */
+double	frexp(double x, int *i);
+double	ldexp(double x, int n);
+double	modf(double x, double *i);
+#endif
+
+static struct methodlist math_methods[] = {
+	{"acos", math_acos},
+	{"asin", math_asin},
+	{"atan", math_atan},
+	{"atan2", math_atan2},
+	{"ceil", math_ceil},
+	{"cos", math_cos},
+	{"cosh", math_cosh},
+	{"exp", math_exp},
+	{"fabs", math_fabs},
+	{"floor", math_floor},
+#if 0
+	{"fmod", math_fmod},
+	{"frexp", math_freqp},
+	{"ldexp", math_ldexp},
+#endif
+	{"log", math_log},
+	{"log10", math_log10},
+#if 0
+	{"modf", math_modf},
+#endif
+	{"pow", math_pow},
+	{"sin", math_sin},
+	{"sinh", math_sinh},
+	{"sqrt", math_sqrt},
+	{"tan", math_tan},
+	{"tanh", math_tanh},
+	{NULL,		NULL}		/* sentinel */
+};
+
+void
+initmath()
+{
+	object *m, *d, *v;
+	struct methodlist *ml;
+	if ((m = new_module("math")) == NULL)
+		fatal("can't create math module");
+	d = getmoduledict(m);
+	for (ml = math_methods; ml->ml_name != NULL; ml++) {
+		v = newmethodobject(ml->ml_name, ml->ml_meth, (object *)NULL);
+		if (v == NULL || dictinsert(d, ml->ml_name, v) != 0) {
+			fatal("can't initialize math module");
+		}
+		DECREF(v);
+	}
+	dictinsert(d, "pi", newfloatobject(atan(1.0) * 4.0));
+	dictinsert(d, "e", newfloatobject(exp(1.0)));
+	DECREF(m);
+}

Modules/posixmodule.c

@@ -0,0 +1,444 @@
+/* POSIX module implementation */
+
+#include <stdio.h>
+#include <signal.h>
+#include <string.h>
+#include <setjmp.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <sys/time.h>
+#ifdef SYSV
+#include <dirent.h>
+#define direct dirent
+#else
+#include <sys/dir.h>
+#endif
+
+#include "PROTO.h"
+#include "object.h"
+#include "intobject.h"
+#include "stringobject.h"
+#include "tupleobject.h"
+#include "listobject.h"
+#include "dictobject.h"
+#include "methodobject.h"
+#include "moduleobject.h"
+#include "objimpl.h"
+#include "import.h"
+#include "sigtype.h"
+#include "modsupport.h"
+#include "errors.h"
+
+extern char *strerror();
+
+#ifdef AMOEBA
+#define NO_LSTAT
+#endif
+
+
+/* Return a dictionary corresponding to the POSIX environment table */
+
+extern char **environ;
+
+static object *
+convertenviron()
+{
+	object *d;
+	char **e;
+	d = newdictobject();
+	if (d == NULL)
+		return NULL;
+	if (environ == NULL)
+		return d;
+	/* XXX This part ignores errors */
+	for (e = environ; *e != NULL; e++) {
+		object *v;
+		char *p = strchr(*e, '=');
+		if (p == NULL)
+			continue;
+		v = newstringobject(p+1);
+		if (v == NULL)
+			continue;
+		*p = '\0';
+		(void) dictinsert(d, *e, v);
+		*p = '=';
+		DECREF(v);
+	}
+	return d;
+}
+
+
+static object *PosixError; /* Exception posix.error */
+
+/* Set a POSIX-specific error from errno, and return NULL */
+
+static object *
+posix_error()
+{
+	object *v = newtupleobject(2);
+	if (v != NULL) {
+		settupleitem(v, 0, newintobject((long)errno));
+		settupleitem(v, 1, newstringobject(strerror(errno)));
+	}
+	err_setval(PosixError, v);
+	if (v != NULL)
+		DECREF(v);
+	return NULL;
+}
+
+
+/* POSIX generic methods */
+
+static object *
+posix_1str(args, func)
+	object *args;
+	int (*func) FPROTO((const char *));
+{
+	object *path1;
+	if (!getstrarg(args, &path1))
+		return NULL;
+	if ((*func)(getstringvalue(path1)) < 0)
+		return posix_error();
+	INCREF(None);
+	return None;
+}
+
+static object *
+posix_2str(args, func)
+	object *args;
+	int (*func) FPROTO((const char *, const char *));
+{
+	object *path1, *path2;
+	if (!getstrstrarg(args, &path1, &path2))
+		return NULL;
+	if ((*func)(getstringvalue(path1), getstringvalue(path2)) < 0)
+		return posix_error();
+	INCREF(None);
+	return None;
+}
+
+static object *
+posix_strint(args, func)
+	object *args;
+	int (*func) FPROTO((const char *, int));
+{
+	object *path1;
+	int i;
+	if (!getstrintarg(args, &path1, &i))
+		return NULL;
+	if ((*func)(getstringvalue(path1), i) < 0)
+		return posix_error();
+	INCREF(None);
+	return None;
+}
+
+static object *
+posix_do_stat(self, args, statfunc)
+	object *self;
+	object *args;
+	int (*statfunc) FPROTO((const char *, struct stat *));
+{
+	struct stat st;
+	object *path;
+	object *v;
+	if (!getstrarg(args, &path))
+		return NULL;
+	if ((*statfunc)(getstringvalue(path), &st) != 0)
+		return posix_error();
+	v = newtupleobject(10);
+	if (v == NULL)
+		return NULL;
+	errno = 0;
+#define SET(i, st_member) settupleitem(v, i, newintobject((long)st.st_member))
+	SET(0, st_mode);
+	SET(1, st_ino);
+	SET(2, st_dev);
+	SET(3, st_nlink);
+	SET(4, st_uid);
+	SET(5, st_gid);
+	SET(6, st_size);
+	SET(7, st_atime);
+	SET(8, st_mtime);
+	SET(9, st_ctime);
+#undef SET
+	if (errno != 0) {
+		DECREF(v);
+		return err_nomem();
+	}
+	return v;
+}
+
+
+/* POSIX methods */
+
+static object *
+posix_chdir(self, args)
+	object *self;
+	object *args;
+{
+	extern int chdir PROTO((const char *));
+	return posix_1str(args, chdir);
+}
+
+static object *
+posix_chmod(self, args)
+	object *self;
+	object *args;
+{
+	extern int chmod PROTO((const char *, mode_t));
+	return posix_strint(args, chmod);
+}
+
+static object *
+posix_getcwd(self, args)
+	object *self;
+	object *args;
+{
+	char buf[1026];
+	extern char *getcwd PROTO((char *, int));
+	if (!getnoarg(args))
+		return NULL;
+	if (getcwd(buf, sizeof buf) == NULL)
+		return posix_error();
+	return newstringobject(buf);
+}
+
+static object *
+posix_link(self, args)
+	object *self;
+	object *args;
+{
+	extern int link PROTO((const char *, const char *));
+	return posix_2str(args, link);
+}
+
+static object *
+posix_listdir(self, args)
+	object *self;
+	object *args;
+{
+	object *name, *d, *v;
+	DIR *dirp;
+	struct direct *ep;
+	if (!getstrarg(args, &name))
+		return NULL;
+	if ((dirp = opendir(getstringvalue(name))) == NULL)
+		return posix_error();
+	if ((d = newlistobject(0)) == NULL) {
+		closedir(dirp);
+		return NULL;
+	}
+	while ((ep = readdir(dirp)) != NULL) {
+		v = newstringobject(ep->d_name);
+		if (v == NULL) {
+			DECREF(d);
+			d = NULL;
+			break;
+		}
+		if (addlistitem(d, v) != 0) {
+			DECREF(v);
+			DECREF(d);
+			d = NULL;
+			break;
+		}
+		DECREF(v);
+	}
+	closedir(dirp);
+	return d;
+}
+
+static object *
+posix_mkdir(self, args)
+	object *self;
+	object *args;
+{
+	extern int mkdir PROTO((const char *, mode_t));
+	return posix_strint(args, mkdir);
+}
+
+static object *
+posix_rename(self, args)
+	object *self;
+	object *args;
+{
+	extern int rename PROTO((const char *, const char *));
+	return posix_2str(args, rename);
+}
+
+static object *
+posix_rmdir(self, args)
+	object *self;
+	object *args;
+{
+	extern int rmdir PROTO((const char *));
+	return posix_1str(args, rmdir);
+}
+
+static object *
+posix_stat(self, args)
+	object *self;
+	object *args;
+{
+	extern int stat PROTO((const char *, struct stat *));
+	return posix_do_stat(self, args, stat);
+}
+
+static object *
+posix_system(self, args)
+	object *self;
+	object *args;
+{
+	object *command;
+	int sts;
+	if (!getstrarg(args, &command))
+		return NULL;
+	sts = system(getstringvalue(command));
+	return newintobject((long)sts);
+}
+
+static object *
+posix_umask(self, args)
+	object *self;
+	object *args;
+{
+	int i;
+	if (!getintarg(args, &i))
+		return NULL;
+	i = umask(i);
+	if (i < 0)
+		return posix_error();
+	return newintobject((long)i);
+}
+
+static object *
+posix_unlink(self, args)
+	object *self;
+	object *args;
+{
+	extern int unlink PROTO((const char *));
+	return posix_1str(args, unlink);
+}
+
+static object *
+posix_utimes(self, args)
+	object *self;
+	object *args;
+{
+	object *path;
+	struct timeval tv[2];
+	if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 2) {
+		err_badarg();
+		return NULL;
+	}
+	if (!getstrarg(gettupleitem(args, 0), &path) ||
+				!getlonglongargs(gettupleitem(args, 1),
+					&tv[0].tv_sec, &tv[1].tv_sec))
+		return NULL;
+	tv[0].tv_usec = tv[1].tv_usec = 0;
+	if (utimes(getstringvalue(path), tv) < 0)
+		return posix_error();
+	INCREF(None);
+	return None;
+}
+
+#ifdef NO_GETCWD
+
+/* Quick hack to get posix.getcwd() working for pure BSD 4.3 */
+/* XXX This assumes MAXPATHLEN = 1024 !!! */
+
+static char *
+getcwd(buf, size)
+	char *buf;
+	int size;
+{
+	extern char *getwd PROTO((char *));
+	register char *ret = getwd(buf);
+	if (ret == NULL)
+		errno = EACCES; /* Most likely error */
+	return ret;
+}
+
+#endif /* NO_GETCWD */
+
+
+#ifndef NO_LSTAT
+
+static object *
+posix_lstat(self, args)
+	object *self;
+	object *args;
+{
+	extern int lstat PROTO((const char *, struct stat *));
+	return posix_do_stat(self, args, lstat);
+}
+
+static object *
+posix_readlink(self, args)
+	object *self;
+	object *args;
+{
+	char buf[1024]; /* XXX Should use MAXPATHLEN */
+	object *path;
+	int n;
+	if (!getstrarg(args, &path))
+		return NULL;
+	n = readlink(getstringvalue(path), buf, sizeof buf);
+	if (n < 0)
+		return posix_error();
+	return newsizedstringobject(buf, n);
+}
+
+static object *
+posix_symlink(self, args)
+	object *self;
+	object *args;
+{
+	extern int symlink PROTO((const char *, const char *));
+	return posix_2str(args, symlink);
+}
+
+#endif /* NO_LSTAT */
+
+
+static struct methodlist posix_methods[] = {
+	{"chdir",	posix_chdir},
+	{"chmod",	posix_chmod},
+	{"getcwd",	posix_getcwd},
+	{"link",	posix_link},
+	{"listdir",	posix_listdir},
+	{"mkdir",	posix_mkdir},
+	{"rename",	posix_rename},
+	{"rmdir",	posix_rmdir},
+	{"stat",	posix_stat},
+	{"system",	posix_system},
+	{"umask",	posix_umask},
+	{"unlink",	posix_unlink},
+	{"utimes",	posix_utimes},
+#ifndef NO_LSTAT
+	{"lstat",	posix_lstat},
+	{"readlink",	posix_readlink},
+	{"symlink",	posix_symlink},
+#endif
+	{NULL,		NULL}		 /* Sentinel */
+};
+
+
+void
+initposix()
+{
+	object *m, *d, *v;
+	
+	m = initmodule("posix", posix_methods);
+	d = getmoduledict(m);
+	
+	/* Initialize posix.environ dictionary */
+	v = convertenviron();
+	if (v == NULL || dictinsert(d, "environ", v) != 0)
+		fatal("can't define posix.environ");
+	DECREF(v);
+	
+	/* Initialize posix.error exception */
+	PosixError = newstringobject("posix.error");
+	if (PosixError == NULL || dictinsert(d, "error", PosixError) != 0)
+		fatal("can't define posix.error");
+}

Modules/timemodule.c

@@ -0,0 +1,178 @@
+/* Time module */
+
+#include <stdio.h>
+#include <signal.h>
+#include <setjmp.h>
+
+#ifdef __STDC__
+#include <time.h>
+#else /* !__STDC__ */
+typedef unsigned long time_t;
+extern time_t time();
+#endif /* !__STDC__ */
+
+#include "PROTO.h"
+#include "object.h"
+#include "intobject.h"
+#include "dictobject.h"
+#include "methodobject.h"
+#include "moduleobject.h"
+#include "objimpl.h"
+#include "import.h"
+#include "sigtype.h"
+#include "modsupport.h"
+#include "errors.h"
+
+
+/* Time methods */
+
+static object *
+time_time(self, args)
+	object *self;
+	object *args;
+{
+	long secs;
+	if (!getnoarg(args))
+		return NULL;
+	secs = time((time_t *)NULL);
+	return newintobject(secs);
+}
+
+static jmp_buf sleep_intr;
+
+static void
+sleep_catcher(sig)
+	int sig;
+{
+	longjmp(sleep_intr, 1);
+}
+
+static object *
+time_sleep(self, args)
+	object *self;
+	object *args;
+{
+	int secs;
+	SIGTYPE (*sigsave)();
+	if (!getintarg(args, &secs))
+		return NULL;
+	if (setjmp(sleep_intr)) {
+		signal(SIGINT, sigsave);
+		err_set(KeyboardInterrupt);
+		return NULL;
+	}
+	sigsave = signal(SIGINT, SIG_IGN);
+	if (sigsave != (SIGTYPE (*)()) SIG_IGN)
+		signal(SIGINT, sleep_catcher);
+	sleep(secs);
+	signal(SIGINT, sigsave);
+	INCREF(None);
+	return None;
+}
+
+#ifdef THINK_C
+#define DO_MILLI
+#endif /* THINK_C */
+
+#ifdef AMOEBA
+#define DO_MILLI
+extern long sys_milli();
+#define millitimer sys_milli
+#endif /* AMOEBA */
+
+#ifdef DO_MILLI
+
+static object *
+time_millisleep(self, args)
+	object *self;
+	object *args;
+{
+	long msecs;
+	SIGTYPE (*sigsave)();
+	if (!getlongarg(args, &msecs))
+		return NULL;
+	if (setjmp(sleep_intr)) {
+		signal(SIGINT, sigsave);
+		err_set(KeyboardInterrupt);
+		return NULL;
+	}
+	sigsave = signal(SIGINT, SIG_IGN);
+	if (sigsave != (SIGTYPE (*)()) SIG_IGN)
+		signal(SIGINT, sleep_catcher);
+	millisleep(msecs);
+	signal(SIGINT, sigsave);
+	INCREF(None);
+	return None;
+}
+
+static object *
+time_millitimer(self, args)
+	object *self;
+	object *args;
+{
+	long msecs;
+	extern long millitimer();
+	if (!getnoarg(args))
+		return NULL;
+	msecs = millitimer();
+	return newintobject(msecs);
+}
+
+#endif /* DO_MILLI */
+
+
+static struct methodlist time_methods[] = {
+#ifdef DO_MILLI
+	{"millisleep",	time_millisleep},
+	{"millitimer",	time_millitimer},
+#endif /* DO_MILLI */
+	{"sleep",	time_sleep},
+	{"time",	time_time},
+	{NULL,		NULL}		/* sentinel */
+};
+
+
+void
+inittime()
+{
+	initmodule("time", time_methods);
+}
+
+
+#ifdef THINK_C
+
+#define MacTicks	(* (long *)0x16A)
+
+static
+sleep(msecs)
+	int msecs;
+{
+	register long deadline;
+	
+	deadline = MacTicks + msecs * 60;
+	while (MacTicks < deadline) {
+		if (intrcheck())
+			sleep_catcher(SIGINT);
+	}
+}
+
+static
+millisleep(msecs)
+	long msecs;
+{
+	register long deadline;
+	
+	deadline = MacTicks + msecs * 3 / 50; /* msecs * 60 / 1000 */
+	while (MacTicks < deadline) {
+		if (intrcheck())
+			sleep_catcher(SIGINT);
+	}
+}
+
+static long
+millitimer()
+{
+	return MacTicks * 50 / 3; /* MacTicks * 1000 / 60 */
+}
+
+#endif /* THINK_C */

Objects/classobject.c

@@ -0,0 +1,268 @@
+/* Class object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "node.h"
+#include "object.h"
+#include "stringobject.h"
+#include "tupleobject.h"
+#include "dictobject.h"
+#include "funcobject.h"
+#include "classobject.h"
+#include "objimpl.h"
+
+typedef struct {
+	OB_HEAD
+	node	*cl_tree;	/* The entire classdef parse tree */
+	object	*cl_bases;	/* A tuple */
+	object	*cl_methods;	/* A dictionary */
+} classobject;
+
+object *
+newclassobject(tree, bases, methods)
+	node *tree;
+	object *bases; /* NULL or tuple of classobjects! */
+	object *methods;
+{
+	classobject *op;
+	op = NEWOBJ(classobject, &Classtype);
+	if (op == NULL)
+		return NULL;
+	op->cl_tree = tree;
+	if (bases != NULL)
+		INCREF(bases);
+	op->cl_bases = bases;
+	INCREF(methods);
+	op->cl_methods = methods;
+	return (object *) op;
+}
+
+/* Class methods */
+
+static void
+class_dealloc(op)
+	classobject *op;
+{
+	int i;
+	if (op->cl_bases != NULL)
+		DECREF(op->cl_bases);
+	DECREF(op->cl_methods);
+	free((ANY *)op);
+}
+
+static object *
+class_getattr(op, name)
+	register classobject *op;
+	register char *name;
+{
+	register object *v;
+	v = dictlookup(op->cl_methods, name);
+	if (v != NULL) {
+		INCREF(v);
+		return v;
+	}
+	if (op->cl_bases != NULL) {
+		int n = gettuplesize(op->cl_bases);
+		int i;
+		for (i = 0; i < n; i++) {
+			v = class_getattr(gettupleitem(op->cl_bases, i), name);
+			if (v != NULL)
+				return v;
+		}
+	}
+	errno = ESRCH;
+	return NULL;
+}
+
+typeobject Classtype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"class",
+	sizeof(classobject),
+	0,
+	class_dealloc,	/*tp_dealloc*/
+	0,		/*tp_print*/
+	class_getattr,	/*tp_getattr*/
+	0,		/*tp_setattr*/
+	0,		/*tp_compare*/
+	0,		/*tp_repr*/
+	0,		/*tp_as_number*/
+	0,		/*tp_as_sequence*/
+	0,		/*tp_as_mapping*/
+};
+
+
+/* We're not done yet: next, we define class member objects... */
+
+typedef struct {
+	OB_HEAD
+	classobject	*cm_class;	/* The class object */
+	object		*cm_attr;	/* A dictionary */
+} classmemberobject;
+
+object *
+newclassmemberobject(class)
+	register object *class;
+{
+	register classmemberobject *cm;
+	if (!is_classobject(class)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	cm = NEWOBJ(classmemberobject, &Classmembertype);
+	if (cm == NULL)
+		return NULL;
+	INCREF(class);
+	cm->cm_class = (classobject *)class;
+	cm->cm_attr = newdictobject();
+	if (cm->cm_attr == NULL) {
+		DECREF(cm);
+		return NULL;
+	}
+	return (object *)cm;
+}
+
+/* Class member methods */
+
+static void
+classmember_dealloc(cm)
+	register classmemberobject *cm;
+{
+	DECREF(cm->cm_class);
+	if (cm->cm_attr != NULL)
+		DECREF(cm->cm_attr);
+	free((ANY *)cm);
+}
+
+static object *
+classmember_getattr(cm, name)
+	register classmemberobject *cm;
+	register char *name;
+{
+	register object *v = dictlookup(cm->cm_attr, name);
+	if (v != NULL) {
+		INCREF(v);
+		return v;
+	}
+	v = class_getattr(cm->cm_class, name);
+	if (v == NULL)
+		return v; /* class_getattr() has set errno */
+	if (is_funcobject(v)) {
+		object *w = newclassmethodobject(v, (object *)cm);
+		DECREF(v);
+		return w;
+	}
+	DECREF(v);
+	errno = ESRCH;
+	return NULL;
+}
+
+static int
+classmember_setattr(cm, name, v)
+	classmemberobject *cm;
+	char *name;
+	object *v;
+{
+	if (v == NULL)
+		return dictremove(cm->cm_attr, name);
+	else
+		return dictinsert(cm->cm_attr, name, v);
+}
+
+typeobject Classmembertype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"class member",
+	sizeof(classmemberobject),
+	0,
+	classmember_dealloc,	/*tp_dealloc*/
+	0,			/*tp_print*/
+	classmember_getattr,	/*tp_getattr*/
+	classmember_setattr,	/*tp_setattr*/
+	0,			/*tp_compare*/
+	0,			/*tp_repr*/
+	0,			/*tp_as_number*/
+	0,			/*tp_as_sequence*/
+	0,			/*tp_as_mapping*/
+};
+
+
+/* And finally, here are class method objects */
+/* (Really methods of class members) */
+
+typedef struct {
+	OB_HEAD
+	object	*cm_func;	/* The method function */
+	object	*cm_self;	/* The object to which this applies */
+} classmethodobject;
+
+object *
+newclassmethodobject(func, self)
+	object *func;
+	object *self;
+{
+	register classmethodobject *cm;
+	if (!is_funcobject(func)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	cm = NEWOBJ(classmethodobject, &Classmethodtype);
+	if (cm == NULL)
+		return NULL;
+	INCREF(func);
+	cm->cm_func = func;
+	INCREF(self);
+	cm->cm_self = self;
+	return (object *)cm;
+}
+
+object *
+classmethodgetfunc(cm)
+	register object *cm;
+{
+	if (!is_classmethodobject(cm)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	return ((classmethodobject *)cm)->cm_func;
+}
+
+object *
+classmethodgetself(cm)
+	register object *cm;
+{
+	if (!is_classmethodobject(cm)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	return ((classmethodobject *)cm)->cm_self;
+}
+
+/* Class method methods */
+
+static void
+classmethod_dealloc(cm)
+	register classmethodobject *cm;
+{
+	DECREF(cm->cm_func);
+	DECREF(cm->cm_self);
+	free((ANY *)cm);
+}
+
+typeobject Classmethodtype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"class method",
+	sizeof(classmethodobject),
+	0,
+	classmethod_dealloc,	/*tp_dealloc*/
+	0,			/*tp_print*/
+	0,			/*tp_getattr*/
+	0,			/*tp_setattr*/
+	0,			/*tp_compare*/
+	0,			/*tp_repr*/
+	0,			/*tp_as_number*/
+	0,			/*tp_as_sequence*/
+	0,			/*tp_as_mapping*/
+};

Objects/fileobject.c

@@ -0,0 +1,267 @@
+/* File object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "stringobject.h"
+#include "intobject.h"
+#include "fileobject.h"
+#include "methodobject.h"
+#include "objimpl.h"
+
+typedef struct {
+	OB_HEAD
+	FILE *f_fp;
+	object *f_name;
+	object *f_mode;
+	/* XXX Should move the 'need space' on printing flag here */
+} fileobject;
+
+FILE *
+getfilefile(f)
+	object *f;
+{
+	if (!is_fileobject(f)) {
+		errno = EBADF;
+		return NULL;
+	}
+	return ((fileobject *)f)->f_fp;
+}
+
+object *
+newopenfileobject(fp, name, mode)
+	FILE *fp;
+	char *name;
+	char *mode;
+{
+	fileobject *f = NEWOBJ(fileobject, &Filetype);
+	if (f == NULL)
+		return NULL;
+	f->f_fp = NULL;
+	f->f_name = newstringobject(name);
+	f->f_mode = newstringobject(mode);
+	if (f->f_name == NULL || f->f_mode == NULL) {
+		DECREF(f);
+		errno = ENOMEM;
+		return NULL;
+	}
+	f->f_fp = fp;
+	return (object *) f;
+}
+
+object *
+newfileobject(name, mode)
+	char *name, *mode;
+{
+	fileobject *f;
+	FILE *fp;
+	f = (fileobject *) newopenfileobject((FILE *)NULL, name, mode);
+	if (f == NULL)
+		return NULL;
+	if ((f->f_fp = fopen(name, mode)) == NULL) {
+		DECREF(f);
+		return NULL;
+	}
+	return (object *)f;
+}
+
+/* Methods */
+
+static void
+filedealloc(f)
+	fileobject *f;
+{
+	if (f->f_fp != NULL)
+		fclose(f->f_fp);
+	if (f->f_name != NULL)
+		DECREF(f->f_name);
+	if (f->f_mode != NULL)
+		DECREF(f->f_mode);
+	free((char *)f);
+}
+
+static void
+fileprint(f, fp, flags)
+	fileobject *f;
+	FILE *fp;
+	int flags;
+{
+	fprintf(fp, "<%s file ", f->f_fp == NULL ? "closed" : "open");
+	printobject(f->f_name, fp, flags);
+	fprintf(fp, ", mode ");
+	printobject(f->f_mode, fp, flags);
+	fprintf(fp, ">");
+}
+
+static object *
+filerepr(f)
+	fileobject *f;
+{
+	char buf[300];
+	/* XXX This differs from fileprint if the filename contains
+	   quotes or other funny characters. */
+	sprintf(buf, "<%s file '%.256s', mode '%.10s'>",
+		f->f_fp == NULL ? "closed" : "open",
+		getstringvalue(f->f_name),
+		getstringvalue(f->f_mode));
+	return newstringobject(buf);
+}
+
+static object *
+fileclose(f, args)
+	fileobject *f;
+	object *args;
+{
+	if (args != NULL) {
+		errno = EINVAL;
+		return NULL;
+	}
+	if (f->f_fp != NULL) {
+		fclose(f->f_fp);
+		f->f_fp = NULL;
+	}
+	INCREF(None);
+	return None;
+}
+
+static object *
+fileread(f, args)
+	fileobject *f;
+	object *args;
+{
+	int n;
+	object *v;
+	if (f->f_fp == NULL) {
+		errno = EBADF;
+		return NULL;
+	}
+	if (args == NULL || !is_intobject(args)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	n = getintvalue(args);
+	if (n <= 0 /* || n > 0x7fff /*XXX*/ ) {
+		errno = EDOM;
+		return NULL;
+	}
+	v = newsizedstringobject((char *)NULL, n);
+	if (v == NULL) {
+		errno = ENOMEM;
+		return NULL;
+	}
+	n = fread(getstringvalue(v), 1, n, f->f_fp);
+	/* EOF is reported as an empty string */
+	/* XXX should detect real I/O errors? */
+	resizestring(&v, n);
+	return v;
+}
+
+/* XXX Should this be unified with raw_input()? */
+
+static object *
+filereadline(f, args)
+	fileobject *f;
+	object *args;
+{
+	int n;
+	object *v;
+	if (f->f_fp == NULL) {
+		errno = EBADF;
+		return NULL;
+	}
+	if (args == NULL) {
+		n = 10000; /* XXX should really be unlimited */
+	}
+	else if (is_intobject(args)) {
+		n = getintvalue(args);
+		if (n < 0 || n > 0x7fff /*XXX*/ ) {
+			errno = EDOM;
+			return NULL;
+		}
+	}
+	else {
+		errno = EINVAL;
+		return NULL;
+	}
+	v = newsizedstringobject((char *)NULL, n);
+	if (v == NULL) {
+		errno = ENOMEM;
+		return NULL;
+	}
+	if (fgets(getstringvalue(v), n+1, f->f_fp) == NULL) {
+		/* EOF is reported as an empty string */
+		/* XXX should detect real I/O errors? */
+		n = 0;
+	}
+	else {
+		n = strlen(getstringvalue(v));
+	}
+	resizestring(&v, n);
+	return v;
+}
+
+static object *
+filewrite(f, args)
+	fileobject *f;
+	object *args;
+{
+	int n, n2;
+	if (f->f_fp == NULL) {
+		errno = EBADF;
+		return NULL;
+	}
+	if (args == NULL || !is_stringobject(args)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	errno = 0;
+	n2 = fwrite(getstringvalue(args), 1, n = getstringsize(args), f->f_fp);
+	if (n2 != n) {
+		if (errno == 0)
+			errno = EIO;
+		return NULL;
+	}
+	INCREF(None);
+	return None;
+}
+
+static struct methodlist {
+	char *ml_name;
+	method ml_meth;
+} filemethods[] = {
+	{"write",	filewrite},
+	{"read",	fileread},
+	{"readline",	filereadline},
+	{"close",	fileclose},
+	{NULL,		NULL}		/* sentinel */
+};
+
+static object *
+filegetattr(f, name)
+	fileobject *f;
+	char *name;
+{
+	struct methodlist *ml = filemethods;
+	for (; ml->ml_name != NULL; ml++) {
+		if (strcmp(name, ml->ml_name) == 0)
+			return newmethodobject(ml->ml_name, ml->ml_meth,
+				(object *)f);
+	}
+	errno = ESRCH;
+	return NULL;
+}
+
+typeobject Filetype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"file",
+	sizeof(fileobject),
+	0,
+	filedealloc,	/*tp_dealloc*/
+	fileprint,	/*tp_print*/
+	filegetattr,	/*tp_getattr*/
+	0,		/*tp_setattr*/
+	0,		/*tp_compare*/
+	filerepr,	/*tp_repr*/
+};

Objects/floatobject.c

@@ -0,0 +1,240 @@
+/* Float object implementation */
+
+#include <stdio.h>
+#include <math.h>
+#include <ctype.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "floatobject.h"
+#include "stringobject.h"
+#include "objimpl.h"
+
+object *
+newfloatobject(fval)
+	double fval;
+{
+	/* For efficiency, this code is copied from newobject() */
+	register floatobject *op = (floatobject *) malloc(sizeof(floatobject));
+	if (op == NULL) {
+		errno = ENOMEM;
+	}
+	else {
+		NEWREF(op);
+		op->ob_type = &Floattype;
+		op->ob_fval = fval;
+	}
+	return (object *) op;
+}
+
+double
+getfloatvalue(op)
+	object *op;
+{
+	if (!is_floatobject(op)) {
+		errno = EBADF;
+		return -1;
+	}
+	else
+		return ((floatobject *)op) -> ob_fval;
+}
+
+/* Methods */
+
+static void
+float_buf_repr(buf, v)
+	char *buf;
+	floatobject *v;
+{
+	register char *cp;
+	/* Subroutine for float_repr and float_print.
+	   We want float numbers to be recognizable as such,
+	   i.e., they should contain a decimal point or an exponent.
+	   However, %g may print the number as an integer;
+	   in such cases, we append ".0" to the string. */
+	sprintf(buf, "%.12g", v->ob_fval);
+	cp = buf;
+	if (*cp == '-')
+		cp++;
+	for (; *cp != '\0'; cp++) {
+		/* Any non-digit means it's not an integer;
+		   this takes care of NAN and INF as well. */
+		if (!isdigit(*cp))
+			break;
+	}
+	if (*cp == '\0') {
+		*cp++ = '.';
+		*cp++ = '0';
+		*cp++ = '\0';
+	}
+}
+
+static void
+float_print(v, fp, flags)
+	floatobject *v;
+	FILE *fp;
+	int flags;
+{
+	char buf[100];
+	float_buf_repr(buf, v);
+	fputs(buf, fp);
+}
+
+static object *
+float_repr(v)
+	floatobject *v;
+{
+	char buf[100];
+	float_buf_repr(buf, v);
+	return newstringobject(buf);
+}
+
+static int
+float_compare(v, w)
+	floatobject *v, *w;
+{
+	double i = v->ob_fval;
+	double j = w->ob_fval;
+	return (i < j) ? -1 : (i > j) ? 1 : 0;
+}
+
+static object *
+float_add(v, w)
+	floatobject *v;
+	object *w;
+{
+	if (!is_floatobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	return newfloatobject(v->ob_fval + ((floatobject *)w) -> ob_fval);
+}
+
+static object *
+float_sub(v, w)
+	floatobject *v;
+	object *w;
+{
+	if (!is_floatobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	return newfloatobject(v->ob_fval - ((floatobject *)w) -> ob_fval);
+}
+
+static object *
+float_mul(v, w)
+	floatobject *v;
+	object *w;
+{
+	if (!is_floatobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	return newfloatobject(v->ob_fval * ((floatobject *)w) -> ob_fval);
+}
+
+static object *
+float_div(v, w)
+	floatobject *v;
+	object *w;
+{
+	if (!is_floatobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	if (((floatobject *)w) -> ob_fval == 0) {
+		errno = EDOM;
+		return NULL;
+	}
+	return newfloatobject(v->ob_fval / ((floatobject *)w) -> ob_fval);
+}
+
+static object *
+float_rem(v, w)
+	floatobject *v;
+	object *w;
+{
+	double wx;
+	extern double fmod();
+	if (!is_floatobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	wx = ((floatobject *)w) -> ob_fval;
+	if (wx == 0.0) {
+		errno = EDOM;
+		return NULL;
+	}
+	return newfloatobject(fmod(v->ob_fval, wx));
+}
+
+static object *
+float_pow(v, w)
+	floatobject *v;
+	object *w;
+{
+	double iv, iw, ix;
+	extern double pow();
+	if (!is_floatobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	iv = v->ob_fval;
+	iw = ((floatobject *)w)->ob_fval;
+	errno = 0;
+	ix = pow(iv, iw);
+	if (errno != 0)
+		return NULL;
+	else
+		return newfloatobject(ix);
+}
+
+static object *
+float_neg(v)
+	floatobject *v;
+{
+	return newfloatobject(-v->ob_fval);
+}
+
+static object *
+float_pos(v)
+	floatobject *v;
+{
+	return newfloatobject(v->ob_fval);
+}
+
+static number_methods float_as_number = {
+	float_add,	/*tp_add*/
+	float_sub,	/*tp_subtract*/
+	float_mul,	/*tp_multiply*/
+	float_div,	/*tp_divide*/
+	float_rem,	/*tp_remainder*/
+	float_pow,	/*tp_power*/
+	float_neg,	/*tp_negate*/
+	float_pos,	/*tp_plus*/
+};
+
+typeobject Floattype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"float",
+	sizeof(floatobject),
+	0,
+	free,			/*tp_dealloc*/
+	float_print,		/*tp_print*/
+	0,			/*tp_getattr*/
+	0,			/*tp_setattr*/
+	float_compare,		/*tp_compare*/
+	float_repr,		/*tp_repr*/
+	&float_as_number,	/*tp_as_number*/
+	0,			/*tp_as_sequence*/
+	0,			/*tp_as_mapping*/
+};
+
+/*
+XXX This is not enough.  Need:
+- automatic casts for mixed arithmetic (3.1 * 4)
+- mixed comparisons (!)
+- look at other uses of ints that could be extended to floats
+*/

Objects/funcobject.c

@@ -0,0 +1,101 @@
+/* Function object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "node.h"
+#include "stringobject.h"
+#include "funcobject.h"
+#include "objimpl.h"
+#include "token.h"
+
+typedef struct {
+	OB_HEAD
+	node *func_node;
+	object *func_globals;
+} funcobject;
+
+object *
+newfuncobject(n, globals)
+	node *n;
+	object *globals;
+{
+	funcobject *op = NEWOBJ(funcobject, &Functype);
+	if (op != NULL) {
+		op->func_node = n;
+		if (globals != NULL)
+			INCREF(globals);
+		op->func_globals = globals;
+	}
+	return (object *)op;
+}
+
+node *
+getfuncnode(op)
+	object *op;
+{
+	if (!is_funcobject(op)) {
+		errno = EBADF;
+		return NULL;
+	}
+	return ((funcobject *) op) -> func_node;
+}
+
+object *
+getfuncglobals(op)
+	object *op;
+{
+	if (!is_funcobject(op)) {
+		errno = EBADF;
+		return NULL;
+	}
+	return ((funcobject *) op) -> func_globals;
+}
+
+/* Methods */
+
+static void
+funcdealloc(op)
+	funcobject *op;
+{
+	/* XXX free node? */
+	DECREF(op->func_globals);
+	free((char *)op);
+}
+
+static void
+funcprint(op, fp, flags)
+	funcobject *op;
+	FILE *fp;
+	int flags;
+{
+	node *n = op->func_node;
+	n = CHILD(n, 1);
+	fprintf(fp, "<user function %s>", STR(n));
+}
+
+static object *
+funcrepr(op)
+	funcobject *op;
+{
+	char buf[100];
+	node *n = op->func_node;
+	n = CHILD(n, 1);
+	sprintf(buf, "<user function %.80s>", STR(n));
+	return newstringobject(buf);
+}
+
+typeobject Functype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"function",
+	sizeof(funcobject),
+	0,
+	funcdealloc,	/*tp_dealloc*/
+	funcprint,	/*tp_print*/
+	0,		/*tp_getattr*/
+	0,		/*tp_setattr*/
+	0,		/*tp_compare*/
+	funcrepr,	/*tp_repr*/
+};

Objects/intobject.c

@@ -0,0 +1,250 @@
+/* Integer object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "intobject.h"
+#include "stringobject.h"
+#include "objimpl.h"
+
+/* Standard Booleans */
+intobject FalseObject = {
+	OB_HEAD_INIT(&Inttype)
+	0
+};
+intobject TrueObject = {
+	OB_HEAD_INIT(&Inttype)
+	1
+};
+
+object *
+newintobject(ival)
+	long ival;
+{
+	/* For efficiency, this code is copied from newobject() */
+	register intobject *op = (intobject *) malloc(sizeof(intobject));
+	if (op == NULL) {
+		errno = ENOMEM;
+	}
+	else {
+		NEWREF(op);
+		op->ob_type = &Inttype;
+		op->ob_ival = ival;
+	}
+	return (object *) op;
+}
+
+long
+getintvalue(op)
+	register object *op;
+{
+	if (!is_intobject(op)) {
+		errno = EBADF;
+		return -1;
+	}
+	else
+		return ((intobject *)op) -> ob_ival;
+}
+
+/* Methods */
+
+static void
+intprint(v, fp, flags)
+	intobject *v;
+	FILE *fp;
+	int flags;
+{
+	fprintf(fp, "%ld", v->ob_ival);
+}
+
+static object *
+intrepr(v)
+	intobject *v;
+{
+	char buf[20];
+	sprintf(buf, "%ld", v->ob_ival);
+	return newstringobject(buf);
+}
+
+static int
+intcompare(v, w)
+	intobject *v, *w;
+{
+	register long i = v->ob_ival;
+	register long j = w->ob_ival;
+	return (i < j) ? -1 : (i > j) ? 1 : 0;
+}
+
+static object *
+intadd(v, w)
+	intobject *v;
+	register object *w;
+{
+	register long a, b, x;
+	if (!is_intobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	a = v->ob_ival;
+	b = ((intobject *)w) -> ob_ival;
+	x = a + b;
+	if ((x^a) < 0 && (x^b) < 0) {
+		errno = ERANGE;
+		return NULL;
+	}
+	return newintobject(x);
+}
+
+static object *
+intsub(v, w)
+	intobject *v;
+	register object *w;
+{
+	register long a, b, x;
+	if (!is_intobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	a = v->ob_ival;
+	b = ((intobject *)w) -> ob_ival;
+	x = a - b;
+	if ((x^a) < 0 && (x^~b) < 0) {
+		errno = ERANGE;
+		return NULL;
+	}
+	return newintobject(x);
+}
+
+static object *
+intmul(v, w)
+	intobject *v;
+	register object *w;
+{
+	register long a, b;
+	double x;
+	if (!is_intobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	a = v->ob_ival;
+	b = ((intobject *)w) -> ob_ival;
+	x = (double)a * (double)b;
+	if (x > 0x7fffffff || x < (double) (long) 0x80000000) {
+		errno = ERANGE;
+		return NULL;
+	}
+	return newintobject(a * b);
+}
+
+static object *
+intdiv(v, w)
+	intobject *v;
+	register object *w;
+{
+	if (!is_intobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	if (((intobject *)w) -> ob_ival == 0) {
+		errno = EDOM;
+		return NULL;
+	}
+	return newintobject(v->ob_ival / ((intobject *)w) -> ob_ival);
+}
+
+static object *
+intrem(v, w)
+	intobject *v;
+	register object *w;
+{
+	if (!is_intobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	if (((intobject *)w) -> ob_ival == 0) {
+		errno = EDOM;
+		return NULL;
+	}
+	return newintobject(v->ob_ival % ((intobject *)w) -> ob_ival);
+}
+
+static object *
+intpow(v, w)
+	intobject *v;
+	register object *w;
+{
+	register long iv, iw, ix;
+	register int neg;
+	if (!is_intobject(w)) {
+		errno = EINVAL;
+		return NULL;
+	}
+	iv = v->ob_ival;
+	iw = ((intobject *)w)->ob_ival;
+	neg = 0;
+	if (iw < 0)
+		neg = 1, iw = -iw;
+	ix = 1;
+	for (; iw > 0; iw--)
+		ix = ix * iv;
+	if (neg) {
+		if (ix == 0) {
+			errno = EDOM;
+			return NULL;
+		}
+		ix = 1/ix;
+	}
+	/* XXX How to check for overflow? */
+	return newintobject(ix);
+}
+
+static object *
+intneg(v)
+	intobject *v;
+{
+	register long a, x;
+	a = v->ob_ival;
+	x = -a;
+	if (a < 0 && x < 0) {
+		errno = ERANGE;
+		return NULL;
+	}
+	return newintobject(x);
+}
+
+static object *
+intpos(v)
+	intobject *v;
+{
+	INCREF(v);
+	return (object *)v;
+}
+
+static number_methods int_as_number = {
+	intadd,	/*tp_add*/
+	intsub,	/*tp_subtract*/
+	intmul,	/*tp_multiply*/
+	intdiv,	/*tp_divide*/
+	intrem,	/*tp_remainder*/
+	intpow,	/*tp_power*/
+	intneg,	/*tp_negate*/
+	intpos,	/*tp_plus*/
+};
+
+typeobject Inttype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"int",
+	sizeof(intobject),
+	0,
+	free,		/*tp_dealloc*/
+	intprint,	/*tp_print*/
+	0,		/*tp_getattr*/
+	0,		/*tp_setattr*/
+	intcompare,	/*tp_compare*/
+	intrepr,	/*tp_repr*/
+	&int_as_number,	/*tp_as_number*/
+	0,		/*tp_as_sequence*/
+	0,		/*tp_as_mapping*/
+};

Objects/listobject.c

@@ -0,0 +1,482 @@
+/* List object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "intobject.h"
+#include "stringobject.h"
+#include "tupleobject.h"
+#include "methodobject.h"
+#include "listobject.h"
+#include "objimpl.h"
+#include "modsupport.h"
+
+typedef struct {
+	OB_VARHEAD
+	object **ob_item;
+} listobject;
+
+object *
+newlistobject(size)
+	int size;
+{
+	int i;
+	listobject *op;
+	if (size < 0) {
+		errno = EINVAL;
+		return NULL;
+	}
+	op = (listobject *) malloc(sizeof(listobject));
+	if (op == NULL) {
+		errno = ENOMEM;
+		return NULL;
+	}
+	if (size <= 0) {
+		op->ob_item = NULL;
+	}
+	else {
+		op->ob_item = (object **) malloc(size * sizeof(object *));
+		if (op->ob_item == NULL) {
+			free((ANY *)op);
+			errno = ENOMEM;
+			return NULL;
+		}
+	}
+	NEWREF(op);
+	op->ob_type = &Listtype;
+	op->ob_size = size;
+	for (i = 0; i < size; i++)
+		op->ob_item[i] = NULL;
+	return (object *) op;
+}
+
+int
+getlistsize(op)
+	object *op;
+{
+	if (!is_listobject(op)) {
+		errno = EBADF;
+		return -1;
+	}
+	else
+		return ((listobject *)op) -> ob_size;
+}
+
+object *
+getlistitem(op, i)
+	object *op;
+	int i;
+{
+	if (!is_listobject(op)) {
+		errno = EBADF;
+		return NULL;
+	}
+	if (i < 0 || i >= ((listobject *)op) -> ob_size) {
+		errno = EDOM;
+		return NULL;
+	}
+	return ((listobject *)op) -> ob_item[i];
+}
+
+int
+setlistitem(op, i, newitem)
+	register object *op;
+	register int i;
+	register object *newitem;
+{
+	register object *olditem;
+	if (!is_listobject(op)) {
+		if (newitem != NULL)
+			DECREF(newitem);
+		return errno = EBADF;
+	}
+	if (i < 0 || i >= ((listobject *)op) -> ob_size) {
+		if (newitem != NULL)
+			DECREF(newitem);
+		return errno = EDOM;
+	}
+	olditem = ((listobject *)op) -> ob_item[i];
+	((listobject *)op) -> ob_item[i] = newitem;
+	if (olditem != NULL)
+		DECREF(olditem);
+	return 0;
+}
+
+static int
+ins1(self, where, v)
+	listobject *self;
+	int where;
+	object *v;
+{
+	int i;
+	object **items;
+	if (v == NULL)
+		return errno = EINVAL;
+	items = self->ob_item;
+	RESIZE(items, object *, self->ob_size+1);
+	if (items == NULL)
+		return errno = ENOMEM;
+	if (where < 0)
+		where = 0;
+	if (where > self->ob_size)
+		where = self->ob_size;
+	for (i = self->ob_size; --i >= where; )
+		items[i+1] = items[i];
+	INCREF(v);
+	items[where] = v;
+	self->ob_item = items;
+	self->ob_size++;
+	return 0;
+}
+
+int
+inslistitem(op, where, newitem)
+	object *op;
+	int where;
+	object *newitem;
+{
+	if (!is_listobject(op))
+		return errno = EBADF;
+	return ins1((listobject *)op, where, newitem);
+}
+
+int
+addlistitem(op, newitem)
+	object *op;
+	object *newitem;
+{
+	if (!is_listobject(op))
+		return errno = EBADF;
+	return ins1((listobject *)op,
+		(int) ((listobject *)op)->ob_size, newitem);
+}
+
+/* Methods */
+
+static void
+list_dealloc(op)
+	listobject *op;
+{
+	int i;
+	for (i = 0; i < op->ob_size; i++) {
+		if (op->ob_item[i] != NULL)
+			DECREF(op->ob_item[i]);
+	}
+	if (op->ob_item != NULL)
+		free((ANY *)op->ob_item);
+	free((ANY *)op);
+}
+
+static void
+list_print(op, fp, flags)
+	listobject *op;
+	FILE *fp;
+	int flags;
+{
+	int i;
+	fprintf(fp, "[");
+	for (i = 0; i < op->ob_size && !StopPrint; i++) {
+		if (i > 0) {
+			fprintf(fp, ", ");
+		}
+		printobject(op->ob_item[i], fp, flags);
+	}
+	fprintf(fp, "]");
+}
+
+object *
+list_repr(v)
+	listobject *v;
+{
+	object *s, *t, *comma;
+	int i;
+	s = newstringobject("[");
+	comma = newstringobject(", ");
+	for (i = 0; i < v->ob_size && s != NULL; i++) {
+		if (i > 0)
+			joinstring(&s, comma);
+		t = reprobject(v->ob_item[i]);
+		joinstring(&s, t);
+		DECREF(t);
+	}
+	DECREF(comma);
+	t = newstringobject("]");
+	joinstring(&s, t);
+	DECREF(t);
+	return s;
+}
+
+static int
+list_compare(v, w)
+	listobject *v, *w;
+{
+	int len = (v->ob_size < w->ob_size) ? v->ob_size : w->ob_size;
+	int i;
+	for (i = 0; i < len; i++) {
+		int cmp = cmpobject(v->ob_item[i], w->ob_item[i]);
+		if (cmp != 0)
+			return cmp;
+	}
+	return v->ob_size - w->ob_size;
+}
+
+static int
+list_length(a)
+	listobject *a;
+{
+	return a->ob_size;
+}
+
+static object *
+list_item(a, i)
+	listobject *a;
+	int i;
+{
+	if (i < 0 || i >= a->ob_size) {
+		errno = EDOM;
+		return NULL;
+	}
+	INCREF(a->ob_item[i]);
+	return a->ob_item[i];
+}
+
+static object *
+list_slice(a, ilow, ihigh)
+	listobject *a;
+	int ilow, ihigh;
+{
+	listobject *np;
+	int i;
+	if (ilow < 0)
+		ilow = 0;
+	else if (ilow > a->ob_size)
+		ilow = a->ob_size;
+	if (ihigh < 0)
+		ihigh = 0;
+	if (ihigh < ilow)
+		ihigh = ilow;
+	else if (ihigh > a->ob_size)
+		ihigh = a->ob_size;
+	np = (listobject *) newlistobject(ihigh - ilow);
+	if (np == NULL)
+		return NULL;
+	for (i = ilow; i < ihigh; i++) {
+		object *v = a->ob_item[i];
+		INCREF(v);
+		np->ob_item[i - ilow] = v;
+	}
+	return (object *)np;
+}
+
+static object *
+list_concat(a, bb)
+	listobject *a;
+	object *bb;
+{
+	int size;
+	int i;
+	listobject *np;
+	if (!is_listobject(bb)) {
+		errno = EINVAL;
+		return NULL;
+	}
+#define b ((listobject *)bb)
+	size = a->ob_size + b->ob_size;
+	np = (listobject *) newlistobject(size);
+	if (np == NULL) {
+		errno = ENOMEM;
+		return NULL;
+	}
+	for (i = 0; i < a->ob_size; i++) {
+		object *v = a->ob_item[i];
+		INCREF(v);
+		np->ob_item[i] = v;
+	}
+	for (i = 0; i < b->ob_size; i++) {
+		object *v = b->ob_item[i];
+		INCREF(v);
+		np->ob_item[i + a->ob_size] = v;
+	}
+	return (object *)np;
+#undef b
+}
+
+static int
+list_ass_item(a, i, v)
+	listobject *a;
+	int i;
+	object *v;
+{
+	if (i < 0 || i >= a->ob_size)
+		return errno = EDOM;
+	if (v == NULL)
+		return list_ass_slice(a, i, i+1, v);
+	INCREF(v);
+	DECREF(a->ob_item[i]);
+	a->ob_item[i] = v;
+	return 0;
+}
+
+static int
+list_ass_slice(a, ilow, ihigh, v)
+	listobject *a;
+	int ilow, ihigh;
+	object *v;
+{
+	object **item;
+	int n; /* Size of replacement list */
+	int d; /* Change in size */
+	int k; /* Loop index */
+#define b ((listobject *)v)
+	if (v == NULL)
+		n = 0;
+	else if (is_listobject(v))
+		n = b->ob_size;
+	else
+		return errno = EINVAL;
+	if (ilow < 0)
+		ilow = 0;
+	else if (ilow > a->ob_size)
+		ilow = a->ob_size;
+	if (ihigh < 0)
+		ihigh = 0;
+	if (ihigh < ilow)
+		ihigh = ilow;
+	else if (ihigh > a->ob_size)
+		ihigh = a->ob_size;
+	item = a->ob_item;
+	d = n - (ihigh-ilow);
+	if (d <= 0) { /* Delete -d items; DECREF ihigh-ilow items */
+		for (k = ilow; k < ihigh; k++)
+			DECREF(item[k]);
+		if (d < 0) {
+			for (/*k = ihigh*/; k < a->ob_size; k++)
+				item[k+d] = item[k];
+			a->ob_size += d;
+			RESIZE(item, object *, a->ob_size); /* Can't fail */
+			a->ob_item = item;
+		}
+	}
+	else { /* Insert d items; DECREF ihigh-ilow items */
+		RESIZE(item, object *, a->ob_size + d);
+		if (item == NULL)
+			return errno = ENOMEM;
+		for (k = a->ob_size; --k >= ihigh; )
+			item[k+d] = item[k];
+		for (/*k = ihigh-1*/; k >= ilow; --k)
+			DECREF(item[k]);
+		a->ob_item = item;
+		a->ob_size += d;
+	}
+	for (k = 0; k < n; k++, ilow++) {
+		object *w = b->ob_item[k];
+		INCREF(w);
+		item[ilow] = w;
+	}
+	return 0;
+#undef b
+}
+
+static object *
+ins(self, where, v)
+	listobject *self;
+	int where;
+	object *v;
+{
+	if (ins1(self, where, v) != 0)
+		return NULL;
+	INCREF(None);
+	return None;
+}
+
+static object *
+listinsert(self, args)
+	listobject *self;
+	object *args;
+{
+	int i;
+	if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 2) {
+		errno = EINVAL;
+		return NULL;
+	}
+	if (!getintarg(gettupleitem(args, 0), &i))
+		return NULL;
+	return ins(self, i, gettupleitem(args, 1));
+}
+
+static object *
+listappend(self, args)
+	listobject *self;
+	object *args;
+{
+	return ins(self, (int) self->ob_size, args);
+}
+
+static int
+cmp(v, w)
+	char *v, *w;
+{
+	return cmpobject(* (object **) v, * (object **) w);
+}
+
+static object *
+listsort(self, args)
+	listobject *self;
+	object *args;
+{
+	if (args != NULL) {
+		errno = EINVAL;
+		return NULL;
+	}
+	errno = 0;
+	if (self->ob_size > 1)
+		qsort((char *)self->ob_item,
+				(int) self->ob_size, sizeof(object *), cmp);
+	if (errno != 0)
+		return NULL;
+	INCREF(None);
+	return None;
+}
+
+static struct methodlist list_methods[] = {
+	{"append",	listappend},
+	{"insert",	listinsert},
+	{"sort",	listsort},
+	{NULL,		NULL}		/* sentinel */
+};
+
+static object *
+list_getattr(f, name)
+	listobject *f;
+	char *name;
+{
+	return findmethod(list_methods, (object *)f, name);
+}
+
+static sequence_methods list_as_sequence = {
+	list_length,	/*sq_length*/
+	list_concat,	/*sq_concat*/
+	0,		/*sq_repeat*/
+	list_item,	/*sq_item*/
+	list_slice,	/*sq_slice*/
+	list_ass_item,	/*sq_ass_item*/
+	list_ass_slice,	/*sq_ass_slice*/
+};
+
+typeobject Listtype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"list",
+	sizeof(listobject),
+	0,
+	list_dealloc,	/*tp_dealloc*/
+	list_print,	/*tp_print*/
+	list_getattr,	/*tp_getattr*/
+	0,		/*tp_setattr*/
+	list_compare,	/*tp_compare*/
+	list_repr,	/*tp_repr*/
+	0,		/*tp_as_number*/
+	&list_as_sequence,	/*tp_as_sequence*/
+	0,		/*tp_as_mapping*/
+};

Objects/methodobject.c

@@ -0,0 +1,113 @@
+/* Method object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "node.h"
+#include "stringobject.h"
+#include "methodobject.h"
+#include "objimpl.h"
+#include "token.h"
+
+typedef struct {
+	OB_HEAD
+	char *m_name;
+	method m_meth;
+	object *m_self;
+} methodobject;
+
+object *
+newmethodobject(name, meth, self)
+	char *name; /* static string */
+	method meth;
+	object *self;
+{
+	methodobject *op = NEWOBJ(methodobject, &Methodtype);
+	if (op != NULL) {
+		op->m_name = name;
+		op->m_meth = meth;
+		if (self != NULL)
+			INCREF(self);
+		op->m_self = self;
+	}
+	return (object *)op;
+}
+
+method
+getmethod(op)
+	object *op;
+{
+	if (!is_methodobject(op)) {
+		errno = EBADF;
+		return NULL;
+	}
+	return ((methodobject *)op) -> m_meth;
+}
+
+object *
+getself(op)
+	object *op;
+{
+	if (!is_methodobject(op)) {
+		errno = EBADF;
+		return NULL;
+	}
+	return ((methodobject *)op) -> m_self;
+}
+
+/* Methods (the standard built-in methods, that is) */
+
+static void
+meth_dealloc(m)
+	methodobject *m;
+{
+	if (m->m_self != NULL)
+		DECREF(m->m_self);
+	free((char *)m);
+}
+
+static void
+meth_print(m, fp, flags)
+	methodobject *m;
+	FILE *fp;
+	int flags;
+{
+	if (m->m_self == NULL)
+		fprintf(fp, "<%s method>", m->m_name);
+	else
+		fprintf(fp, "<%s method of %s object at %lx>",
+			m->m_name, m->m_self->ob_type->tp_name,
+			(long)m->m_self);
+}
+
+static object *
+meth_repr(m)
+	methodobject *m;
+{
+	char buf[200];
+	if (m->m_self == NULL)
+		sprintf(buf, "<%.80s method>", m->m_name);
+	else
+		sprintf(buf, "<%.80s method of %.80s object at %lx>",
+			m->m_name, m->m_self->ob_type->tp_name,
+			(long)m->m_self);
+	return newstringobject(buf);
+}
+
+typeobject Methodtype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"method",
+	sizeof(methodobject),
+	0,
+	meth_dealloc,	/*tp_dealloc*/
+	meth_print,	/*tp_print*/
+	0,		/*tp_getattr*/
+	0,		/*tp_setattr*/
+	0,		/*tp_compare*/
+	meth_repr,	/*tp_repr*/
+	0,		/*tp_as_number*/
+	0,		/*tp_as_sequence*/
+	0,		/*tp_as_mapping*/
+};

Objects/moduleobject.c

@@ -0,0 +1,130 @@
+/* Module object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "stringobject.h"
+#include "dictobject.h"
+#include "moduleobject.h"
+#include "objimpl.h"
+
+typedef struct {
+	OB_HEAD
+	object *md_name;
+	object *md_dict;
+} moduleobject;
+
+object *
+newmoduleobject(name)
+	char *name;
+{
+	moduleobject *m = NEWOBJ(moduleobject, &Moduletype);
+	if (m == NULL)
+		return NULL;
+	m->md_name = newstringobject(name);
+	m->md_dict = newdictobject();
+	if (m->md_name == NULL || m->md_dict == NULL) {
+		DECREF(m);
+		return NULL;
+	}
+	return (object *)m;
+}
+
+object *
+getmoduledict(m)
+	object *m;
+{
+	if (!is_moduleobject(m)) {
+		errno = EBADF;
+		return NULL;
+	}
+	return ((moduleobject *)m) -> md_dict;
+}
+
+int
+setmoduledict(m, v)
+	object *m;
+	object *v;
+{
+	if (!is_moduleobject(m))
+		return errno = EBADF;
+	if (!is_dictobject(v))
+		return errno = EINVAL;
+	DECREF(((moduleobject *)m) -> md_dict);
+	INCREF(v);
+	((moduleobject *)m) -> md_dict = v;
+	return 0;
+}
+
+/* Methods */
+
+static void
+moduledealloc(m)
+	moduleobject *m;
+{
+	if (m->md_name != NULL)
+		DECREF(m->md_name);
+	if (m->md_dict != NULL)
+		DECREF(m->md_dict);
+	free((char *)m);
+}
+
+static void
+moduleprint(m, fp, flags)
+	moduleobject *m;
+	FILE *fp;
+	int flags;
+{
+	fprintf(fp, "<module %s>", getstringvalue(m->md_name));
+}
+
+static object *
+modulerepr(m)
+	moduleobject *m;
+{
+	char buf[100];
+	sprintf(buf, "<module %.80s>", getstringvalue(m->md_name));
+	return newstringobject(buf);
+}
+
+static object *
+modulegetattr(m, name)
+	moduleobject *m;
+	char *name;
+{
+	object *res = dictlookup(m->md_dict, name);
+	if (res == NULL) {
+		if (errno == ENOENT)
+			errno = ESRCH;
+	}
+	else
+		INCREF(res);
+	return res;
+}
+
+static int
+modulesetattr(m, name, v)
+	moduleobject *m;
+	char *name;
+	object *v;
+{
+	if (v == NULL)
+		return dictremove(m->md_dict, name);
+	else
+		return dictinsert(m->md_dict, name, v);
+}
+
+typeobject Moduletype = {
+	OB_HEAD_INIT(&Typetype)
+	0,			/*ob_size*/
+	"module",		/*tp_name*/
+	sizeof(moduleobject),	/*tp_size*/
+	0,			/*tp_itemsize*/
+	moduledealloc,	/*tp_dealloc*/
+	moduleprint,	/*tp_print*/
+	modulegetattr,	/*tp_getattr*/
+	modulesetattr,	/*tp_setattr*/
+	0,		/*tp_compare*/
+	modulerepr,	/*tp_repr*/
+};

Objects/object.c

@@ -0,0 +1,195 @@
+/* Object implementation; and 'noobject' implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "stringobject.h"
+#include "objimpl.h"
+#include "errors.h"
+
+extern object *err_nomem PROTO((void)); /* XXX from modsupport.c */
+
+int StopPrint; /* Flag to indicate printing must be stopped */
+
+/* Object allocation routines used by NEWOBJ and NEWVAROBJ macros */
+
+object *
+newobject(tp)
+	typeobject *tp;
+{
+	object *op = (object *) malloc(tp->tp_basicsize);
+	if (op == NULL)
+		return err_nomem();
+	NEWREF(op);
+	op->ob_type = tp;
+	return op;
+}
+
+#if 0 /* unused */
+
+varobject *
+newvarobject(tp, size)
+	typeobject *tp;
+	unsigned int size;
+{
+	varobject *op = (varobject *)
+		malloc(tp->tp_basicsize + size * tp->tp_itemsize);
+	if (op == NULL)
+		return err_nomem();
+	NEWREF(op);
+	op->ob_type = tp;
+	op->ob_size = size;
+	return op;
+}
+
+#endif
+
+static int prlevel;
+
+void
+printobject(op, fp, flags)
+	object *op;
+	FILE *fp;
+	int flags;
+{
+	/* Hacks to make printing a long or recursive object interruptible */
+	prlevel++;
+	if (!StopPrint && intrcheck()) {
+		fprintf(fp, "\n[print interrupted]\n");
+		StopPrint = 1;
+	}
+	if (!StopPrint) {
+		if (op == NULL) {
+			fprintf(fp, "<nil>");
+		}
+		else if (op->ob_type->tp_print == NULL) {
+			fprintf(fp, "<%s object at %lx>",
+				op->ob_type->tp_name, (long)op);
+		}
+		else {
+			(*op->ob_type->tp_print)(op, fp, flags);
+		}
+	}
+	prlevel--;
+	if (prlevel == 0)
+		StopPrint = 0;
+}
+
+object *
+reprobject(v)
+	object *v;
+{
+	object *w;
+	/* Hacks to make converting a long or recursive object interruptible */
+	prlevel++;
+	if (!StopPrint && intrcheck()) {
+		StopPrint = 1;
+		w = NULL;
+		err_set(KeyboardInterrupt);
+	}
+	if (!StopPrint) {
+		if (v == NULL) {
+			w = newstringobject("<nil>");
+		}
+		else if (v->ob_type->tp_repr == NULL) {
+			char buf[100];
+			sprintf(buf, "<%.80s object at %lx>",
+				v->ob_type->tp_name, (long)v);
+			w = newstringobject(buf);
+		}
+		else {
+			w = (*v->ob_type->tp_repr)(v);
+		}
+	}
+	prlevel--;
+	if (prlevel == 0)
+		StopPrint = 0;
+	return w;
+}
+
+int
+cmpobject(v, w)
+	object *v, *w;
+{
+	typeobject *tp;
+	if (v == w)
+		return 0;
+	if (v == NULL)
+		return -1;
+	if (w == NULL)
+		return 1;
+	if ((tp = v->ob_type) != w->ob_type)
+		return strcmp(tp->tp_name, w->ob_type->tp_name);
+	if (tp->tp_compare == NULL)
+		return (v < w) ? -1 : 1;
+	return ((*tp->tp_compare)(v, w));
+}
+
+
+/*
+NoObject is usable as a non-NULL undefined value, used by the macro None.
+There is (and should be!) no way to create other objects of this type,
+so there is exactly one.
+*/
+
+static void
+noprint(op, fp, flags)
+	object *op;
+	FILE *fp;
+	int flags;
+{
+	fprintf(fp, "<no value>");
+}
+
+static typeobject Notype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"novalue",
+	0,
+	0,
+	0,		/*tp_dealloc*/ /*never called*/
+	noprint,	/*tp_print*/
+};
+
+object NoObject = {
+	OB_HEAD_INIT(&Notype)
+};
+
+
+#ifdef TRACE_REFS
+
+static object refchain = {&refchain, &refchain};
+
+NEWREF(op)
+	object *op;
+{
+	ref_total++;
+	op->ob_refcnt = 1;
+	op->_ob_next = refchain._ob_next;
+	op->_ob_prev = &refchain;
+	refchain._ob_next->_ob_prev = op;
+	refchain._ob_next = op;
+}
+
+DELREF(op)
+	object *op;
+{
+	op->_ob_next->_ob_prev = op->_ob_prev;
+	op->_ob_prev->_ob_next = op->_ob_next;
+	(*(op)->ob_type->tp_dealloc)(op);
+}
+
+printrefs(fp)
+	FILE *fp;
+{
+	object *op;
+	fprintf(fp, "Remaining objects:\n");
+	for (op = refchain._ob_next; op != &refchain; op = op->_ob_next) {
+		fprintf(fp, "[%d] ", op->ob_refcnt);
+		printobject(op, fp, 0);
+		putc('\n', fp);
+	}
+}
+
+#endif

Objects/stringobject.c

@@ -0,0 +1,328 @@
+/* String object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "stringobject.h"
+#include "intobject.h"
+#include "objimpl.h"
+
+object *
+newsizedstringobject(str, size)
+	char *str;
+	int size;
+{
+	register stringobject *op = (stringobject *)
+		malloc(sizeof(stringobject) + size * sizeof(char));
+	if (op == NULL) {
+		errno = ENOMEM;
+	}
+	else {
+		NEWREF(op);
+		op->ob_type = &Stringtype;
+		op->ob_size = size;
+		if (str != NULL)
+			memcpy(op->ob_sval, str, size);
+		op->ob_sval[size] = '\0';
+	}
+	return (object *) op;
+}
+
+object *
+newstringobject(str)
+	char *str;
+{
+	register unsigned int size = strlen(str);
+	register stringobject *op = (stringobject *)
+		malloc(sizeof(stringobject) + size * sizeof(char));
+	if (op == NULL) {
+		errno = ENOMEM;
+	}
+	else {
+		NEWREF(op);
+		op->ob_type = &Stringtype;
+		op->ob_size = size;
+		strcpy(op->ob_sval, str);
+	}
+	return (object *) op;
+}
+
+unsigned int
+getstringsize(op)
+	register object *op;
+{
+	if (!is_stringobject(op)) {
+		errno = EBADF;
+		return -1;
+	}
+	return ((stringobject *)op) -> ob_size;
+}
+
+/*const*/ char *
+getstringvalue(op)
+	register object *op;
+{
+	if (!is_stringobject(op)) {
+		errno = EBADF;
+		return NULL;
+	}
+	return ((stringobject *)op) -> ob_sval;
+}
+
+/* Methods */
+
+static void
+stringprint(op, fp, flags)
+	stringobject *op;
+	FILE *fp;
+	int flags;
+{
+	int i;
+	char c;
+	if (flags & PRINT_RAW) {
+		fwrite(op->ob_sval, 1, (int) op->ob_size, fp);
+		return;
+	}
+	fprintf(fp, "'");
+	for (i = 0; i < op->ob_size; i++) {
+		c = op->ob_sval[i];
+		if (c == '\'' || c == '\\')
+			fprintf(fp, "\\%c", c);
+		else if (c < ' ' || c >= 0177)
+			fprintf(fp, "\\%03o", c&0377);
+		else
+			putc(c, fp);
+	}
+	fprintf(fp, "'");
+}
+
+static object *
+stringrepr(op)
+	register stringobject *op;
+{
+	/* XXX overflow? */
+	int newsize = 2 + 4 * op->ob_size * sizeof(char);
+	object *v = newsizedstringobject((char *)NULL, newsize);
+	if (v == NULL) {
+		errno = ENOMEM;
+	}
+	else {
+		register int i;
+		register char c;
+		register char *p;
+		NEWREF(v);
+		v->ob_type = &Stringtype;
+		((stringobject *)v)->ob_size = newsize;
+		p = ((stringobject *)v)->ob_sval;
+		*p++ = '\'';
+		for (i = 0; i < op->ob_size; i++) {
+			c = op->ob_sval[i];
+			if (c == '\'' || c == '\\')
+				*p++ = '\\', *p++ = c;
+			else if (c < ' ' || c >= 0177) {
+				sprintf(p, "\\%03o", c&0377);
+				while (*p != '\0')
+					p++;
+				
+			}
+			else
+				*p++ = c;
+		}
+		*p++ = '\'';
+		*p = '\0';
+		resizestring(&v, (int) (p - ((stringobject *)v)->ob_sval));
+	}
+	return v;
+}
+
+static int
+stringlength(a)
+	stringobject *a;
+{
+	return a->ob_size;
+}
+
+static object *
+stringconcat(a, bb)
+	register stringobject *a;
+	register object *bb;
+{
+	register unsigned int size;
+	register stringobject *op;
+	if (!is_stringobject(bb)) {
+		errno = EINVAL;
+		return NULL;
+	}
+#define b ((stringobject *)bb)
+	/* Optimize cases with empty left or right operand */
+	if (a->ob_size == 0) {
+		INCREF(bb);
+		return bb;
+	}
+	if (b->ob_size == 0) {
+		INCREF(a);
+		return (object *)a;
+	}
+	size = a->ob_size + b->ob_size;
+	op = (stringobject *)
+		malloc(sizeof(stringobject) + size * sizeof(char));
+	if (op == NULL) {
+		errno = ENOMEM;
+	}
+	else {
+		NEWREF(op);
+		op->ob_type = &Stringtype;
+		op->ob_size = size;
+		memcpy(op->ob_sval, a->ob_sval, (int) a->ob_size);
+		memcpy(op->ob_sval + a->ob_size, b->ob_sval, (int) b->ob_size);
+		op->ob_sval[size] = '\0';
+	}
+	return (object *) op;
+#undef b
+}
+
+static object *
+stringrepeat(a, n)
+	register stringobject *a;
+	register int n;
+{
+	register int i;
+	register unsigned int size;
+	register stringobject *op;
+	if (n < 0)
+		n = 0;
+	size = a->ob_size * n;
+	if (size == a->ob_size) {
+		INCREF(a);
+		return (object *)a;
+	}
+	op = (stringobject *)
+		malloc(sizeof(stringobject) + size * sizeof(char));
+	if (op == NULL) {
+		errno = ENOMEM;
+	}
+	else {
+		NEWREF(op);
+		op->ob_type = &Stringtype;
+		op->ob_size = size;
+		for (i = 0; i < size; i += a->ob_size)
+			memcpy(op->ob_sval+i, a->ob_sval, (int) a->ob_size);
+		op->ob_sval[size] = '\0';
+	}
+	return (object *) op;
+}
+
+/* String slice a[i:j] consists of characters a[i] ... a[j-1] */
+
+static object *
+stringslice(a, i, j)
+	register stringobject *a;
+	register int i, j; /* May be negative! */
+{
+	if (i < 0)
+		i = 0;
+	if (j < 0)
+		j = 0; /* Avoid signed/unsigned bug in next line */
+	if (j > a->ob_size)
+		j = a->ob_size;
+	if (i == 0 && j == a->ob_size) { /* It's the same as a */
+		INCREF(a);
+		return (object *)a;
+	}
+	if (j < i)
+		j = i;
+	return newsizedstringobject(a->ob_sval + i, (int) (j-i));
+}
+
+static object *
+stringitem(a, i)
+	stringobject *a;
+	register int i;
+{
+	if (i < 0 || i >= a->ob_size) {
+		errno = EDOM;
+		return NULL;
+	}
+	return stringslice(a, i, i+1);
+}
+
+static int
+stringcompare(a, b)
+	stringobject *a, *b;
+{
+	/* XXX should use memcmp on shortest size, then compare lengths */
+	return strcmp(a->ob_sval, b->ob_sval);
+}
+
+static sequence_methods string_as_sequence = {
+	stringlength,	/*tp_length*/
+	stringconcat,	/*tp_concat*/
+	stringrepeat,	/*tp_repeat*/
+	stringitem,	/*tp_item*/
+	stringslice,	/*tp_slice*/
+	0,	/*tp_ass_item*/
+	0,	/*tp_ass_slice*/
+};
+
+typeobject Stringtype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"string",
+	sizeof(stringobject),
+	sizeof(char),
+	free,		/*tp_dealloc*/
+	stringprint,	/*tp_print*/
+	0,		/*tp_getattr*/
+	0,		/*tp_setattr*/
+	stringcompare,	/*tp_compare*/
+	stringrepr,	/*tp_repr*/
+	0,		/*tp_as_number*/
+	&string_as_sequence,	/*tp_as_sequence*/
+	0,		/*tp_as_mapping*/
+};
+
+void
+joinstring(pv, w)
+	register object **pv;
+	register object *w;
+{
+	register object *v;
+	if (*pv == NULL || w == NULL || !is_stringobject(*pv))
+		return;
+	v = stringconcat((stringobject *) *pv, w);
+	DECREF(*pv);
+	*pv = v;
+}
+
+/* The following function breaks the notion that strings are immutable:
+   it changes the size of a string.  We get away with this only if there
+   is only one module referencing the object.  You can also think of it
+   as creating a new string object and destroying the old one, only
+   more efficiently.  In any case, don't use this if the string may
+   already be known to some other part of the code... */
+
+int
+resizestring(pv, newsize)
+	object **pv;
+	int newsize;
+{
+	register stringobject *v;
+	v = (stringobject *) *pv;
+	if (!is_stringobject(v) || v->ob_refcnt != 1) {
+		*pv = 0;
+		DECREF(v);
+		return errno = EBADF;
+	}
+	*pv = (object *)
+		realloc((char *)v,
+			sizeof(stringobject) + newsize * sizeof(char));
+	if (*pv == NULL) {
+		DECREF(v);
+		return errno = ENOMEM;
+	}
+	v = (stringobject *) *pv;
+	v->ob_size = newsize;
+	v->ob_sval[newsize] = '\0';
+	return 0;
+}

Objects/tupleobject.c

@@ -0,0 +1,276 @@
+/* Tuple object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "stringobject.h"
+#include "tupleobject.h"
+#include "intobject.h"
+#include "objimpl.h"
+
+typedef struct {
+	OB_VARHEAD
+	object *ob_item[1];
+} tupleobject;
+
+object *
+newtupleobject(size)
+	register int size;
+{
+	register int i;
+	register tupleobject *op;
+	if (size < 0) {
+		errno = EINVAL;
+		return NULL;
+	}
+	op = (tupleobject *)
+		malloc(sizeof(tupleobject) + size * sizeof(object *));
+	if (op == NULL) {
+		errno = ENOMEM;
+		return NULL;
+	}
+	NEWREF(op);
+	op->ob_type = &Tupletype;
+	op->ob_size = size;
+	for (i = 0; i < size; i++)
+		op->ob_item[i] = NULL;
+	return (object *) op;
+}
+
+int
+gettuplesize(op)
+	register object *op;
+{
+	if (!is_tupleobject(op)) {
+		errno = EBADF;
+		return -1;
+	}
+	else
+		return ((tupleobject *)op)->ob_size;
+}
+
+object *
+gettupleitem(op, i)
+	register object *op;
+	register int i;
+{
+	if (!is_tupleobject(op)) {
+		errno = EBADF;
+		return NULL;
+	}
+	if (i < 0 || i >= ((tupleobject *)op) -> ob_size) {
+		errno = EDOM;
+		return NULL;
+	}
+	return ((tupleobject *)op) -> ob_item[i];
+}
+
+int
+settupleitem(op, i, newitem)
+	register object *op;
+	register int i;
+	register object *newitem;
+{
+	register object *olditem;
+	if (!is_tupleobject(op)) {
+		if (newitem != NULL)
+			DECREF(newitem);
+		return errno = EBADF;
+	}
+	if (i < 0 || i >= ((tupleobject *)op) -> ob_size) {
+		if (newitem != NULL)
+			DECREF(newitem);
+		return errno = EDOM;
+	}
+	olditem = ((tupleobject *)op) -> ob_item[i];
+	((tupleobject *)op) -> ob_item[i] = newitem;
+	if (olditem != NULL)
+		DECREF(olditem);
+	return 0;
+}
+
+/* Methods */
+
+static void
+tupledealloc(op)
+	register tupleobject *op;
+{
+	register int i;
+	for (i = 0; i < op->ob_size; i++) {
+		if (op->ob_item[i] != NULL)
+			DECREF(op->ob_item[i]);
+	}
+	free((ANY *)op);
+}
+
+static void
+tupleprint(op, fp, flags)
+	tupleobject *op;
+	FILE *fp;
+	int flags;
+{
+	int i;
+	fprintf(fp, "(");
+	for (i = 0; i < op->ob_size && !StopPrint; i++) {
+		if (i > 0) {
+			fprintf(fp, ", ");
+		}
+		printobject(op->ob_item[i], fp, flags);
+	}
+	if (op->ob_size == 1)
+		fprintf(fp, ",");
+	fprintf(fp, ")");
+}
+
+object *
+tuplerepr(v)
+	tupleobject *v;
+{
+	object *s, *t, *comma;
+	int i;
+	s = newstringobject("(");
+	comma = newstringobject(", ");
+	for (i = 0; i < v->ob_size && s != NULL; i++) {
+		if (i > 0)
+			joinstring(&s, comma);
+		t = reprobject(v->ob_item[i]);
+		joinstring(&s, t);
+		if (t != NULL)
+			DECREF(t);
+	}
+	DECREF(comma);
+	if (v->ob_size == 1) {
+		t = newstringobject(",");
+		joinstring(&s, t);
+		DECREF(t);
+	}
+	t = newstringobject(")");
+	joinstring(&s, t);
+	DECREF(t);
+	return s;
+}
+
+static int
+tuplecompare(v, w)
+	register tupleobject *v, *w;
+{
+	register int len =
+		(v->ob_size < w->ob_size) ? v->ob_size : w->ob_size;
+	register int i;
+	for (i = 0; i < len; i++) {
+		int cmp = cmpobject(v->ob_item[i], w->ob_item[i]);
+		if (cmp != 0)
+			return cmp;
+	}
+	return v->ob_size - w->ob_size;
+}
+
+static int
+tuplelength(a)
+	tupleobject *a;
+{
+	return a->ob_size;
+}
+
+static object *
+tupleitem(a, i)
+	register tupleobject *a;
+	register int i;
+{
+	if (i < 0 || i >= a->ob_size) {
+		errno = EDOM;
+		return NULL;
+	}
+	INCREF(a->ob_item[i]);
+	return a->ob_item[i];
+}
+
+static object *
+tupleslice(a, ilow, ihigh)
+	register tupleobject *a;
+	register int ilow, ihigh;
+{
+	register tupleobject *np;
+	register int i;
+	if (ilow < 0)
+		ilow = 0;
+	if (ihigh > a->ob_size)
+		ihigh = a->ob_size;
+	if (ihigh < ilow)
+		ihigh = ilow;
+	if (ilow == 0 && ihigh == a->ob_size) {
+		/* XXX can only do this if tuples are immutable! */
+		INCREF(a);
+		return (object *)a;
+	}
+	np = (tupleobject *)newtupleobject(ihigh - ilow);
+	if (np == NULL)
+		return NULL;
+	for (i = ilow; i < ihigh; i++) {
+		object *v = a->ob_item[i];
+		INCREF(v);
+		np->ob_item[i - ilow] = v;
+	}
+	return (object *)np;
+}
+
+static object *
+tupleconcat(a, bb)
+	register tupleobject *a;
+	register object *bb;
+{
+	register int size;
+	register int i;
+	tupleobject *np;
+	if (!is_tupleobject(bb)) {
+		errno = EINVAL;
+		return NULL;
+	}
+#define b ((tupleobject *)bb)
+	size = a->ob_size + b->ob_size;
+	np = (tupleobject *) newtupleobject(size);
+	if (np == NULL) {
+		errno = ENOMEM;
+		return NULL;
+	}
+	for (i = 0; i < a->ob_size; i++) {
+		object *v = a->ob_item[i];
+		INCREF(v);
+		np->ob_item[i] = v;
+	}
+	for (i = 0; i < b->ob_size; i++) {
+		object *v = b->ob_item[i];
+		INCREF(v);
+		np->ob_item[i + a->ob_size] = v;
+	}
+	return (object *)np;
+#undef b
+}
+
+static sequence_methods tuple_as_sequence = {
+	tuplelength,	/*sq_length*/
+	tupleconcat,	/*sq_concat*/
+	0,		/*sq_repeat*/
+	tupleitem,	/*sq_item*/
+	tupleslice,	/*sq_slice*/
+	0,		/*sq_ass_item*/
+	0,		/*sq_ass_slice*/
+};
+
+typeobject Tupletype = {
+	OB_HEAD_INIT(&Typetype)
+	0,
+	"tuple",
+	sizeof(tupleobject) - sizeof(object *),
+	sizeof(object *),
+	tupledealloc,	/*tp_dealloc*/
+	tupleprint,	/*tp_print*/
+	0,		/*tp_getattr*/
+	0,		/*tp_setattr*/
+	tuplecompare,	/*tp_compare*/
+	tuplerepr,	/*tp_repr*/
+	0,		/*tp_as_number*/
+	&tuple_as_sequence,	/*tp_as_sequence*/
+	0,		/*tp_as_mapping*/
+};

Objects/typeobject.c

@@ -0,0 +1,47 @@
+/* Type object implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "stringobject.h"
+#include "objimpl.h"
+
+/* Type object implementation */
+
+static void
+typeprint(v, fp, flags)
+	typeobject *v;
+	FILE *fp;
+	int flags;
+{
+	fprintf(fp, "<type '%s'>", v->tp_name);
+}
+
+static object *
+typerepr(v)
+	typeobject *v;
+{
+	char buf[100];
+	sprintf(buf, "<type '%.80s'>", v->tp_name);
+	return newstringobject(buf);
+}
+
+typedef struct {
+	OB_HEAD
+	long ob_ival;
+} intobject;
+
+typeobject Typetype = {
+	OB_HEAD_INIT(&Typetype)
+	0,			/* Number of items for varobject */
+	"type",			/* Name of this type */
+	sizeof(typeobject),	/* Basic object size */
+	0,			/* Item size for varobject */
+	0,		/*tp_dealloc*/
+	typeprint,	/*tp_print*/
+	0,		/*tp_getattr*/
+	0,		/*tp_setattr*/
+	0,		/*tp_compare*/
+	typerepr,	/*tp_repr*/
+};

Objects/xxobject.c

@@ -0,0 +1,94 @@
+/* Xx objects */
+
+typedef struct {
+	OB_HEAD
+	object	*x_attr;	/* Attributes dictionary */
+} xxobject;
+
+extern typeobject Xxtype;	/* Really static, forward */
+
+static xxobject *
+newxxobject(arg)
+	object *arg;
+{
+	textobject *xp;
+	xp = NEWOBJ(xxobject, &Xxtype);
+	if (xp == NULL)
+		return NULL;
+	xp->x_attr = NULL;
+	return xp;
+}
+
+/* Xx methods */
+
+static void
+xx_dealloc(xp)
+	xxobject *xp;
+{
+	if (xp->x_attr != NULL)
+		DECREF(xp->x_attr);
+	DEL(xp);
+}
+
+static object *
+xx_demo(self, args)
+	xxobject *self;
+	object *args;
+{
+	if (!getnoarg(args))
+		return NULL;
+	INCREF(None);
+	return None;
+}
+
+static struct methodlist xx_methods[] = {
+	"demo",		xx_demo,
+	{NULL,		NULL}		/* sentinel */
+};
+
+static object *
+xx_getattr(xp, name)
+	xxobject *xp;
+	char *name;
+{
+	if (xp->x_attr != NULL) {
+		object *v = dictlookup(xp->x_attr, name);
+		if (v != NULL) {
+			INCREF(v);
+			return v;
+		}
+	}
+	return findmethod(xx_methods, (object *)xp, name);
+}
+
+static int
+xx_setattr(xp, name, v)
+	xxobject *xp;
+	char *name;
+	object *v;
+{
+	if (xp->x_attr == NULL) {
+		xp->x_attr = newdictobject();
+		if (xp->x_attr == NULL)
+			return errno;
+	}
+	if (v == NULL)
+		return dictremove(xp->x_attr, name);
+	else
+		return dictinsert(xp->x_attr, name, v);
+}
+
+static typeobject Xxtype = {
+	OB_HEAD_INIT(&Typetype)
+	0,			/*ob_size*/
+	"xx",			/*tp_name*/
+	sizeof(xxobject),	/*tp_size*/
+	0,			/*tp_itemsize*/
+	/* methods */
+	xx_dealloc,	/*tp_dealloc*/
+	0,		/*tp_print*/
+	xx_getattr,	/*tp_getattr*/
+	xx_setattr,	/*tp_setattr*/
+	0,		/*tp_compare*/
+	0,		/*tp_repr*/
+};

Parser/acceler.c

@@ -0,0 +1,101 @@
+/* Parser accelerator module */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "grammar.h"
+#include "token.h"
+#include "malloc.h"
+
+static void
+fixstate(g, d, s)
+	grammar *g;
+	dfa *d;
+	state *s;
+{
+	arc *a;
+	int k;
+	int *accel;
+	int nl = g->g_ll.ll_nlabels;
+	s->s_accept = 0;
+	accel = NEW(int, nl);
+	for (k = 0; k < nl; k++)
+		accel[k] = -1;
+	a = s->s_arc;
+	for (k = s->s_narcs; --k >= 0; a++) {
+		int lbl = a->a_lbl;
+		label *l = &g->g_ll.ll_label[lbl];
+		int type = l->lb_type;
+		if (a->a_arrow >= (1 << 7)) {
+			printf("XXX too many states!\n");
+			continue;
+		}
+		if (ISNONTERMINAL(type)) {
+			dfa *d1 = finddfa(g, type);
+			int ibit;
+			if (type - NT_OFFSET >= (1 << 7)) {
+				printf("XXX too high nonterminal number!\n");
+				continue;
+			}
+			for (ibit = 0; ibit < g->g_ll.ll_nlabels; ibit++) {
+				if (testbit(d1->d_first, ibit)) {
+					if (accel[ibit] != -1)
+						printf("XXX ambiguity!\n");
+					accel[ibit] = a->a_arrow | (1 << 7) |
+						((type - NT_OFFSET) << 8);
+				}
+			}
+		}
+		else if (lbl == EMPTY)
+			s->s_accept = 1;
+		else if (lbl >= 0 && lbl < nl)
+			accel[lbl] = a->a_arrow;
+	}
+	while (nl > 0 && accel[nl-1] == -1)
+		nl--;
+	for (k = 0; k < nl && accel[k] == -1;)
+		k++;
+	if (k < nl) {
+		int i;
+		s->s_accel = NEW(int, nl-k);
+		if (s->s_accel == NULL) {
+			fprintf(stderr, "no mem to add parser accelerators\n");
+			exit(1);
+		}
+		s->s_lower = k;
+		s->s_upper = nl;
+		for (i = 0; k < nl; i++, k++)
+			s->s_accel[i] = accel[k];
+	}
+	DEL(accel);
+}
+
+static void
+fixdfa(g, d)
+	grammar *g;
+	dfa *d;
+{
+	state *s;
+	int j;
+	s = d->d_state;
+	for (j = 0; j < d->d_nstates; j++, s++)
+		fixstate(g, d, s);
+}
+
+void
+addaccelerators(g)
+	grammar *g;
+{
+	dfa *d;
+	int i;
+#ifdef DEBUG
+	printf("Adding parser accellerators ...\n");
+#endif
+	d = g->g_dfa;
+	for (i = g->g_ndfas; --i >= 0; d++)
+		fixdfa(g, d);
+	g->g_accel = 1;
+#ifdef DEBUG
+	printf("Done.\n");
+#endif
+}

Parser/assert.h

@@ -0,0 +1 @@
+#define assert(e) { if (!(e)) { printf("Assertion failed\n"); abort(); } }

Parser/bitset.c

@@ -0,0 +1,76 @@
+/* Bitset primitives */
+
+#include "PROTO.h"
+#include "malloc.h"
+#include "bitset.h"
+
+bitset
+newbitset(nbits)
+	int nbits;
+{
+	int nbytes = NBYTES(nbits);
+	bitset ss = NEW(BYTE, nbytes);
+	
+	if (ss == NULL)
+		fatal("no mem for bitset");
+	
+	ss += nbytes;
+	while (--nbytes >= 0)
+		*--ss = 0;
+	return ss;
+}
+
+void
+delbitset(ss)
+	bitset ss;
+{
+	DEL(ss);
+}
+
+int
+addbit(ss, ibit)
+	bitset ss;
+	int ibit;
+{
+	int ibyte = BIT2BYTE(ibit);
+	BYTE mask = BIT2MASK(ibit);
+	
+	if (ss[ibyte] & mask)
+		return 0; /* Bit already set */
+	ss[ibyte] |= mask;
+	return 1;
+}
+
+#if 0 /* Now a macro */
+int
+testbit(ss, ibit)
+	bitset ss;
+	int ibit;
+{
+	return (ss[BIT2BYTE(ibit)] & BIT2MASK(ibit)) != 0;
+}
+#endif
+
+int
+samebitset(ss1, ss2, nbits)
+	bitset ss1, ss2;
+	int nbits;
+{
+	int i;
+	
+	for (i = NBYTES(nbits); --i >= 0; )
+		if (*ss1++ != *ss2++)
+			return 0;
+	return 1;
+}
+
+void
+mergebitset(ss1, ss2, nbits)
+	bitset ss1, ss2;
+	int nbits;
+{
+	int i;
+	
+	for (i = NBYTES(nbits); --i >= 0; )
+		*ss1++ |= *ss2++;
+}

Parser/firstsets.c

@@ -0,0 +1,109 @@
+/* Computation of FIRST stets */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "malloc.h"
+#include "grammar.h"
+#include "token.h"
+
+extern int debugging;
+
+static void
+calcfirstset(g, d)
+	grammar *g;
+	dfa *d;
+{
+	int i, j;
+	state *s;
+	arc *a;
+	int nsyms;
+	int *sym;
+	int nbits;
+	static bitset dummy;
+	bitset result;
+	int type;
+	dfa *d1;
+	label *l0;
+	
+	if (debugging)
+		printf("Calculate FIRST set for '%s'\n", d->d_name);
+	
+	if (dummy == NULL)
+		dummy = newbitset(1);
+	if (d->d_first == dummy) {
+		fprintf(stderr, "Left-recursion for '%s'\n", d->d_name);
+		return;
+	}
+	if (d->d_first != NULL) {
+		fprintf(stderr, "Re-calculating FIRST set for '%s' ???\n",
+			d->d_name);
+	}
+	d->d_first = dummy;
+	
+	l0 = g->g_ll.ll_label;
+	nbits = g->g_ll.ll_nlabels;
+	result = newbitset(nbits);
+	
+	sym = NEW(int, 1);
+	if (sym == NULL)
+		fatal("no mem for new sym in calcfirstset");
+	nsyms = 1;
+	sym[0] = findlabel(&g->g_ll, d->d_type, (char *)NULL);
+	
+	s = &d->d_state[d->d_initial];
+	for (i = 0; i < s->s_narcs; i++) {
+		a = &s->s_arc[i];
+		for (j = 0; j < nsyms; j++) {
+			if (sym[j] == a->a_lbl)
+				break;
+		}
+		if (j >= nsyms) { /* New label */
+			RESIZE(sym, int, nsyms + 1);
+			if (sym == NULL)
+				fatal("no mem to resize sym in calcfirstset");
+			sym[nsyms++] = a->a_lbl;
+			type = l0[a->a_lbl].lb_type;
+			if (ISNONTERMINAL(type)) {
+				d1 = finddfa(g, type);
+				if (d1->d_first == dummy) {
+					fprintf(stderr,
+						"Left-recursion below '%s'\n",
+						d->d_name);
+				}
+				else {
+					if (d1->d_first == NULL)
+						calcfirstset(g, d1);
+					mergebitset(result, d1->d_first, nbits);
+				}
+			}
+			else if (ISTERMINAL(type)) {
+				addbit(result, a->a_lbl);
+			}
+		}
+	}
+	d->d_first = result;
+	if (debugging) {
+		printf("FIRST set for '%s': {", d->d_name);
+		for (i = 0; i < nbits; i++) {
+			if (testbit(result, i))
+				printf(" %s", labelrepr(&l0[i]));
+		}
+		printf(" }\n");
+	}
+}
+
+void
+addfirstsets(g)
+	grammar *g;
+{
+	int i;
+	dfa *d;
+	
+	printf("Adding FIRST sets ...\n");
+	for (i = 0; i < g->g_ndfas; i++) {
+		d = &g->g_dfa[i];
+		if (d->d_first == NULL)
+			calcfirstset(g, d);
+	}
+}

Parser/grammar.c

@@ -0,0 +1,207 @@
+/* Grammar implementation */
+
+#include <stdio.h>
+#include <ctype.h>
+
+#include "PROTO.h"
+#include "malloc.h"
+#include "assert.h"
+#include "token.h"
+#include "grammar.h"
+
+extern int debugging;
+
+grammar *
+newgrammar(start)
+	int start;
+{
+	grammar *g;
+	
+	g = NEW(grammar, 1);
+	if (g == NULL)
+		fatal("no mem for new grammar");
+	g->g_ndfas = 0;
+	g->g_dfa = NULL;
+	g->g_start = start;
+	g->g_ll.ll_nlabels = 0;
+	g->g_ll.ll_label = NULL;
+	return g;
+}
+
+dfa *
+adddfa(g, type, name)
+	grammar *g;
+	int type;
+	char *name;
+{
+	dfa *d;
+	
+	RESIZE(g->g_dfa, dfa, g->g_ndfas + 1);
+	if (g->g_dfa == NULL)
+		fatal("no mem to resize dfa in adddfa");
+	d = &g->g_dfa[g->g_ndfas++];
+	d->d_type = type;
+	d->d_name = name;
+	d->d_nstates = 0;
+	d->d_state = NULL;
+	d->d_initial = -1;
+	d->d_first = NULL;
+	return d; /* Only use while fresh! */
+}
+
+int
+addstate(d)
+	dfa *d;
+{
+	state *s;
+	
+	RESIZE(d->d_state, state, d->d_nstates + 1);
+	if (d->d_state == NULL)
+		fatal("no mem to resize state in addstate");
+	s = &d->d_state[d->d_nstates++];
+	s->s_narcs = 0;
+	s->s_arc = NULL;
+	return s - d->d_state;
+}
+
+void
+addarc(d, from, to, lbl)
+	dfa *d;
+	int lbl;
+{
+	state *s;
+	arc *a;
+	
+	assert(0 <= from && from < d->d_nstates);
+	assert(0 <= to && to < d->d_nstates);
+	
+	s = &d->d_state[from];
+	RESIZE(s->s_arc, arc, s->s_narcs + 1);
+	if (s->s_arc == NULL)
+		fatal("no mem to resize arc list in addarc");
+	a = &s->s_arc[s->s_narcs++];
+	a->a_lbl = lbl;
+	a->a_arrow = to;
+}
+
+int
+addlabel(ll, type, str)
+	labellist *ll;
+	int type;
+	char *str;
+{
+	int i;
+	label *lb;
+	
+	for (i = 0; i < ll->ll_nlabels; i++) {
+		if (ll->ll_label[i].lb_type == type &&
+			strcmp(ll->ll_label[i].lb_str, str) == 0)
+			return i;
+	}
+	RESIZE(ll->ll_label, label, ll->ll_nlabels + 1);
+	if (ll->ll_label == NULL)
+		fatal("no mem to resize labellist in addlabel");
+	lb = &ll->ll_label[ll->ll_nlabels++];
+	lb->lb_type = type;
+	lb->lb_str = str; /* XXX strdup(str) ??? */
+	return lb - ll->ll_label;
+}
+
+/* Same, but rather dies than adds */
+
+int
+findlabel(ll, type, str)
+	labellist *ll;
+	int type;
+	char *str;
+{
+	int i;
+	label *lb;
+	
+	for (i = 0; i < ll->ll_nlabels; i++) {
+		if (ll->ll_label[i].lb_type == type /*&&
+			strcmp(ll->ll_label[i].lb_str, str) == 0*/)
+			return i;
+	}
+	fprintf(stderr, "Label %d/'%s' not found\n", type, str);
+	abort();
+}
+
+static void
+translabel(g, lb)
+	grammar *g;
+	label *lb;
+{
+	int i;
+	
+	if (debugging)
+		printf("Translating label %s ...\n", labelrepr(lb));
+	
+	if (lb->lb_type == NAME) {
+		for (i = 0; i < g->g_ndfas; i++) {
+			if (strcmp(lb->lb_str, g->g_dfa[i].d_name) == 0) {
+				if (debugging)
+					printf("Label %s is non-terminal %d.\n",
+						lb->lb_str,
+						g->g_dfa[i].d_type);
+				lb->lb_type = g->g_dfa[i].d_type;
+				lb->lb_str = NULL;
+				return;
+			}
+		}
+		for (i = 0; i < (int)N_TOKENS; i++) {
+			if (strcmp(lb->lb_str, tok_name[i]) == 0) {
+				if (debugging)
+					printf("Label %s is terminal %d.\n",
+						lb->lb_str, i);
+				lb->lb_type = i;
+				lb->lb_str = NULL;
+				return;
+			}
+		}
+		printf("Can't translate NAME label '%s'\n", lb->lb_str);
+		return;
+	}
+	
+	if (lb->lb_type == STRING) {
+		if (isalpha(lb->lb_str[1])) {
+			char *p, *strchr();
+			if (debugging)
+				printf("Label %s is a keyword\n", lb->lb_str);
+			lb->lb_type = NAME;
+			lb->lb_str++;
+			p = strchr(lb->lb_str, '\'');
+			if (p)
+				*p = '\0';
+		}
+		else {
+			if (lb->lb_str[2] == lb->lb_str[0]) {
+				int type = (int) tok_1char(lb->lb_str[1]);
+				if (type != OP) {
+					lb->lb_type = type;
+					lb->lb_str = NULL;
+				}
+				else
+					printf("Unknown OP label %s\n",
+						lb->lb_str);
+			}
+			else
+				printf("Can't translate STRING label %s\n",
+					lb->lb_str);
+		}
+	}
+	else
+		printf("Can't translate label '%s'\n", labelrepr(lb));
+}
+
+void
+translatelabels(g)
+	grammar *g;
+{
+	int i;
+	
+	printf("Translating labels ...\n");
+	/* Don't translate EMPTY */
+	for (i = EMPTY+1; i < g->g_ll.ll_nlabels; i++)
+		translabel(g, &g->g_ll.ll_label[i]);
+}

Parser/grammar1.c

@@ -0,0 +1,52 @@
+/* Grammar subroutines needed by parser */
+
+#include "PROTO.h"
+#define NULL 0
+#include "assert.h"
+#include "grammar.h"
+#include "token.h"
+
+/* Return the DFA for the given type */
+
+dfa *
+finddfa(g, type)
+	grammar *g;
+	register int type;
+{
+	register int i;
+	register dfa *d;
+	
+	for (i = g->g_ndfas, d = g->g_dfa; --i >= 0; d++) {
+		if (d->d_type == type)
+			return d;
+	}
+	assert(0);
+	/* NOTREACHED */
+}
+
+char *
+labelrepr(lb)
+	label *lb;
+{
+	static char buf[100];
+	
+	if (lb->lb_type == ENDMARKER)
+		return "EMPTY";
+	else if (ISNONTERMINAL(lb->lb_type)) {
+		if (lb->lb_str == NULL) {
+			sprintf(buf, "NT%d", lb->lb_type);
+			return buf;
+		}
+		else
+			return lb->lb_str;
+	}
+	else {
+		if (lb->lb_str == NULL)
+			return tok_name[lb->lb_type];
+		else {
+			sprintf(buf, "%.32s(%.32s)",
+				tok_name[lb->lb_type], lb->lb_str);
+			return buf;
+		}
+	}
+}

Parser/intrcheck.c

@@ -0,0 +1,95 @@
+/* Check for interrupts */
+
+#ifdef MSDOS
+
+/* This might work for MS-DOS: */
+
+void
+initintr()
+{
+}
+
+int
+intrcheck()
+{
+	int interrupted = 0;
+	while (kbhit()) {
+		if (getch() == '\003')
+			interrupted = 1;
+	}
+	return interrupted;
+}
+
+#define OK
+
+#endif
+
+
+#ifdef THINK_C
+
+#include <MacHeaders>
+
+void
+initintr()
+{
+}
+
+int
+intrcheck()
+{
+	/* Static to make it faster(?) only */
+	static EventRecord e;
+	
+	/* XXX This fails if the user first types ahead and then
+	   decides to interrupt -- repeating Command-. until the
+	   event queue overflows may work though. */
+	if (EventAvail(keyDownMask|autoKeyMask, &e) &&
+				(e.modifiers & cmdKey) &&
+				(e.message & charCodeMask) == '.') {
+		(void) GetNextEvent(keyDownMask|autoKeyMask, &e);
+		return 1;
+	}
+	return 0;
+}
+
+#define OK
+
+#endif /* THINK_C */
+
+
+#ifndef OK
+
+/* Default version -- should work for Unix and Standard C */
+
+#include <stdio.h>
+#include <signal.h>
+
+#include "sigtype.h"
+
+static int interrupted;
+
+static SIGTYPE
+intcatcher(sig)
+	int sig;
+{
+	interrupted = 1;
+	signal(SIGINT, intcatcher);
+}
+
+void
+initintr()
+{
+	if (signal(SIGINT, SIG_IGN) != SIG_IGN)
+		signal(SIGINT, intcatcher);
+}
+
+int
+intrcheck()
+{
+	if (!interrupted)
+		return 0;
+	interrupted = 0;
+	return 1;
+}
+
+#endif /* !OK */

Parser/listnode.c

@@ -0,0 +1,68 @@
+/* List a node on a file */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "token.h"
+#include "node.h"
+
+static int level, atbol;
+
+static void
+list1node(fp, n)
+	FILE *fp;
+	node *n;
+{
+	if (n == 0)
+		return;
+	if (ISNONTERMINAL(TYPE(n))) {
+		int i;
+		for (i = 0; i < NCH(n); i++)
+			list1node(fp, CHILD(n, i));
+	}
+	else if (ISTERMINAL(TYPE(n))) {
+		switch (TYPE(n)) {
+		case INDENT:
+			++level;
+			break;
+		case DEDENT:
+			--level;
+			break;
+		default:
+			if (atbol) {
+				int i;
+				for (i = 0; i < level; ++i)
+					fprintf(fp, "\t");
+				atbol = 0;
+			}
+			if (TYPE(n) == NEWLINE) {
+				if (STR(n) != NULL)
+					fprintf(fp, "%s", STR(n));
+				fprintf(fp, "\n");
+				atbol = 1;
+			}
+			else
+				fprintf(fp, "%s ", STR(n));
+			break;
+		}
+	}
+	else
+		fprintf(fp, "? ");
+}
+
+void
+listnode(fp, n)
+	FILE *fp;
+	node *n;
+{
+	level = 0;
+	atbol = 1;
+	list1node(fp, n);
+}
+
+void
+listtree(n)
+	node *n;
+{
+	listnode(stdout, n);
+}

Parser/metagrammar.c

@@ -0,0 +1,151 @@
+#include "PROTO.h"
+#include "metagrammar.h"
+#include "grammar.h"
+static arc arcs_0_0[3] = {
+	{2, 0},
+	{3, 0},
+	{4, 1},
+};
+static arc arcs_0_1[1] = {
+	{0, 1},
+};
+static state states_0[2] = {
+	{3, arcs_0_0},
+	{1, arcs_0_1},
+};
+static arc arcs_1_0[1] = {
+	{5, 1},
+};
+static arc arcs_1_1[1] = {
+	{6, 2},
+};
+static arc arcs_1_2[1] = {
+	{7, 3},
+};
+static arc arcs_1_3[1] = {
+	{3, 4},
+};
+static arc arcs_1_4[1] = {
+	{0, 4},
+};
+static state states_1[5] = {
+	{1, arcs_1_0},
+	{1, arcs_1_1},
+	{1, arcs_1_2},
+	{1, arcs_1_3},
+	{1, arcs_1_4},
+};
+static arc arcs_2_0[1] = {
+	{8, 1},
+};
+static arc arcs_2_1[2] = {
+	{9, 0},
+	{0, 1},
+};
+static state states_2[2] = {
+	{1, arcs_2_0},
+	{2, arcs_2_1},
+};
+static arc arcs_3_0[1] = {
+	{10, 1},
+};
+static arc arcs_3_1[2] = {
+	{10, 1},
+	{0, 1},
+};
+static state states_3[2] = {
+	{1, arcs_3_0},
+	{2, arcs_3_1},
+};
+static arc arcs_4_0[2] = {
+	{11, 1},
+	{13, 2},
+};
+static arc arcs_4_1[1] = {
+	{7, 3},
+};
+static arc arcs_4_2[3] = {
+	{14, 4},
+	{15, 4},
+	{0, 2},
+};
+static arc arcs_4_3[1] = {
+	{12, 4},
+};
+static arc arcs_4_4[1] = {
+	{0, 4},
+};
+static state states_4[5] = {
+	{2, arcs_4_0},
+	{1, arcs_4_1},
+	{3, arcs_4_2},
+	{1, arcs_4_3},
+	{1, arcs_4_4},
+};
+static arc arcs_5_0[3] = {
+	{5, 1},
+	{16, 1},
+	{17, 2},
+};
+static arc arcs_5_1[1] = {
+	{0, 1},
+};
+static arc arcs_5_2[1] = {
+	{7, 3},
+};
+static arc arcs_5_3[1] = {
+	{18, 1},
+};
+static state states_5[4] = {
+	{3, arcs_5_0},
+	{1, arcs_5_1},
+	{1, arcs_5_2},
+	{1, arcs_5_3},
+};
+static dfa dfas[6] = {
+	{256, "MSTART", 0, 2, states_0,
+	 "\070\000\000"},
+	{257, "RULE", 0, 5, states_1,
+	 "\040\000\000"},
+	{258, "RHS", 0, 2, states_2,
+	 "\040\010\003"},
+	{259, "ALT", 0, 2, states_3,
+	 "\040\010\003"},
+	{260, "ITEM", 0, 5, states_4,
+	 "\040\010\003"},
+	{261, "ATOM", 0, 4, states_5,
+	 "\040\000\003"},
+};
+static label labels[19] = {
+	{0, "EMPTY"},
+	{256, 0},
+	{257, 0},
+	{4, 0},
+	{0, 0},
+	{1, 0},
+	{11, 0},
+	{258, 0},
+	{259, 0},
+	{18, 0},
+	{260, 0},
+	{9, 0},
+	{10, 0},
+	{261, 0},
+	{16, 0},
+	{14, 0},
+	{3, 0},
+	{7, 0},
+	{8, 0},
+};
+static grammar gram = {
+	6,
+	dfas,
+	{19, labels},
+	256
+};
+
+grammar *
+meta_grammar()
+{
+	return &gram;
+}

Parser/node.c

@@ -0,0 +1,47 @@
+/* Parse tree node implementation */
+
+#include "PROTO.h"
+#include "malloc.h"
+#include "node.h"
+
+node *
+newnode(type)
+	int type;
+{
+	node *n = NEW(node, 1);
+	if (n == NULL)
+		return NULL;
+	n->n_type = type;
+	n->n_str = NULL;
+	n->n_nchildren = 0;
+	n->n_child = NULL;
+	return n;
+}
+
+#define XXX 3 /* Node alignment factor to speed up realloc */
+#define XXXROUNDUP(n) ((n) == 1 ? 1 : ((n) + XXX - 1) / XXX * XXX)
+
+node *
+addchild(n1, type, str)
+	register node *n1;
+	int type;
+	char *str;
+{
+	register int nch = n1->n_nchildren;
+	register int nch1 = nch+1;
+	register node *n;
+	if (XXXROUNDUP(nch) < nch1) {
+		n = n1->n_child;
+		nch1 = XXXROUNDUP(nch1);
+		RESIZE(n, node, nch1);
+		if (n == NULL)
+			return NULL;
+		n1->n_child = n;
+	}
+	n = &n1->n_child[n1->n_nchildren++];
+	n->n_type = type;
+	n->n_str = str;
+	n->n_nchildren = 0;
+	n->n_child = NULL;
+	return n;
+}

Parser/parser.c

@@ -0,0 +1,396 @@
+/* Parser implementation */
+
+/* For a description, see the comments at end of this file */
+
+/* XXX To do: error recovery */
+
+#include <stdio.h>
+#include "assert.h"
+
+#include "PROTO.h"
+#include "malloc.h"
+#include "token.h"
+#include "grammar.h"
+#include "node.h"
+#include "parser.h"
+#include "errcode.h"
+
+extern int debugging;
+
+#ifdef DEBUG
+#define D(x) if (!debugging); else x
+#else
+#define D(x)
+#endif
+
+
+/* STACK DATA TYPE */
+
+static void s_reset PROTO((stack *));
+
+static void
+s_reset(s)
+	stack *s;
+{
+	s->s_top = &s->s_base[MAXSTACK];
+}
+
+#define s_empty(s) ((s)->s_top == &(s)->s_base[MAXSTACK])
+
+static int s_push PROTO((stack *, dfa *, node *));
+
+static int
+s_push(s, d, parent)
+	register stack *s;
+	dfa *d;
+	node *parent;
+{
+	register stackentry *top;
+	if (s->s_top == s->s_base) {
+		fprintf(stderr, "s_push: parser stack overflow\n");
+		return -1;
+	}
+	top = --s->s_top;
+	top->s_dfa = d;
+	top->s_parent = parent;
+	top->s_state = 0;
+	return 0;
+}
+
+#ifdef DEBUG
+
+static void s_pop PROTO((stack *));
+
+static void
+s_pop(s)
+	register stack *s;
+{
+	if (s_empty(s)) {
+		fprintf(stderr, "s_pop: parser stack underflow -- FATAL\n");
+		abort();
+	}
+	s->s_top++;
+}
+
+#else /* !DEBUG */
+
+#define s_pop(s) (s)->s_top++
+
+#endif
+
+
+/* PARSER CREATION */
+
+parser_state *
+newparser(g, start)
+	grammar *g;
+	int start;
+{
+	parser_state *ps;
+	
+	if (!g->g_accel)
+		addaccelerators(g);
+	ps = NEW(parser_state, 1);
+	if (ps == NULL)
+		return NULL;
+	ps->p_grammar = g;
+	ps->p_tree = newnode(start);
+	if (ps->p_tree == NULL) {
+		if (ps->p_tree != NULL)
+			DEL(ps->p_tree); /* XXX freeing a node!?! */
+		DEL(ps);
+		return NULL;
+	}
+	s_reset(&ps->p_stack);
+	(void) s_push(&ps->p_stack, finddfa(g, start), ps->p_tree);
+	return ps;
+}
+
+void
+delparser(ps)
+	parser_state *ps;
+{
+	DEL(ps);
+}
+
+
+/* PARSER STACK OPERATIONS */
+
+static int shift PROTO((stack *, int, char *, int));
+
+static int
+shift(s, type, str, newstate)
+	register stack *s;
+	int type;
+	char *str;
+	int newstate;
+{
+	assert(!s_empty(s));
+	if (addchild(s->s_top->s_parent, type, str) == NULL) {
+		fprintf(stderr, "shift: no mem in addchild\n");
+		return -1;
+	}
+	s->s_top->s_state = newstate;
+	return 0;
+}
+
+static int push PROTO((stack *, int, dfa *, int));
+
+static int
+push(s, type, d, newstate)
+	register stack *s;
+	int type;
+	dfa *d;
+	int newstate;
+{
+	register node *n;
+	n = s->s_top->s_parent;
+	assert(!s_empty(s));
+	if (addchild(n, type, (char *)NULL) == NULL) {
+		fprintf(stderr, "push: no mem in addchild\n");
+		return -1;
+	}
+	s->s_top->s_state = newstate;
+	return s_push(s, d, CHILD(n, NCH(n)-1));
+}
+
+
+/* PARSER PROPER */
+
+static int classify PROTO((grammar *, int, char *));
+
+static int
+classify(g, type, str)
+	grammar *g;
+	register int type;
+	char *str;
+{
+	register int n = g->g_ll.ll_nlabels;
+	
+	if (type == NAME) {
+		register char *s = str;
+		register label *l = g->g_ll.ll_label;
+		register int i;
+		for (i = n; i > 0; i--, l++) {
+			if (l->lb_type == NAME && l->lb_str != NULL &&
+					l->lb_str[0] == s[0] &&
+					strcmp(l->lb_str, s) == 0) {
+				D(printf("It's a keyword\n"));
+				return n - i;
+			}
+		}
+	}
+	
+	{
+		register label *l = g->g_ll.ll_label;
+		register int i;
+		for (i = n; i > 0; i--, l++) {
+			if (l->lb_type == type && l->lb_str == NULL) {
+				D(printf("It's a token we know\n"));
+				return n - i;
+			}
+		}
+	}
+	
+	D(printf("Illegal token\n"));
+	return -1;
+}
+
+int
+addtoken(ps, type, str)
+	register parser_state *ps;
+	register int type;
+	char *str;
+{
+	register int ilabel;
+	
+	D(printf("Token %s/'%s' ... ", tok_name[type], str));
+	
+	/* Find out which label this token is */
+	ilabel = classify(ps->p_grammar, type, str);
+	if (ilabel < 0)
+		return E_SYNTAX;
+	
+	/* Loop until the token is shifted or an error occurred */
+	for (;;) {
+		/* Fetch the current dfa and state */
+		register dfa *d = ps->p_stack.s_top->s_dfa;
+		register state *s = &d->d_state[ps->p_stack.s_top->s_state];
+		
+		D(printf(" DFA '%s', state %d:",
+			d->d_name, ps->p_stack.s_top->s_state));
+		
+		/* Check accelerator */
+		if (s->s_lower <= ilabel && ilabel < s->s_upper) {
+			register int x = s->s_accel[ilabel - s->s_lower];
+			if (x != -1) {
+				if (x & (1<<7)) {
+					/* Push non-terminal */
+					int nt = (x >> 8) + NT_OFFSET;
+					int arrow = x & ((1<<7)-1);
+					dfa *d1 = finddfa(ps->p_grammar, nt);
+					if (push(&ps->p_stack, nt, d1, arrow) < 0) {
+						D(printf(" MemError: push.\n"));
+						return E_NOMEM;
+					}
+					D(printf(" Push ...\n"));
+					continue;
+				}
+				
+				/* Shift the token */
+				if (shift(&ps->p_stack, type, str, x) < 0) {
+					D(printf(" MemError: shift.\n"));
+					return E_NOMEM;
+				}
+				D(printf(" Shift.\n"));
+				/* Pop while we are in an accept-only state */
+				while (s = &d->d_state
+						[ps->p_stack.s_top->s_state],
+					s->s_accept && s->s_narcs == 1) {
+					D(printf("  Direct pop.\n"));
+					s_pop(&ps->p_stack);
+					if (s_empty(&ps->p_stack)) {
+						D(printf("  ACCEPT.\n"));
+						return E_DONE;
+					}
+					d = ps->p_stack.s_top->s_dfa;
+				}
+				return E_OK;
+			}
+		}
+		
+		if (s->s_accept) {
+			/* Pop this dfa and try again */
+			s_pop(&ps->p_stack);
+			D(printf(" Pop ...\n"));
+			if (s_empty(&ps->p_stack)) {
+				D(printf(" Error: bottom of stack.\n"));
+				return E_SYNTAX;
+			}
+			continue;
+		}
+		
+		/* Stuck, report syntax error */
+		D(printf(" Error.\n"));
+		return E_SYNTAX;
+	}
+}
+
+
+#ifdef DEBUG
+
+/* DEBUG OUTPUT */
+
+void
+dumptree(g, n)
+	grammar *g;
+	node *n;
+{
+	int i;
+	
+	if (n == NULL)
+		printf("NIL");
+	else {
+		label l;
+		l.lb_type = TYPE(n);
+		l.lb_str = TYPE(str);
+		printf("%s", labelrepr(&l));
+		if (ISNONTERMINAL(TYPE(n))) {
+			printf("(");
+			for (i = 0; i < NCH(n); i++) {
+				if (i > 0)
+					printf(",");
+				dumptree(g, CHILD(n, i));
+			}
+			printf(")");
+		}
+	}
+}
+
+void
+showtree(g, n)
+	grammar *g;
+	node *n;
+{
+	int i;
+	
+	if (n == NULL)
+		return;
+	if (ISNONTERMINAL(TYPE(n))) {
+		for (i = 0; i < NCH(n); i++)
+			showtree(g, CHILD(n, i));
+	}
+	else if (ISTERMINAL(TYPE(n))) {
+		printf("%s", tok_name[TYPE(n)]);
+		if (TYPE(n) == NUMBER || TYPE(n) == NAME)
+			printf("(%s)", STR(n));
+		printf(" ");
+	}
+	else
+		printf("? ");
+}
+
+void
+printtree(ps)
+	parser_state *ps;
+{
+	if (debugging) {
+		printf("Parse tree:\n");
+		dumptree(ps->p_grammar, ps->p_tree);
+		printf("\n");
+		printf("Tokens:\n");
+		showtree(ps->p_grammar, ps->p_tree);
+		printf("\n");
+	}
+	printf("Listing:\n");
+	listtree(ps->p_tree);
+	printf("\n");
+}
+
+#endif /* DEBUG */
+
+/*
+
+Description
+-----------
+
+The parser's interface is different than usual: the function addtoken()
+must be called for each token in the input.  This makes it possible to
+turn it into an incremental parsing system later.  The parsing system
+constructs a parse tree as it goes.
+
+A parsing rule is represented as a Deterministic Finite-state Automaton
+(DFA).  A node in a DFA represents a state of the parser; an arc represents
+a transition.  Transitions are either labeled with terminal symbols or
+with non-terminals.  When the parser decides to follow an arc labeled
+with a non-terminal, it is invoked recursively with the DFA representing
+the parsing rule for that as its initial state; when that DFA accepts,
+the parser that invoked it continues.  The parse tree constructed by the
+recursively called parser is inserted as a child in the current parse tree.
+
+The DFA's can be constructed automatically from a more conventional
+language description.  An extended LL(1) grammar (ELL(1)) is suitable.
+Certain restrictions make the parser's life easier: rules that can produce
+the empty string should be outlawed (there are other ways to put loops
+or optional parts in the language).  To avoid the need to construct
+FIRST sets, we can require that all but the last alternative of a rule
+(really: arc going out of a DFA's state) must begin with a terminal
+symbol.
+
+As an example, consider this grammar:
+
+expr:	term (OP term)*
+term:	CONSTANT | '(' expr ')'
+
+The DFA corresponding to the rule for expr is:
+
+------->.---term-->.------->
+	^          |
+	|          |
+	\----OP----/
+
+The parse tree generated for the input a+b is:
+
+(expr: (term: (NAME: a)), (OP: +), (term: (NAME: b)))
+
+*/

Parser/parser.h

@@ -0,0 +1,25 @@
+/* Parser interface */
+
+#define MAXSTACK 100
+
+typedef struct _stackentry {
+	int		 s_state;	/* State in current DFA */
+	dfa		*s_dfa;		/* Current DFA */
+	node		*s_parent;	/* Where to add next node */
+} stackentry;
+
+typedef struct _stack {
+	stackentry	*s_top;		/* Top entry */
+	stackentry	 s_base[MAXSTACK];/* Array of stack entries */
+					/* NB The stack grows down */
+} stack;
+
+typedef struct {
+	struct _stack	 p_stack;	/* Stack of parser states */
+	struct _grammar	*p_grammar;	/* Grammar to use */
+	struct _node	*p_tree;	/* Top of parse tree */
+} parser_state;
+
+parser_state *newparser PROTO((struct _grammar *g, int start));
+void delparser PROTO((parser_state *ps));
+int addtoken PROTO((parser_state *ps, int type, char *str));

Parser/parsetok.c

@@ -0,0 +1,131 @@
+/* Parser-tokenizer link implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "malloc.h"
+#include "tokenizer.h"
+#include "node.h"
+#include "grammar.h"
+#include "parser.h"
+#include "errcode.h"
+
+extern int debugging;
+
+
+/* Parse input coming from the given tokenizer structure.
+   Return error code. */
+
+static int
+parsetok(tok, g, start, n_ret)
+	struct tok_state *tok;
+	grammar *g;
+	int start;
+	node **n_ret;
+{
+	parser_state *ps;
+	int ret;
+	
+	if ((ps = newparser(g, start)) == NULL) {
+		fprintf(stderr, "no mem for new parser\n");
+		return E_NOMEM;
+	}
+	
+	for (;;) {
+		char *a, *b;
+		int type;
+		int len;
+		char *str;
+		
+		type = tok_get(tok, &a, &b);
+		if (type == ERRORTOKEN) {
+			ret = tok->done;
+			break;
+		}
+		len = b - a;
+		str = NEW(char, len + 1);
+		if (str == NULL) {
+			fprintf(stderr, "no mem for next token\n");
+			ret = E_NOMEM;
+			break;
+		}
+		strncpy(str, a, len);
+		str[len] = '\0';
+		ret = addtoken(ps, (int)type, str);
+		if (ret != E_OK) {
+			if (ret == E_DONE)
+				*n_ret = ps->p_tree;
+			else if (tok->lineno <= 1 && tok->done == E_EOF)
+				ret = E_EOF;
+			break;
+		}
+	}
+	
+	delparser(ps);
+	return ret;
+}
+
+
+/* Parse input coming from a string.  Return error code. */
+
+int
+parsestring(s, g, start, n_ret)
+	char *s;
+	grammar *g;
+	int start;
+	node **n_ret;
+{
+	struct tok_state *tok = tok_setups(s);
+	int ret;
+	
+	if (tok == NULL) {
+		fprintf(stderr, "no mem for tok_setups\n");
+		return E_NOMEM;
+	}
+	ret = parsetok(tok, g, start, n_ret);
+	if (ret == E_TOKEN || ret == E_SYNTAX) {
+		fprintf(stderr, "String parsing error at line %d\n",
+			tok->lineno);
+	}
+	tok_free(tok);
+	return ret;
+}
+
+
+/* Parse input coming from a file.  Return error code. */
+
+int
+parsefile(fp, g, start, ps1, ps2, n_ret)
+	FILE *fp;
+	grammar *g;
+	int start;
+	char *ps1, *ps2;
+	node **n_ret;
+{
+	struct tok_state *tok = tok_setupf(fp, ps1, ps2);
+	int ret;
+	
+	if (tok == NULL) {
+		fprintf(stderr, "no mem for tok_setupf\n");
+		return E_NOMEM;
+	}
+	ret = parsetok(tok, g, start, n_ret);
+	if (ret == E_TOKEN || ret == E_SYNTAX) {
+		char *p;
+		fprintf(stderr, "Parsing error at line %d:\n",
+			tok->lineno);
+		*tok->inp = '\0';
+		if (tok->inp > tok->buf && tok->inp[-1] == '\n')
+			tok->inp[-1] = '\0';
+		fprintf(stderr, "%s\n", tok->buf);
+		for (p = tok->buf; p < tok->cur; p++) {
+			if (*p == '\t')
+				putc('\t', stderr);
+			else
+				putc(' ', stderr);
+		}
+		fprintf(stderr, "^\n");
+	}
+	tok_free(tok);
+	return ret;
+}

Parser/pgen.c

@@ -0,0 +1,729 @@
+/* Parser generator */
+
+/* For a description, see the comments at end of this file */
+
+#include <stdio.h>
+#include "assert.h"
+
+#include "PROTO.h"
+#include "malloc.h"
+#include "token.h"
+#include "node.h"
+#include "grammar.h"
+#include "metagrammar.h"
+#include "pgen.h"
+
+extern int debugging;
+
+
+/* PART ONE -- CONSTRUCT NFA -- Cf. Algorithm 3.2 from [Aho&Ullman 77] */
+
+typedef struct _nfaarc {
+	int	ar_label;
+	int	ar_arrow;
+} nfaarc;
+
+typedef struct _nfastate {
+	int	st_narcs;
+	nfaarc	*st_arc;
+} nfastate;
+
+typedef struct _nfa {
+	int		nf_type;
+	char		*nf_name;
+	int		nf_nstates;
+	nfastate	*nf_state;
+	int		nf_start, nf_finish;
+} nfa;
+
+static int
+addnfastate(nf)
+	nfa *nf;
+{
+	nfastate *st;
+	
+	RESIZE(nf->nf_state, nfastate, nf->nf_nstates + 1);
+	if (nf->nf_state == NULL)
+		fatal("out of mem");
+	st = &nf->nf_state[nf->nf_nstates++];
+	st->st_narcs = 0;
+	st->st_arc = NULL;
+	return st - nf->nf_state;
+}
+
+static void
+addnfaarc(nf, from, to, lbl)
+	nfa *nf;
+	int from, to, lbl;
+{
+	nfastate *st;
+	nfaarc *ar;
+	
+	st = &nf->nf_state[from];
+	RESIZE(st->st_arc, nfaarc, st->st_narcs + 1);
+	if (st->st_arc == NULL)
+		fatal("out of mem");
+	ar = &st->st_arc[st->st_narcs++];
+	ar->ar_label = lbl;
+	ar->ar_arrow = to;
+}
+
+static nfa *
+newnfa(name)
+	char *name;
+{
+	nfa *nf;
+	static type = NT_OFFSET; /* All types will be disjunct */
+	
+	nf = NEW(nfa, 1);
+	if (nf == NULL)
+		fatal("no mem for new nfa");
+	nf->nf_type = type++;
+	nf->nf_name = name; /* XXX strdup(name) ??? */
+	nf->nf_nstates = 0;
+	nf->nf_state = NULL;
+	nf->nf_start = nf->nf_finish = -1;
+	return nf;
+}
+
+typedef struct _nfagrammar {
+	int		gr_nnfas;
+	nfa		**gr_nfa;
+	labellist	gr_ll;
+} nfagrammar;
+
+static nfagrammar *
+newnfagrammar()
+{
+	nfagrammar *gr;
+	
+	gr = NEW(nfagrammar, 1);
+	if (gr == NULL)
+		fatal("no mem for new nfa grammar");
+	gr->gr_nnfas = 0;
+	gr->gr_nfa = NULL;
+	gr->gr_ll.ll_nlabels = 0;
+	gr->gr_ll.ll_label = NULL;
+	addlabel(&gr->gr_ll, ENDMARKER, "EMPTY");
+	return gr;
+}
+
+static nfa *
+addnfa(gr, name)
+	nfagrammar *gr;
+	char *name;
+{
+	nfa *nf;
+	
+	nf = newnfa(name);
+	RESIZE(gr->gr_nfa, nfa *, gr->gr_nnfas + 1);
+	if (gr->gr_nfa == NULL)
+		fatal("out of mem");
+	gr->gr_nfa[gr->gr_nnfas++] = nf;
+	addlabel(&gr->gr_ll, NAME, nf->nf_name);
+	return nf;
+}
+
+#ifdef DEBUG
+
+static char REQNFMT[] = "metacompile: less than %d children\n";
+
+#define REQN(i, count) \
+ 	if (i < count) { \
+		fprintf(stderr, REQNFMT, count); \
+		abort(); \
+	} else
+
+#else
+#define REQN(i, count)	/* empty */
+#endif
+
+static nfagrammar *
+metacompile(n)
+	node *n;
+{
+	nfagrammar *gr;
+	int i;
+	
+	printf("Compiling (meta-) parse tree into NFA grammar\n");
+	gr = newnfagrammar();
+	REQ(n, MSTART);
+	i = n->n_nchildren - 1; /* Last child is ENDMARKER */
+	n = n->n_child;
+	for (; --i >= 0; n++) {
+		if (n->n_type != NEWLINE)
+			compile_rule(gr, n);
+	}
+	return gr;
+}
+
+static
+compile_rule(gr, n)
+	nfagrammar *gr;
+	node *n;
+{
+	nfa *nf;
+	
+	REQ(n, RULE);
+	REQN(n->n_nchildren, 4);
+	n = n->n_child;
+	REQ(n, NAME);
+	nf = addnfa(gr, n->n_str);
+	n++;
+	REQ(n, COLON);
+	n++;
+	REQ(n, RHS);
+	compile_rhs(&gr->gr_ll, nf, n, &nf->nf_start, &nf->nf_finish);
+	n++;
+	REQ(n, NEWLINE);
+}
+
+static
+compile_rhs(ll, nf, n, pa, pb)
+	labellist *ll;
+	nfa *nf;
+	node *n;
+	int *pa, *pb;
+{
+	int i;
+	int a, b;
+	
+	REQ(n, RHS);
+	i = n->n_nchildren;
+	REQN(i, 1);
+	n = n->n_child;
+	REQ(n, ALT);
+	compile_alt(ll, nf, n, pa, pb);
+	if (--i <= 0)
+		return;
+	n++;
+	a = *pa;
+	b = *pb;
+	*pa = addnfastate(nf);
+	*pb = addnfastate(nf);
+	addnfaarc(nf, *pa, a, EMPTY);
+	addnfaarc(nf, b, *pb, EMPTY);
+	for (; --i >= 0; n++) {
+		REQ(n, VBAR);
+		REQN(i, 1);
+		--i;
+		n++;
+		REQ(n, ALT);
+		compile_alt(ll, nf, n, &a, &b);
+		addnfaarc(nf, *pa, a, EMPTY);
+		addnfaarc(nf, b, *pb, EMPTY);
+	}
+}
+
+static
+compile_alt(ll, nf, n, pa, pb)
+	labellist *ll;
+	nfa *nf;
+	node *n;
+	int *pa, *pb;
+{
+	int i;
+	int a, b;
+	
+	REQ(n, ALT);
+	i = n->n_nchildren;
+	REQN(i, 1);
+	n = n->n_child;
+	REQ(n, ITEM);
+	compile_item(ll, nf, n, pa, pb);
+	--i;
+	n++;
+	for (; --i >= 0; n++) {
+		if (n->n_type == COMMA) { /* XXX Temporary */
+			REQN(i, 1);
+			--i;
+			n++;
+		}
+		REQ(n, ITEM);
+		compile_item(ll, nf, n, &a, &b);
+		addnfaarc(nf, *pb, a, EMPTY);
+		*pb = b;
+	}
+}
+
+static
+compile_item(ll, nf, n, pa, pb)
+	labellist *ll;
+	nfa *nf;
+	node *n;
+	int *pa, *pb;
+{
+	int i;
+	int a, b;
+	
+	REQ(n, ITEM);
+	i = n->n_nchildren;
+	REQN(i, 1);
+	n = n->n_child;
+	if (n->n_type == LSQB) {
+		REQN(i, 3);
+		n++;
+		REQ(n, RHS);
+		*pa = addnfastate(nf);
+		*pb = addnfastate(nf);
+		addnfaarc(nf, *pa, *pb, EMPTY);
+		compile_rhs(ll, nf, n, &a, &b);
+		addnfaarc(nf, *pa, a, EMPTY);
+		addnfaarc(nf, b, *pb, EMPTY);
+		REQN(i, 1);
+		n++;
+		REQ(n, RSQB);
+	}
+	else {
+		compile_atom(ll, nf, n, pa, pb);
+		if (--i <= 0)
+			return;
+		n++;
+		addnfaarc(nf, *pb, *pa, EMPTY);
+		if (n->n_type == STAR)
+			*pb = *pa;
+		else
+			REQ(n, PLUS);
+	}
+}
+
+static
+compile_atom(ll, nf, n, pa, pb)
+	labellist *ll;
+	nfa *nf;
+	node *n;
+	int *pa, *pb;
+{
+	int i;
+	
+	REQ(n, ATOM);
+	i = n->n_nchildren;
+	REQN(i, 1);
+	n = n->n_child;
+	if (n->n_type == LPAR) {
+		REQN(i, 3);
+		n++;
+		REQ(n, RHS);
+		compile_rhs(ll, nf, n, pa, pb);
+		n++;
+		REQ(n, RPAR);
+	}
+	else if (n->n_type == NAME || n->n_type == STRING) {
+		*pa = addnfastate(nf);
+		*pb = addnfastate(nf);
+		addnfaarc(nf, *pa, *pb, addlabel(ll, n->n_type, n->n_str));
+	}
+	else
+		REQ(n, NAME);
+}
+
+static void
+dumpstate(ll, nf, istate)
+	labellist *ll;
+	nfa *nf;
+	int istate;
+{
+	nfastate *st;
+	int i;
+	nfaarc *ar;
+	
+	printf("%c%2d%c",
+		istate == nf->nf_start ? '*' : ' ',
+		istate,
+		istate == nf->nf_finish ? '.' : ' ');
+	st = &nf->nf_state[istate];
+	ar = st->st_arc;
+	for (i = 0; i < st->st_narcs; i++) {
+		if (i > 0)
+			printf("\n    ");
+		printf("-> %2d  %s", ar->ar_arrow,
+			labelrepr(&ll->ll_label[ar->ar_label]));
+		ar++;
+	}
+	printf("\n");
+}
+
+static void
+dumpnfa(ll, nf)
+	labellist *ll;
+	nfa *nf;
+{
+	int i;
+	
+	printf("NFA '%s' has %d states; start %d, finish %d\n",
+		nf->nf_name, nf->nf_nstates, nf->nf_start, nf->nf_finish);
+	for (i = 0; i < nf->nf_nstates; i++)
+		dumpstate(ll, nf, i);
+}
+
+
+/* PART TWO -- CONSTRUCT DFA -- Algorithm 3.1 from [Aho&Ullman 77] */
+
+static int
+addclosure(ss, nf, istate)
+	bitset ss;
+	nfa *nf;
+	int istate;
+{
+	if (addbit(ss, istate)) {
+		nfastate *st = &nf->nf_state[istate];
+		nfaarc *ar = st->st_arc;
+		int i;
+		
+		for (i = st->st_narcs; --i >= 0; ) {
+			if (ar->ar_label == EMPTY)
+				addclosure(ss, nf, ar->ar_arrow);
+			ar++;
+		}
+	}
+}
+
+typedef struct _ss_arc {
+	bitset	sa_bitset;
+	int	sa_arrow;
+	int	sa_label;
+} ss_arc;
+
+typedef struct _ss_state {
+	bitset	ss_ss;
+	int	ss_narcs;
+	ss_arc	*ss_arc;
+	int	ss_deleted;
+	int	ss_finish;
+	int	ss_rename;
+} ss_state;
+
+typedef struct _ss_dfa {
+	int	sd_nstates;
+	ss_state *sd_state;
+} ss_dfa;
+
+static
+makedfa(gr, nf, d)
+	nfagrammar *gr;
+	nfa *nf;
+	dfa *d;
+{
+	int nbits = nf->nf_nstates;
+	bitset ss;
+	int xx_nstates;
+	ss_state *xx_state, *yy;
+	ss_arc *zz;
+	int istate, jstate, iarc, jarc, ibit;
+	nfastate *st;
+	nfaarc *ar;
+	
+	ss = newbitset(nbits);
+	addclosure(ss, nf, nf->nf_start);
+	xx_state = NEW(ss_state, 1);
+	if (xx_state == NULL)
+		fatal("no mem for xx_state in makedfa");
+	xx_nstates = 1;
+	yy = &xx_state[0];
+	yy->ss_ss = ss;
+	yy->ss_narcs = 0;
+	yy->ss_arc = NULL;
+	yy->ss_deleted = 0;
+	yy->ss_finish = testbit(ss, nf->nf_finish);
+	if (yy->ss_finish)
+		printf("Error: nonterminal '%s' may produce empty.\n",
+			nf->nf_name);
+	
+	/* This algorithm is from a book written before
+	   the invention of structured programming... */
+
+	/* For each unmarked state... */
+	for (istate = 0; istate < xx_nstates; ++istate) {
+		yy = &xx_state[istate];
+		ss = yy->ss_ss;
+		/* For all its states... */
+		for (ibit = 0; ibit < nf->nf_nstates; ++ibit) {
+			if (!testbit(ss, ibit))
+				continue;
+			st = &nf->nf_state[ibit];
+			/* For all non-empty arcs from this state... */
+			for (iarc = 0; iarc < st->st_narcs; iarc++) {
+				ar = &st->st_arc[iarc];
+				if (ar->ar_label == EMPTY)
+					continue;
+				/* Look up in list of arcs from this state */
+				for (jarc = 0; jarc < yy->ss_narcs; ++jarc) {
+					zz = &yy->ss_arc[jarc];
+					if (ar->ar_label == zz->sa_label)
+						goto found;
+				}
+				/* Add new arc for this state */
+				RESIZE(yy->ss_arc, ss_arc, yy->ss_narcs + 1);
+				if (yy->ss_arc == NULL)
+					fatal("out of mem");
+				zz = &yy->ss_arc[yy->ss_narcs++];
+				zz->sa_label = ar->ar_label;
+				zz->sa_bitset = newbitset(nbits);
+				zz->sa_arrow = -1;
+			 found:	;
+				/* Add destination */
+				addclosure(zz->sa_bitset, nf, ar->ar_arrow);
+			}
+		}
+		/* Now look up all the arrow states */
+		for (jarc = 0; jarc < xx_state[istate].ss_narcs; jarc++) {
+			zz = &xx_state[istate].ss_arc[jarc];
+			for (jstate = 0; jstate < xx_nstates; jstate++) {
+				if (samebitset(zz->sa_bitset,
+					xx_state[jstate].ss_ss, nbits)) {
+					zz->sa_arrow = jstate;
+					goto done;
+				}
+			}
+			RESIZE(xx_state, ss_state, xx_nstates + 1);
+			if (xx_state == NULL)
+				fatal("out of mem");
+			zz->sa_arrow = xx_nstates;
+			yy = &xx_state[xx_nstates++];
+			yy->ss_ss = zz->sa_bitset;
+			yy->ss_narcs = 0;
+			yy->ss_arc = NULL;
+			yy->ss_deleted = 0;
+			yy->ss_finish = testbit(yy->ss_ss, nf->nf_finish);
+		 done:	;
+		}
+	}
+	
+	if (debugging)
+		printssdfa(xx_nstates, xx_state, nbits, &gr->gr_ll,
+						"before minimizing");
+	
+	simplify(xx_nstates, xx_state);
+	
+	if (debugging)
+		printssdfa(xx_nstates, xx_state, nbits, &gr->gr_ll,
+						"after minimizing");
+	
+	convert(d, xx_nstates, xx_state);
+	
+	/* XXX cleanup */
+}
+
+static
+printssdfa(xx_nstates, xx_state, nbits, ll, msg)
+	int xx_nstates;
+	ss_state *xx_state;
+	int nbits;
+	labellist *ll;
+	char *msg;
+{
+	int i, ibit, iarc;
+	ss_state *yy;
+	ss_arc *zz;
+	
+	printf("Subset DFA %s\n", msg);
+	for (i = 0; i < xx_nstates; i++) {
+		yy = &xx_state[i];
+		if (yy->ss_deleted)
+			continue;
+		printf(" Subset %d", i);
+		if (yy->ss_finish)
+			printf(" (finish)");
+		printf(" { ");
+		for (ibit = 0; ibit < nbits; ibit++) {
+			if (testbit(yy->ss_ss, ibit))
+				printf("%d ", ibit);
+		}
+		printf("}\n");
+		for (iarc = 0; iarc < yy->ss_narcs; iarc++) {
+			zz = &yy->ss_arc[iarc];
+			printf("  Arc to state %d, label %s\n",
+				zz->sa_arrow,
+				labelrepr(&ll->ll_label[zz->sa_label]));
+		}
+	}
+}
+
+
+/* PART THREE -- SIMPLIFY DFA */
+
+/* Simplify the DFA by repeatedly eliminating states that are
+   equivalent to another oner.  This is NOT Algorithm 3.3 from
+   [Aho&Ullman 77].  It does not always finds the minimal DFA,
+   but it does usually make a much smaller one...  (For an example
+   of sub-optimal behaviour, try S: x a b+ | y a b+.)
+*/
+
+static int
+samestate(s1, s2)
+	ss_state *s1, *s2;
+{
+	int i;
+	
+	if (s1->ss_narcs != s2->ss_narcs || s1->ss_finish != s2->ss_finish)
+		return 0;
+	for (i = 0; i < s1->ss_narcs; i++) {
+		if (s1->ss_arc[i].sa_arrow != s2->ss_arc[i].sa_arrow ||
+			s1->ss_arc[i].sa_label != s2->ss_arc[i].sa_label)
+			return 0;
+	}
+	return 1;
+}
+
+static void
+renamestates(xx_nstates, xx_state, from, to)
+	int xx_nstates;
+	ss_state *xx_state;
+	int from, to;
+{
+	int i, j;
+	
+	if (debugging)
+		printf("Rename state %d to %d.\n", from, to);
+	for (i = 0; i < xx_nstates; i++) {
+		if (xx_state[i].ss_deleted)
+			continue;
+		for (j = 0; j < xx_state[i].ss_narcs; j++) {
+			if (xx_state[i].ss_arc[j].sa_arrow == from)
+				xx_state[i].ss_arc[j].sa_arrow = to;
+		}
+	}
+}
+
+static
+simplify(xx_nstates, xx_state)
+	int xx_nstates;
+	ss_state *xx_state;
+{
+	int changes;
+	int i, j, k;
+	
+	do {
+		changes = 0;
+		for (i = 1; i < xx_nstates; i++) {
+			if (xx_state[i].ss_deleted)
+				continue;
+			for (j = 0; j < i; j++) {
+				if (xx_state[j].ss_deleted)
+					continue;
+				if (samestate(&xx_state[i], &xx_state[j])) {
+					xx_state[i].ss_deleted++;
+					renamestates(xx_nstates, xx_state, i, j);
+					changes++;
+					break;
+				}
+			}
+		}
+	} while (changes);
+}
+
+
+/* PART FOUR -- GENERATE PARSING TABLES */
+
+/* Convert the DFA into a grammar that can be used by our parser */
+
+static
+convert(d, xx_nstates, xx_state)
+	dfa *d;
+	int xx_nstates;
+	ss_state *xx_state;
+{
+	int i, j;
+	ss_state *yy;
+	ss_arc *zz;
+	
+	for (i = 0; i < xx_nstates; i++) {
+		yy = &xx_state[i];
+		if (yy->ss_deleted)
+			continue;
+		yy->ss_rename = addstate(d);
+	}
+	
+	for (i = 0; i < xx_nstates; i++) {
+		yy = &xx_state[i];
+		if (yy->ss_deleted)
+			continue;
+		for (j = 0; j < yy->ss_narcs; j++) {
+			zz = &yy->ss_arc[j];
+			addarc(d, yy->ss_rename,
+				xx_state[zz->sa_arrow].ss_rename,
+				zz->sa_label);
+		}
+		if (yy->ss_finish)
+			addarc(d, yy->ss_rename, yy->ss_rename, 0);
+	}
+	
+	d->d_initial = 0;
+}
+
+
+/* PART FIVE -- GLUE IT ALL TOGETHER */
+
+static grammar *
+maketables(gr)
+	nfagrammar *gr;
+{
+	int i;
+	nfa *nf;
+	dfa *d;
+	grammar *g;
+	
+	if (gr->gr_nnfas == 0)
+		return NULL;
+	g = newgrammar(gr->gr_nfa[0]->nf_type);
+			/* XXX first rule must be start rule */
+	g->g_ll = gr->gr_ll;
+	
+	for (i = 0; i < gr->gr_nnfas; i++) {
+		nf = gr->gr_nfa[i];
+		if (debugging) {
+			printf("Dump of NFA for '%s' ...\n", nf->nf_name);
+			dumpnfa(&gr->gr_ll, nf);
+		}
+		printf("Making DFA for '%s' ...\n", nf->nf_name);
+		d = adddfa(g, nf->nf_type, nf->nf_name);
+		makedfa(gr, gr->gr_nfa[i], d);
+	}
+	
+	return g;
+}
+
+grammar *
+pgen(n)
+	node *n;
+{
+	nfagrammar *gr;
+	grammar *g;
+	
+	gr = metacompile(n);
+	g = maketables(gr);
+	translatelabels(g);
+	addfirstsets(g);
+	return g;
+}
+
+
+/*
+
+Description
+-----------
+
+Input is a grammar in extended BNF (using * for repetition, + for
+at-least-once repetition, [] for optional parts, | for alternatives and
+() for grouping).  This has already been parsed and turned into a parse
+tree.
+
+Each rule is considered as a regular expression in its own right.
+It is turned into a Non-deterministic Finite Automaton (NFA), which
+is then turned into a Deterministic Finite Automaton (DFA), which is then
+optimized to reduce the number of states.  See [Aho&Ullman 77] chapter 3,
+or similar compiler books (this technique is more often used for lexical
+analyzers).
+
+The DFA's are used by the parser as parsing tables in a special way
+that's probably unique.  Before they are usable, the FIRST sets of all
+non-terminals are computed.
+
+Reference
+---------
+
+[Aho&Ullman 77]
+	Aho&Ullman, Principles of Compiler Design, Addison-Wesley 1977
+	(first edition)
+
+*/

Parser/pgen.h

@@ -0,0 +1,6 @@
+/* Parser generator interface */
+
+extern grammar gram;
+
+extern grammar *meta_grammar PROTO((void));
+extern grammar *pgen PROTO((node *));

Parser/pgenmain.c

@@ -0,0 +1,111 @@
+/* Parser generator main program */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "grammar.h"
+#include "node.h"
+#include "parsetok.h"
+#include "pgen.h"
+
+int debugging;
+
+#ifdef THINK_C
+char *
+askfile()
+{
+	char buf[256];
+	static char name[256];
+	printf("Input file name: ");
+	if (fgets(buf, sizeof buf, stdin) == NULL) {
+		printf("EOF\n");
+		exit(1);
+	}
+	if (sscanf(buf, " %s ", name) != 1) {
+		printf("No file\n");
+		exit(1);
+	}
+	return name;
+}
+#endif
+
+grammar *
+getgrammar(filename)
+	char *filename;
+{
+	FILE *fp;
+	node *n;
+	grammar *g0, *g;
+	
+	fp = fopen(filename, "r");
+	if (fp == NULL) {
+		perror(filename);
+		exit(1);
+	}
+	g0 = meta_grammar();
+	n = NULL;
+	parsefile(fp, g0, g0->g_start, (char *)NULL, (char *)NULL, &n);
+	fclose(fp);
+	if (n == NULL) {
+		fprintf(stderr, "Parsing error.\n");
+		exit(1);
+	}
+	g = pgen(n);
+	if (g == NULL) {
+		printf("Bad grammar.\n");
+		exit(1);
+	}
+	return g;
+}
+
+main(argc, argv)
+	int argc;
+	char **argv;
+{
+	grammar *g;
+	node *n;
+	FILE *fp;
+	char *filename;
+	
+#ifdef THINK_C
+	filename = askfile();
+#else
+	if (argc != 2) {
+		fprintf(stderr, "usage: %s grammar\n", argv[0]);
+		exit(2);
+	}
+	filename = argv[1];
+#endif
+	g = getgrammar(filename);
+	fp = fopen("graminit.c", "w");
+	if (fp == NULL) {
+		perror("graminit.c");
+		exit(1);
+	}
+	printf("Writing graminit.c ...\n");
+	printgrammar(g, fp);
+	fclose(fp);
+	fp = fopen("graminit.h", "w");
+	if (fp == NULL) {
+		perror("graminit.h");
+		exit(1);
+	}
+	printf("Writing graminit.h ...\n");
+	printnonterminals(g, fp);
+	fclose(fp);
+	exit(0);
+}
+
+void
+fatal(msg)
+	char *msg;
+{
+	fprintf(stderr, "pgen: FATAL ERROR: %s\n", msg);
+	exit(1);
+}
+
+/*	TO DO:
+
+	- improve user interface
+	- check for duplicate definitions of names (instead of fatal err)
+*/

Parser/printgrammar.c

@@ -0,0 +1,121 @@
+/* Print a bunch of C initializers that represent a grammar */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "grammar.h"
+
+static void
+printarcs(i, d, fp)
+	int i;
+	dfa *d;
+	FILE *fp;
+{
+	arc *a;
+	state *s;
+	int j, k;
+	
+	s = d->d_state;
+	for (j = 0; j < d->d_nstates; j++, s++) {
+		fprintf(fp, "static arc arcs_%d_%d[%d] = {\n",
+			i, j, s->s_narcs);
+		a = s->s_arc;
+		for (k = 0; k < s->s_narcs; k++, a++)
+			fprintf(fp, "\t{%d, %d},\n", a->a_lbl, a->a_arrow);
+		fprintf(fp, "};\n");
+	}
+}
+
+static void
+printstates(g, fp)
+	grammar *g;
+	FILE *fp;
+{
+	state *s;
+	dfa *d;
+	int i, j;
+	
+	d = g->g_dfa;
+	for (i = 0; i < g->g_ndfas; i++, d++) {
+		printarcs(i, d, fp);
+		fprintf(fp, "static state states_%d[%d] = {\n",
+			i, d->d_nstates);
+		s = d->d_state;
+		for (j = 0; j < d->d_nstates; j++, s++)
+			fprintf(fp, "\t{%d, arcs_%d_%d},\n",
+				s->s_narcs, i, j);
+		fprintf(fp, "};\n");
+	}
+}
+
+static void
+printdfas(g, fp)
+	grammar *g;
+	FILE *fp;
+{
+	dfa *d;
+	int i, j;
+	
+	printstates(g, fp);
+	fprintf(fp, "static dfa dfas[%d] = {\n", g->g_ndfas);
+	d = g->g_dfa;
+	for (i = 0; i < g->g_ndfas; i++, d++) {
+		fprintf(fp, "\t{%d, \"%s\", %d, %d, states_%d,\n",
+			d->d_type, d->d_name, d->d_initial, d->d_nstates, i);
+		fprintf(fp, "\t \"");
+		for (j = 0; j < NBYTES(g->g_ll.ll_nlabels); j++)
+			fprintf(fp, "\\%03o", d->d_first[j] & 0xff);
+		fprintf(fp, "\"},\n");
+	}
+	fprintf(fp, "};\n");
+}
+
+static void
+printlabels(g, fp)
+	grammar *g;
+	FILE *fp;
+{
+	label *l;
+	int i;
+	
+	fprintf(fp, "static label labels[%d] = {\n", g->g_ll.ll_nlabels);
+	l = g->g_ll.ll_label;
+	for (i = g->g_ll.ll_nlabels; --i >= 0; l++) {
+		if (l->lb_str == NULL)
+			fprintf(fp, "\t{%d, 0},\n", l->lb_type);
+		else
+			fprintf(fp, "\t{%d, \"%s\"},\n",
+				l->lb_type, l->lb_str);
+	}
+	fprintf(fp, "};\n");
+}
+
+void
+printgrammar(g, fp)
+	grammar *g;
+	FILE *fp;
+{
+	fprintf(fp, "#include \"PROTO.h\"\n");
+	fprintf(fp, "#include \"grammar.h\"\n");
+	printdfas(g, fp);
+	printlabels(g, fp);
+	fprintf(fp, "grammar gram = {\n");
+	fprintf(fp, "\t%d,\n", g->g_ndfas);
+	fprintf(fp, "\tdfas,\n");
+	fprintf(fp, "\t{%d, labels},\n", g->g_ll.ll_nlabels);
+	fprintf(fp, "\t%d\n", g->g_start);
+	fprintf(fp, "};\n");
+}
+
+void
+printnonterminals(g, fp)
+	grammar *g;
+	FILE *fp;
+{
+	dfa *d;
+	int i;
+	
+	d = g->g_dfa;
+	for (i = g->g_ndfas; --i >= 0; d++)
+		fprintf(fp, "#define %s %d\n", d->d_name, d->d_type);
+}

Parser/tokenizer.c

@@ -0,0 +1,490 @@
+/* Tokenizer implementation */
+
+/* XXX This is rather old, should be restructured perhaps */
+/* XXX Need a better interface to report errors than writing to stderr */
+
+#include <stdio.h>
+#include <ctype.h>
+#include "string.h"
+
+#include "PROTO.h"
+#include "malloc.h"
+#include "tokenizer.h"
+#include "errcode.h"
+
+#ifdef THINK_C
+#define TABSIZE 4
+#endif
+
+#ifndef TABSIZE
+#define TABSIZE 8
+#endif
+
+/* Token names */
+
+char *tok_name[] = {
+	"ENDMARKER",
+	"NAME",
+	"NUMBER",
+	"STRING",
+	"NEWLINE",
+	"INDENT",
+	"DEDENT",
+	"LPAR",
+	"RPAR",
+	"LSQB",
+	"RSQB",
+	"COLON",
+	"COMMA",
+	"SEMI",
+	"PLUS",
+	"MINUS",
+	"STAR",
+	"SLASH",
+	"VBAR",
+	"AMPER",
+	"LESS",
+	"GREATER",
+	"EQUAL",
+	"DOT",
+	"PERCENT",
+	"BACKQUOTE",
+	"LBRACE",
+	"RBRACE",
+	"OP",
+	"<ERRORTOKEN>",
+	"<N_TOKENS>"
+};
+
+
+/* Create and initialize a new tok_state structure */
+
+static struct tok_state *
+tok_new()
+{
+	struct tok_state *tok = NEW(struct tok_state, 1);
+	if (tok == NULL)
+		return NULL;
+	tok->buf = tok->cur = tok->end = tok->inp = NULL;
+	tok->done = E_OK;
+	tok->fp = NULL;
+	tok->tabsize = TABSIZE;
+	tok->indent = 0;
+	tok->indstack[0] = 0;
+	tok->atbol = 1;
+	tok->pendin = 0;
+	tok->prompt = tok->nextprompt = NULL;
+	tok->lineno = 0;
+	return tok;
+}
+
+
+/* Set up tokenizer for string */
+
+struct tok_state *
+tok_setups(str)
+	char *str;
+{
+	struct tok_state *tok = tok_new();
+	if (tok == NULL)
+		return NULL;
+	tok->buf = tok->cur = str;
+	tok->end = tok->inp = strchr(str, '\0');
+	return tok;
+}
+
+
+/* Set up tokenizer for string */
+
+struct tok_state *
+tok_setupf(fp, ps1, ps2)
+	FILE *fp;
+	char *ps1, *ps2;
+{
+	struct tok_state *tok = tok_new();
+	if (tok == NULL)
+		return NULL;
+	if ((tok->buf = NEW(char, BUFSIZ)) == NULL) {
+		DEL(tok);
+		return NULL;
+	}
+	tok->cur = tok->inp = tok->buf;
+	tok->end = tok->buf + BUFSIZ;
+	tok->fp = fp;
+	tok->prompt = ps1;
+	tok->nextprompt = ps2;
+	return tok;
+}
+
+
+/* Free a tok_state structure */
+
+void
+tok_free(tok)
+	struct tok_state *tok;
+{
+	/* XXX really need a separate flag to say 'my buffer' */
+	if (tok->fp != NULL && tok->buf != NULL)
+		DEL(tok->buf);
+	DEL(tok);
+}
+
+
+/* Get next char, updating state; error code goes into tok->done */
+
+static int
+tok_nextc(tok)
+	register struct tok_state *tok;
+{
+	if (tok->done != E_OK)
+		return EOF;
+	
+	for (;;) {
+		if (tok->cur < tok->inp)
+			return *tok->cur++;
+		if (tok->fp == NULL) {
+			tok->done = E_EOF;
+			return EOF;
+		}
+		if (tok->inp > tok->buf && tok->inp[-1] == '\n')
+			tok->inp = tok->buf;
+		if (tok->inp == tok->end) {
+			int n = tok->end - tok->buf;
+			char *new = tok->buf;
+			RESIZE(new, char, n+n);
+			if (new == NULL) {
+				fprintf(stderr, "tokenizer out of mem\n");
+				tok->done = E_NOMEM;
+				return EOF;
+			}
+			tok->buf = new;
+			tok->inp = tok->buf + n;
+			tok->end = tok->inp + n;
+		}
+#ifdef USE_READLINE
+		if (tok->prompt != NULL) {
+			extern char *readline PROTO((char *prompt));
+			static int been_here;
+			if (!been_here) {
+				/* Force rebind of TAB to insert-tab */
+				extern int rl_insert();
+				rl_bind_key('\t', rl_insert);
+				been_here++;
+			}
+			if (tok->buf != NULL)
+				free(tok->buf);
+			tok->buf = readline(tok->prompt);
+			(void) intrcheck(); /* Clear pending interrupt */
+			if (tok->nextprompt != NULL)
+				tok->prompt = tok->nextprompt;
+				/* XXX different semantics w/o readline()! */
+			if (tok->buf == NULL) {
+				tok->done = E_EOF;
+			}
+			else {
+				unsigned int n = strlen(tok->buf);
+				if (n > 0)
+					add_history(tok->buf);
+				/* Append the '\n' that readline()
+				   doesn't give us, for the tokenizer... */
+				tok->buf = realloc(tok->buf, n+2);
+				if (tok->buf == NULL)
+					tok->done = E_NOMEM;
+				else {
+					tok->end = tok->buf + n;
+					*tok->end++ = '\n';
+					*tok->end = '\0';
+					tok->inp = tok->end;
+					tok->cur = tok->buf;
+				}
+			}
+		}
+		else
+#endif
+		{
+			tok->cur = tok->inp;
+			if (tok->prompt != NULL && tok->inp == tok->buf) {
+				fprintf(stderr, "%s", tok->prompt);
+				tok->prompt = tok->nextprompt;
+			}
+			tok->done = fgets_intr(tok->inp,
+				(int)(tok->end - tok->inp), tok->fp);
+		}
+		if (tok->done != E_OK) {
+			if (tok->prompt != NULL)
+				fprintf(stderr, "\n");
+			return EOF;
+		}
+		tok->inp = strchr(tok->inp, '\0');
+	}
+}
+
+
+/* Back-up one character */
+
+static void
+tok_backup(tok, c)
+	register struct tok_state *tok;
+	register int c;
+{
+	if (c != EOF) {
+		if (--tok->cur < tok->buf) {
+			fprintf(stderr, "tok_backup: begin of buffer\n");
+			abort();
+		}
+		if (*tok->cur != c)
+			*tok->cur = c;
+	}
+}
+
+
+/* Return the token corresponding to a single character */
+
+int
+tok_1char(c)
+	int c;
+{
+	switch (c) {
+	case '(':	return LPAR;
+	case ')':	return RPAR;
+	case '[':	return LSQB;
+	case ']':	return RSQB;
+	case ':':	return COLON;
+	case ',':	return COMMA;
+	case ';':	return SEMI;
+	case '+':	return PLUS;
+	case '-':	return MINUS;
+	case '*':	return STAR;
+	case '/':	return SLASH;
+	case '|':	return VBAR;
+	case '&':	return AMPER;
+	case '<':	return LESS;
+	case '>':	return GREATER;
+	case '=':	return EQUAL;
+	case '.':	return DOT;
+	case '%':	return PERCENT;
+	case '`':	return BACKQUOTE;
+	case '{':	return LBRACE;
+	case '}':	return RBRACE;
+	default:	return OP;
+	}
+}
+
+
+/* Get next token, after space stripping etc. */
+
+int
+tok_get(tok, p_start, p_end)
+	register struct tok_state *tok; /* In/out: tokenizer state */
+	char **p_start, **p_end; /* Out: point to start/end of token */
+{
+	register int c;
+	
+	/* Get indentation level */
+	if (tok->atbol) {
+		register int col = 0;
+		tok->atbol = 0;
+		tok->lineno++;
+		for (;;) {
+			c = tok_nextc(tok);
+			if (c == ' ')
+				col++;
+			else if (c == '\t')
+				col = (col/tok->tabsize + 1) * tok->tabsize;
+			else
+				break;
+		}
+		tok_backup(tok, c);
+		if (col == tok->indstack[tok->indent]) {
+			/* No change */
+		}
+		else if (col > tok->indstack[tok->indent]) {
+			/* Indent -- always one */
+			if (tok->indent+1 >= MAXINDENT) {
+				fprintf(stderr, "excessive indent\n");
+				tok->done = E_TOKEN;
+				return ERRORTOKEN;
+			}
+			tok->pendin++;
+			tok->indstack[++tok->indent] = col;
+		}
+		else /* col < tok->indstack[tok->indent] */ {
+			/* Dedent -- any number, must be consistent */
+			while (tok->indent > 0 &&
+				col < tok->indstack[tok->indent]) {
+				tok->indent--;
+				tok->pendin--;
+			}
+			if (col != tok->indstack[tok->indent]) {
+				fprintf(stderr, "inconsistent dedent\n");
+				tok->done = E_TOKEN;
+				return ERRORTOKEN;
+			}
+		}
+	}
+	
+	*p_start = *p_end = tok->cur;
+	
+	/* Return pending indents/dedents */
+	if (tok->pendin != 0) {
+		if (tok->pendin < 0) {
+			tok->pendin++;
+			return DEDENT;
+		}
+		else {
+			tok->pendin--;
+			return INDENT;
+		}
+	}
+	
+ again:
+	/* Skip spaces */
+	do {
+		c = tok_nextc(tok);
+	} while (c == ' ' || c == '\t');
+	
+	/* Set start of current token */
+	*p_start = tok->cur - 1;
+	
+	/* Skip comment */
+	if (c == '#') {
+		/* Hack to allow overriding the tabsize in the file.
+		   This is also recognized by vi, when it occurs near the
+		   beginning or end of the file.  (Will vi never die...?) */
+		int x;
+		if (sscanf(tok->cur, " vi:set tabsize=%d:", &x) == 1 &&
+						x >= 1 && x <= 40) {
+			fprintf(stderr, "# vi:set tabsize=%d:\n", x);
+			tok->tabsize = x;
+		}
+		do {
+			c = tok_nextc(tok);
+		} while (c != EOF && c != '\n');
+	}
+	
+	/* Check for EOF and errors now */
+	if (c == EOF)
+		return tok->done == E_EOF ? ENDMARKER : ERRORTOKEN;
+	
+	/* Identifier (most frequent token!) */
+	if (isalpha(c) || c == '_') {
+		do {
+			c = tok_nextc(tok);
+		} while (isalnum(c) || c == '_');
+		tok_backup(tok, c);
+		*p_end = tok->cur;
+		return NAME;
+	}
+	
+	/* Newline */
+	if (c == '\n') {
+		tok->atbol = 1;
+		*p_end = tok->cur - 1; /* Leave '\n' out of the string */
+		return NEWLINE;
+	}
+	
+	/* Number */
+	if (isdigit(c)) {
+		if (c == '0') {
+			/* Hex or octal */
+			c = tok_nextc(tok);
+			if (c == '.')
+				goto fraction;
+			if (c == 'x' || c == 'X') {
+				/* Hex */
+				do {
+					c = tok_nextc(tok);
+				} while (isxdigit(c));
+			}
+			else {
+				/* Octal; c is first char of it */
+				/* There's no 'isoctdigit' macro, sigh */
+				while ('0' <= c && c < '8') {
+					c = tok_nextc(tok);
+				}
+			}
+		}
+		else {
+			/* Decimal */
+			do {
+				c = tok_nextc(tok);
+			} while (isdigit(c));
+			/* Accept floating point numbers.
+			   XXX This accepts incomplete things like 12e or 1e+;
+			       worry about that at run-time.
+			   XXX Doesn't accept numbers starting with a dot */
+			if (c == '.') {
+	fraction:
+				/* Fraction */
+				do {
+					c = tok_nextc(tok);
+				} while (isdigit(c));
+			}
+			if (c == 'e' || c == 'E') {
+				/* Exponent part */
+				c = tok_nextc(tok);
+				if (c == '+' || c == '-')
+					c = tok_nextc(tok);
+				while (isdigit(c)) {
+					c = tok_nextc(tok);
+				}
+			}
+		}
+		tok_backup(tok, c);
+		*p_end = tok->cur;
+		return NUMBER;
+	}
+	
+	/* String */
+	if (c == '\'') {
+		for (;;) {
+			c = tok_nextc(tok);
+			if (c == '\n' || c == EOF) {
+				tok->done = E_TOKEN;
+				return ERRORTOKEN;
+			}
+			if (c == '\\') {
+				c = tok_nextc(tok);
+				*p_end = tok->cur;
+				if (c == '\n' || c == EOF) {
+					tok->done = E_TOKEN;
+					return ERRORTOKEN;
+				}
+				continue;
+			}
+			if (c == '\'')
+				break;
+		}
+		*p_end = tok->cur;
+		return STRING;
+	}
+	
+	/* Line continuation */
+	if (c == '\\') {
+		c = tok_nextc(tok);
+		if (c != '\n') {
+			tok->done = E_TOKEN;
+			return ERRORTOKEN;
+		}
+		goto again; /* Read next line */
+	}
+	
+	/* Punctuation character */
+	*p_end = tok->cur;
+	return tok_1char(c);
+}
+
+
+#ifdef DEBUG
+
+void
+tok_dump(type, start, end)
+	int type;
+	char *start, *end;
+{
+	printf("%s", tok_name[type]);
+	if (type == NAME || type == NUMBER || type == STRING || type == OP)
+		printf("(%.*s)", (int)(end - start), start);
+}
+
+#endif

Parser/tokenizer.h

@@ -0,0 +1,29 @@
+/* Tokenizer interface */
+
+#include "token.h"	/* For token types */
+
+#define MAXINDENT 100	/* Max indentation level */
+
+/* Tokenizer state */
+struct tok_state {
+	/* Input state; buf <= cur <= inp <= end */
+	/* NB an entire token must fit in the buffer */
+	char *buf;	/* Input buffer */
+	char *cur;	/* Next character in buffer */
+	char *inp;	/* End of data in buffer */
+	char *end;	/* End of input buffer */
+	int done;	/* 0 normally, 1 at EOF, -1 after error */
+	FILE *fp;	/* Rest of input; NULL if tokenizing a string */
+	int tabsize;	/* Tab spacing */
+	int indent;	/* Current indentation index */
+	int indstack[MAXINDENT];	/* Stack of indents */
+	int atbol;	/* Nonzero if at begin of new line */
+	int pendin;	/* Pending indents (if > 0) or dedents (if < 0) */
+	char *prompt, *nextprompt;	/* For interactive prompting */
+	int lineno;	/* Current line number */
+};
+
+extern struct tok_state *tok_setups PROTO((char *));
+extern struct tok_state *tok_setupf PROTO((FILE *, char *ps1, char *ps2));
+extern void tok_free PROTO((struct tok_state *));
+extern int tok_get PROTO((struct tok_state *, char **, char **));

Python/cgensupport.c

@@ -0,0 +1,369 @@
+/* Functions used by cgen output */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "intobject.h"
+#include "floatobject.h"
+#include "stringobject.h"
+#include "tupleobject.h"
+#include "listobject.h"
+#include "methodobject.h"
+#include "moduleobject.h"
+#include "modsupport.h"
+#include "import.h"
+#include "cgensupport.h"
+#include "errors.h"
+
+
+/* Functions to construct return values */
+
+object *
+mknewcharobject(c)
+	int c;
+{
+	char ch[1];
+	ch[0] = c;
+	return newsizedstringobject(ch, 1);
+}
+
+/* Functions to extract arguments.
+   These needs to know the total number of arguments supplied,
+   since the argument list is a tuple only of there is more than
+   one argument. */
+
+int
+getiobjectarg(args, nargs, i, p_arg)
+	register object *args;
+	int nargs, i;
+	object **p_arg;
+{
+	if (nargs != 1) {
+		if (args == NULL || !is_tupleobject(args) ||
+				nargs != gettuplesize(args) ||
+				i < 0 || i >= nargs) {
+			return err_badarg();
+		}
+		else {
+			args = gettupleitem(args, i);
+		}
+	}
+	if (args == NULL) {
+		return err_badarg();
+	}
+	*p_arg = args;
+	return 1;
+}
+
+int
+getilongarg(args, nargs, i, p_arg)
+	register object *args;
+	int nargs, i;
+	long *p_arg;
+{
+	if (nargs != 1) {
+		if (args == NULL || !is_tupleobject(args) ||
+				nargs != gettuplesize(args) ||
+				i < 0 || i >= nargs) {
+			return err_badarg();
+		}
+		args = gettupleitem(args, i);
+	}
+	if (args == NULL || !is_intobject(args)) {
+		return err_badarg();
+	}
+	*p_arg = getintvalue(args);
+	return 1;
+}
+
+int
+getishortarg(args, nargs, i, p_arg)
+	register object *args;
+	int nargs, i;
+	short *p_arg;
+{
+	long x;
+	if (!getilongarg(args, nargs, i, &x))
+		return 0;
+	*p_arg = x;
+	return 1;
+}
+
+static int
+extractdouble(v, p_arg)
+	register object *v;
+	double *p_arg;
+{
+	if (v == NULL) {
+		/* Fall through to error return at end of function */
+	}
+	else if (is_floatobject(v)) {
+		*p_arg = GETFLOATVALUE((floatobject *)v);
+		return 1;
+	}
+	else if (is_intobject(v)) {
+		*p_arg = GETINTVALUE((intobject *)v);
+		return 1;
+	}
+	return err_badarg();
+}
+
+static int
+extractfloat(v, p_arg)
+	register object *v;
+	float *p_arg;
+{
+	if (v == NULL) {
+		/* Fall through to error return at end of function */
+	}
+	else if (is_floatobject(v)) {
+		*p_arg = GETFLOATVALUE((floatobject *)v);
+		return 1;
+	}
+	else if (is_intobject(v)) {
+		*p_arg = GETINTVALUE((intobject *)v);
+		return 1;
+	}
+	return err_badarg();
+}
+
+int
+getifloatarg(args, nargs, i, p_arg)
+	register object *args;
+	int nargs, i;
+	float *p_arg;
+{
+	object *v;
+	float x;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (!extractfloat(v, &x))
+		return 0;
+	*p_arg = x;
+	return 1;
+}
+
+int
+getistringarg(args, nargs, i, p_arg)
+	object *args;
+	int nargs, i;
+	string *p_arg;
+{
+	object *v;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return NULL;
+	if (!is_stringobject(v)) {
+		return err_badarg();
+	}
+	*p_arg = getstringvalue(v);
+	return 1;
+}
+
+int
+getichararg(args, nargs, i, p_arg)
+	object *args;
+	int nargs, i;
+	char *p_arg;
+{
+	string x;
+	if (!getistringarg(args, nargs, i, &x))
+		return 0;
+	if (x[0] == '\0' || x[1] != '\0') {
+		/* Not exactly one char */
+		return err_badarg();
+	}
+	*p_arg = x[0];
+	return 1;
+}
+
+int
+getilongarraysize(args, nargs, i, p_arg)
+	object *args;
+	int nargs, i;
+	long *p_arg;
+{
+	object *v;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		*p_arg = gettuplesize(v);
+		return 1;
+	}
+	if (is_listobject(v)) {
+		*p_arg = getlistsize(v);
+		return 1;
+	}
+	return err_badarg();
+}
+
+int
+getishortarraysize(args, nargs, i, p_arg)
+	object *args;
+	int nargs, i;
+	short *p_arg;
+{
+	long x;
+	if (!getilongarraysize(args, nargs, i, &x))
+		return 0;
+	*p_arg = x;
+	return 1;
+}
+
+/* XXX The following four are too similar.  Should share more code. */
+
+int
+getilongarray(args, nargs, i, n, p_arg)
+	object *args;
+	int nargs, i;
+	int n;
+	long *p_arg; /* [n] */
+{
+	object *v, *w;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		if (gettuplesize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = gettupleitem(v, i);
+			if (!is_intobject(w)) {
+				return err_badarg();
+			}
+			p_arg[i] = getintvalue(w);
+		}
+		return 1;
+	}
+	else if (is_listobject(v)) {
+		if (getlistsize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = getlistitem(v, i);
+			if (!is_intobject(w)) {
+				return err_badarg();
+			}
+			p_arg[i] = getintvalue(w);
+		}
+		return 1;
+	}
+	else {
+		return err_badarg();
+	}
+}
+
+int
+getishortarray(args, nargs, i, n, p_arg)
+	object *args;
+	int nargs, i;
+	int n;
+	short *p_arg; /* [n] */
+{
+	object *v, *w;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		if (gettuplesize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = gettupleitem(v, i);
+			if (!is_intobject(w)) {
+				return err_badarg();
+			}
+			p_arg[i] = getintvalue(w);
+		}
+		return 1;
+	}
+	else if (is_listobject(v)) {
+		if (getlistsize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = getlistitem(v, i);
+			if (!is_intobject(w)) {
+				return err_badarg();
+			}
+			p_arg[i] = getintvalue(w);
+		}
+		return 1;
+	}
+	else {
+		return err_badarg();
+	}
+}
+
+int
+getidoublearray(args, nargs, i, n, p_arg)
+	object *args;
+	int nargs, i;
+	int n;
+	double *p_arg; /* [n] */
+{
+	object *v, *w;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		if (gettuplesize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = gettupleitem(v, i);
+			if (!extractdouble(w, &p_arg[i]))
+				return 0;
+		}
+		return 1;
+	}
+	else if (is_listobject(v)) {
+		if (getlistsize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = getlistitem(v, i);
+			if (!extractdouble(w, &p_arg[i]))
+				return 0;
+		}
+		return 1;
+	}
+	else {
+		return err_badarg();
+	}
+}
+
+int
+getifloatarray(args, nargs, i, n, p_arg)
+	object *args;
+	int nargs, i;
+	int n;
+	float *p_arg; /* [n] */
+{
+	object *v, *w;
+	if (!getiobjectarg(args, nargs, i, &v))
+		return 0;
+	if (is_tupleobject(v)) {
+		if (gettuplesize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = gettupleitem(v, i);
+			if (!extractfloat(w, &p_arg[i]))
+				return 0;
+		}
+		return 1;
+	}
+	else if (is_listobject(v)) {
+		if (getlistsize(v) != n) {
+			return err_badarg();
+		}
+		for (i = 0; i < n; i++) {
+			w = getlistitem(v, i);
+			if (!extractfloat(w, &p_arg[i]))
+				return 0;
+		}
+		return 1;
+	}
+	else {
+		return err_badarg();
+	}
+}

Python/errors.c

@@ -0,0 +1,111 @@
+/* Error handling -- see also run.c */
+
+/* New error handling interface.
+
+   The following problem exists (existed): methods of built-in modules
+   are called with 'self' and 'args' arguments, but without a context
+   argument, so they have no way to raise a specific exception.
+   The same is true for the object implementations: no context argument.
+   The old convention was to set 'errno' and to return NULL.
+   The caller (usually call_function() in eval.c) detects the NULL
+   return value and then calls puterrno(ctx) to turn the errno value
+   into a true exception.  Problems with this approach are:
+   - it used standard errno values to indicate Python-specific errors,
+     but this means that when such an error code is reported by UNIX the
+     user gets a confusing message
+   - errno is a global variable, which makes extensions to a multi-
+     threading environment difficult; e.g., in IRIX, multi-threaded
+     programs must use the function getoserror() (sp.?) instead of
+     looking in errno
+   - there is no portable way to add new error numbers for specic
+     situations -- the value space for errno is reserved to the OS, yet
+     the way to turn module-specific errors into a module-specific
+     exception requires module-specific values for errno
+   - there is no way to add a more situation-specific message to an
+     error.
+  
+  The new interface solves all these problems.  To return an error, a
+  built-in function calls err_set(exception), err_set(valexception,
+  value) or err_setstr(exception, string), and returns NULL.  These
+  functions save the value for later use by puterrno().  To adapt this
+  scheme to a multi-threaded environment, only the implementation of
+  err_setval() has to be changed.
+*/
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "stringobject.h"
+#include "errors.h"
+
+/* Last exception stored by err_setval() */
+
+static object *last_exception;
+static object *last_exc_val;
+
+void
+err_setval(exception, value)
+	object *exception;
+	object *value;
+{
+	if (last_exception != NULL)
+		DECREF(last_exception);
+	if (exception != NULL)
+		INCREF(exception);
+	last_exception = exception;
+	
+	if (last_exc_val != NULL)
+		DECREF(last_exc_val);
+	if (value != NULL)
+		INCREF(value);
+	last_exc_val = value;
+}
+
+void
+err_set(exception)
+	object *exception;
+{
+	err_setval(exception, (object *)NULL);
+}
+
+void
+err_setstr(exception, string)
+	object *exception;
+	char *string;
+{
+	object *value = newstringobject(string);
+	err_setval(exception, value);
+	if (value != NULL)
+		DECREF(value);
+}
+
+int
+err_occurred()
+{
+	return last_exception != NULL;
+}
+
+void
+err_get(p_exc, p_val)
+	object **p_exc;
+	object **p_val;
+{
+	*p_exc = last_exception;
+	last_exception = NULL;
+	*p_val = last_exc_val;
+	last_exc_val = NULL;
+}
+
+void
+err_clear()
+{
+	if (last_exception != NULL) {
+		DECREF(last_exception);
+		last_exception = NULL;
+	}
+	if (last_exc_val != NULL) {
+		DECREF(last_exc_val);
+		last_exc_val = NULL;
+	}
+}

Python/fmod.c

@@ -0,0 +1,27 @@
+/* Portable fmod(x, y) implementation for systems that don't have it */
+
+#include <math.h>
+#include <errno.h>
+
+extern int errno;
+
+double
+fmod(x, y)
+	double x, y;
+{
+	double i, f;
+	
+	if (y == 0.0) {
+		errno = EDOM;
+		return 0.0;
+	}
+	
+	/* return f such that x = i*y + f for some integer i
+	   such that |f| < |y| and f has the same sign as x */
+	
+	i = floor(x/y);
+	f = x - i*y;
+	if ((x < 0.0) != (y < 0.0))
+		f = f-y;
+	return f;
+}

Python/import.c

@@ -0,0 +1,252 @@
+/* Module definition and import implementation */
+
+#include <stdio.h>
+#include "string.h"
+
+#include "PROTO.h"
+#include "object.h"
+#include "stringobject.h"
+#include "listobject.h"
+#include "dictobject.h"
+#include "moduleobject.h"
+#include "node.h"
+#include "context.h"
+#include "token.h"
+#include "graminit.h"
+#include "run.h"
+#include "support.h"
+#include "import.h"
+#include "errcode.h"
+#include "sysmodule.h"
+
+/* Define pathname separator and delimiter in $PYTHONPATH */
+
+#ifdef THINK_C
+#define SEP ':'
+#define DELIM ' '
+#endif
+
+#ifndef SEP
+#define SEP '/'
+#endif
+
+#ifndef DELIM
+#define DELIM ':'
+#endif
+
+void
+initimport()
+{
+	object *v;
+	if ((v = newdictobject()) == NULL)
+		fatal("no mem for module table");
+	if (sysset("modules", v) != 0)
+		fatal("can't assign sys.modules");
+}
+
+object *
+new_module(name)
+	char *name;
+{
+	object *m;
+	object *mtab;
+	mtab = sysget("modules");
+	if (mtab == NULL || !is_dictobject(mtab)) {
+		errno = EBADF;
+		return NULL;
+	}
+	m = newmoduleobject(name);
+	if (m == NULL)
+		return NULL;
+	if (dictinsert(mtab, name, m) != 0) {
+		DECREF(m);
+		return NULL;
+	}
+	return m;
+}
+
+void
+define_module(ctx, name)
+	context *ctx;
+	char *name;
+{
+	object *m, *d;
+	m = new_module(name);
+	if (m == NULL) {
+		puterrno(ctx);
+		return;
+	}
+	d = getmoduledict(m);
+	INCREF(d);
+	DECREF(ctx->ctx_locals);
+	ctx->ctx_locals = d;
+	INCREF(d);
+	DECREF(ctx->ctx_globals);
+	ctx->ctx_globals = d;
+	DECREF(m);
+}
+
+object *
+parsepath(path, delim)
+	char *path;
+	int delim;
+{
+	int i, n;
+	char *p;
+	object *v, *w;
+	
+	n = 1;
+	p = path;
+	while ((p = strchr(p, delim)) != NULL) {
+		n++;
+		p++;
+	}
+	v = newlistobject(n);
+	if (v == NULL)
+		return NULL;
+	for (i = 0; ; i++) {
+		p = strchr(path, delim);
+		if (p == NULL)
+			p = strchr(path, '\0'); /* End of string */
+		w = newsizedstringobject(path, (int) (p - path));
+		if (w == NULL) {
+			DECREF(v);
+			return NULL;
+		}
+		setlistitem(v, i, w);
+		if (*p == '\0')
+			break;
+		path = p+1;
+	}
+	return v;
+}
+
+void
+setpythonpath(path)
+	char *path;
+{
+	object *v;
+	if ((v = parsepath(path, DELIM)) != NULL) {
+		if (sysset("path", v) != 0)
+			fatal("can't assign sys.path");
+		DECREF(v);
+	}
+}
+
+static FILE *
+open_module(name, suffix)
+	char *name;
+	char *suffix;
+{
+	object *path;
+	char namebuf[256];
+	FILE *fp;
+	
+	path = sysget("path");
+	if (path == NULL || !is_listobject(path)) {
+		strcpy(namebuf, name);
+		strcat(namebuf, suffix);
+		fp = fopen(namebuf, "r");
+	}
+	else {
+		int npath = getlistsize(path);
+		int i;
+		fp = NULL;
+		for (i = 0; i < npath; i++) {
+			object *v = getlistitem(path, i);
+			int len;
+			if (!is_stringobject(v))
+				continue;
+			strcpy(namebuf, getstringvalue(v));
+			len = getstringsize(v);
+			if (len > 0 && namebuf[len-1] != SEP)
+				namebuf[len++] = SEP;
+			strcpy(namebuf+len, name); /* XXX check for overflow */
+			strcat(namebuf, suffix); /* XXX ditto */
+			fp = fopen(namebuf, "r");
+			if (fp != NULL)
+				break;
+		}
+	}
+	return fp;
+}
+
+static object *
+load_module(ctx, name)
+	context *ctx;
+	char *name;
+{
+	object *m;
+	char **p;
+	FILE *fp;
+	node *n, *mh;
+	int err;
+	object *mtab;
+	object *save_locals, *save_globals;
+	
+	mtab = sysget("modules");
+	if (mtab == NULL || !is_dictobject(mtab)) {
+		errno = EBADF;
+		return NULL;
+	}
+	fp = open_module(name, ".py");
+	if (fp == NULL) {
+		/* XXX Compatibility hack */
+		fprintf(stderr,
+			"Can't find '%s.py' in sys.path, trying '%s'\n",
+			name, name);
+		fp = open_module(name, "");
+	}
+	if (fp == NULL) {
+		name_error(ctx, name);
+		return NULL;
+	}
+#ifdef DEBUG
+	fprintf(stderr, "Reading module %s from file '%s'\n", name, namebuf);
+#endif
+	err = parseinput(fp, file_input, &n);
+	fclose(fp);
+	if (err != E_DONE) {
+		input_error(ctx, err);
+		return NULL;
+	}
+	save_locals = ctx->ctx_locals;
+	INCREF(save_locals);
+	save_globals = ctx->ctx_globals;
+	INCREF(save_globals);
+	define_module(ctx, name);
+	exec_node(ctx, n);
+	DECREF(ctx->ctx_locals);
+	ctx->ctx_locals = save_locals;
+	DECREF(ctx->ctx_globals);
+	ctx->ctx_globals = save_globals;
+	/* XXX need to free the tree n here; except referenced defs */
+	if (ctx->ctx_exception) {
+		dictremove(mtab, name); /* Undefine the module */
+		return NULL;
+	}
+	m = dictlookup(mtab, name);
+	if (m == NULL) {
+		error(ctx, "module not defined after loading");
+		return NULL;
+	}
+	return m;
+}
+
+object *
+import_module(ctx, name)
+	context *ctx;
+	char *name;
+{
+	object *m;
+	object *mtab;
+	mtab = sysget("modules");
+	if (mtab == NULL || !is_dictobject(mtab)) {
+		error(ctx, "bad sys.modules");
+		return NULL;
+	}
+	if ((m = dictlookup(mtab, name)) == NULL) {
+		m = load_module(ctx, name);
+	}
+	return m;
+}

Python/modsupport.c

@@ -0,0 +1,398 @@
+/* Module support implementation */
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "intobject.h"
+#include "stringobject.h"
+#include "tupleobject.h"
+#include "listobject.h"
+#include "methodobject.h"
+#include "moduleobject.h"
+#include "modsupport.h"
+#include "import.h"
+#include "errors.h"
+
+
+/* Find a method in a module's method table.
+   Usually called from a module's getattr method. */
+
+object *
+findmethod(ml, op, name)
+	struct methodlist *ml;
+	object *op;
+	char *name;
+{
+	for (; ml->ml_name != NULL; ml++) {
+		if (strcmp(name, ml->ml_name) == 0)
+			return newmethodobject(ml->ml_name, ml->ml_meth, op);
+	}
+	err_setstr(NameError, name);
+	return NULL;
+}
+
+
+object *
+initmodule(name, methods)
+	char *name;
+	struct methodlist *methods;
+{
+	object *m, *d, *v;
+	struct methodlist *ml;
+	if ((m = new_module(name)) == NULL) {
+		fprintf(stderr, "initializing module: %s\n", name);
+		fatal("can't create a module");
+	}
+	d = getmoduledict(m);
+	for (ml = methods; ml->ml_name != NULL; ml++) {
+		v = newmethodobject(ml->ml_name, ml->ml_meth, (object *)NULL);
+		if (v == NULL || dictinsert(d, ml->ml_name, v) != 0) {
+			fprintf(stderr, "initializing module: %s\n", name);
+			fatal("can't initialize module");
+		}
+		DECREF(v);
+	}
+	DECREF(m);
+	return m; /* Yes, it still exists, in sys.modules... */
+}
+
+
+/* Convenience functions to set a type error exception and return 0 */
+
+int
+err_badarg()
+{
+	err_setstr(TypeError, "illegal argument type for built-in function");
+	return 0;
+}
+
+object *
+err_nomem()
+{
+	err_setstr(MemoryError, "in built-in function");
+	return NULL;
+}
+
+/* Argument list handling tools.
+   All return 1 for success, or call err_set*() and return 0 for failure */
+
+int
+getnoarg(v)
+	object *v;
+{
+	if (v != NULL) {
+		return err_badarg();
+	}
+	return 1;
+}
+
+int
+getintarg(v, a)
+	object *v;
+	int *a;
+{
+	if (v == NULL || !is_intobject(v)) {
+		return err_badarg();
+	}
+	*a = getintvalue(v);
+	return 1;
+}
+
+int
+getintintarg(v, a, b)
+	object *v;
+	int *a;
+	int *b;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getintarg(gettupleitem(v, 0), a) &&
+		getintarg(gettupleitem(v, 1), b);
+}
+
+int
+getlongarg(v, a)
+	object *v;
+	long *a;
+{
+	if (v == NULL || !is_intobject(v)) {
+		return err_badarg();
+	}
+	*a = getintvalue(v);
+	return 1;
+}
+
+int
+getlonglongargs(v, a, b)
+	object *v;
+	long *a, *b;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getlongarg(gettupleitem(v, 0), a) &&
+		getlongarg(gettupleitem(v, 1), b);
+}
+
+int
+getlonglongobjectargs(v, a, b, c)
+	object *v;
+	long *a, *b;
+	object **c;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
+		return err_badarg();
+	}
+	if (getlongarg(gettupleitem(v, 0), a) &&
+		getlongarg(gettupleitem(v, 1), b)) {
+		*c = gettupleitem(v, 2);
+		return 1;
+	}
+	else {
+		return err_badarg();
+	}
+}
+
+int
+getstrarg(v, a)
+	object *v;
+	object **a;
+{
+	if (v == NULL || !is_stringobject(v)) {
+		return err_badarg();
+	}
+	*a = v;
+	return 1;
+}
+
+int
+getstrstrarg(v, a, b)
+	object *v;
+	object **a;
+	object **b;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getstrarg(gettupleitem(v, 0), a) &&
+		getstrarg(gettupleitem(v, 1), b);
+}
+
+int
+getstrstrintarg(v, a, b, c)
+	object *v;
+	object **a;
+	object **b;
+	int *c;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
+		return err_badarg();
+	}
+	return getstrarg(gettupleitem(v, 0), a) &&
+		getstrarg(gettupleitem(v, 1), b) &&
+		getintarg(gettupleitem(v, 2), c);
+}
+
+int
+getstrintarg(v, a, b)
+	object *v;
+	object **a;
+	int *b;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getstrarg(gettupleitem(v, 0), a) &&
+		getintarg(gettupleitem(v, 1), b);
+}
+
+int
+getintstrarg(v, a, b)
+	object *v;
+	int *a;
+	object **b;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getintarg(gettupleitem(v, 0), a) &&
+		getstrarg(gettupleitem(v, 1), b);
+}
+
+int
+getpointarg(v, a)
+	object *v;
+	int *a; /* [2] */
+{
+	return getintintarg(v, a, a+1);
+}
+
+int
+get3pointarg(v, a)
+	object *v;
+	int *a; /* [6] */
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
+		return err_badarg();
+	}
+	return getpointarg(gettupleitem(v, 0), a) &&
+		getpointarg(gettupleitem(v, 1), a+2) &&
+		getpointarg(gettupleitem(v, 2), a+4);
+}
+
+int
+getrectarg(v, a)
+	object *v;
+	int *a; /* [2+2] */
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getpointarg(gettupleitem(v, 0), a) &&
+		getpointarg(gettupleitem(v, 1), a+2);
+}
+
+int
+getrectintarg(v, a)
+	object *v;
+	int *a; /* [4+1] */
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getrectarg(gettupleitem(v, 0), a) &&
+		getintarg(gettupleitem(v, 1), a+4);
+}
+
+int
+getpointintarg(v, a)
+	object *v;
+	int *a; /* [2+1] */
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getpointarg(gettupleitem(v, 0), a) &&
+		getintarg(gettupleitem(v, 1), a+2);
+}
+
+int
+getpointstrarg(v, a, b)
+	object *v;
+	int *a; /* [2] */
+	object **b;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getpointarg(gettupleitem(v, 0), a) &&
+		getstrarg(gettupleitem(v, 1), b);
+}
+
+int
+getstrintintarg(v, a, b, c)
+	object *v;
+	object *a;
+	int *b, *c;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
+		return err_badarg();
+	}
+	return getstrarg(gettupleitem(v, 0), a) &&
+		getintarg(gettupleitem(v, 1), b) &&
+		getintarg(gettupleitem(v, 2), c);
+}
+
+int
+getrectpointarg(v, a)
+	object *v;
+	int *a; /* [4+2] */
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
+		return err_badarg();
+	}
+	return getrectarg(gettupleitem(v, 0), a) &&
+		getpointarg(gettupleitem(v, 1), a+4);
+}
+
+int
+getlongtuplearg(args, a, n)
+	object *args;
+	long *a; /* [n] */
+	int n;
+{
+	int i;
+	if (!is_tupleobject(args) || gettuplesize(args) != n) {
+		return err_badarg();
+	}
+	for (i = 0; i < n; i++) {
+		object *v = gettupleitem(args, i);
+		if (!is_intobject(v)) {
+			return err_badarg();
+		}
+		a[i] = getintvalue(v);
+	}
+	return 1;
+}
+
+int
+getshorttuplearg(args, a, n)
+	object *args;
+	short *a; /* [n] */
+	int n;
+{
+	int i;
+	if (!is_tupleobject(args) || gettuplesize(args) != n) {
+		return err_badarg();
+	}
+	for (i = 0; i < n; i++) {
+		object *v = gettupleitem(args, i);
+		if (!is_intobject(v)) {
+			return err_badarg();
+		}
+		a[i] = getintvalue(v);
+	}
+	return 1;
+}
+
+int
+getlonglistarg(args, a, n)
+	object *args;
+	long *a; /* [n] */
+	int n;
+{
+	int i;
+	if (!is_listobject(args) || getlistsize(args) != n) {
+		return err_badarg();
+	}
+	for (i = 0; i < n; i++) {
+		object *v = getlistitem(args, i);
+		if (!is_intobject(v)) {
+			return err_badarg();
+		}
+		a[i] = getintvalue(v);
+	}
+	return 1;
+}
+
+int
+getshortlistarg(args, a, n)
+	object *args;
+	short *a; /* [n] */
+	int n;
+{
+	int i;
+	if (!is_listobject(args) || getlistsize(args) != n) {
+		return err_badarg();
+	}
+	for (i = 0; i < n; i++) {
+		object *v = getlistitem(args, i);
+		if (!is_intobject(v)) {
+			return err_badarg();
+		}
+		a[i] = getintvalue(v);
+	}
+	return 1;
+}

Python/pythonmain.c

@@ -0,0 +1,297 @@
+/* Python interpreter main program */
+
+/* XXX This is still a mess */
+
+#ifdef THINK_C
+#define USE_STDWIN
+#endif
+
+#include <stdio.h>
+#include <ctype.h>
+#include "string.h"
+
+#ifdef USE_STDWIN
+#include "stdwin.h"
+int use_stdwin;
+#endif
+
+extern char *getenv();
+
+#include "PROTO.h"
+#include "grammar.h"
+#include "node.h"
+#include "parsetok.h"
+#include "graminit.h"
+#include "errcode.h"
+#include "object.h"
+#include "stringobject.h"
+#include "sysmodule.h"
+
+extern grammar gram; /* From graminit.c */
+
+#ifndef PYTHONPATH
+
+#ifdef THINK_C
+
+#define PYTHONPATH ": :mod"
+
+#else /* !THINK_C */
+
+#ifdef AMOEBA
+#define PYTHONPATH ".:/profile/module/python"
+#else /* !AMOEBA */
+#define PYTHONPATH ".:/usr/local/lib/python"
+#endif /* !AMOEBA */
+
+#endif /* !THINK_C */
+
+#endif /* !PYTHONPATH */
+
+int debugging;
+
+main(argc, argv)
+	int argc;
+	char **argv;
+{
+	char *path;
+	char *filename = NULL;
+	FILE *fp = stdin;
+	int ret;
+	
+#ifdef USE_STDWIN
+#ifdef THINK_C
+	wsetstdio(1);
+#else THINK_C
+	/* Must use "python -s" now to get stdwin support */
+	if (argc > 1 && strcmp(argv[1], "-s") == 0)
+		argv[1] = argv[0],
+		argc--, argv++,
+#endif /* !THINK_C */
+		use_stdwin = 1;
+	if (use_stdwin)
+		winitargs(&argc, &argv);
+#endif /* USE_STDWIN */
+	
+#ifdef THINK_C_not_today
+	printf("argc = %d, argv[0] = '%s'\n", argc, argv[0]);
+	if (argc <= 1)
+		askargs(&argc, &argv);
+#endif
+	
+	initintr(); /* For intrcheck() */
+	
+	if (argc > 1 && strcmp(argv[1], "-") != 0)
+		filename = argv[1];
+
+	if (filename != NULL) {
+		if ((fp = fopen(filename, "r")) == NULL) {
+			fprintf(stderr, "python: can't open file '%s'\n",
+				filename);
+			exit(2);
+		}
+	}
+	
+	/* XXX what is the ideal initialization order? */
+	
+	initsys(argc-1, argv+1);
+	inittime();
+	initmath();
+	
+#ifndef THINK_C
+	path = getenv("PYTHONPATH");
+	if (path == NULL)
+#endif
+		path = PYTHONPATH;
+	setpythonpath(path);
+	
+	initrun();
+	
+#ifdef USE_POSIX
+	initposix();
+#endif
+
+#ifdef THINK_C
+	initmac();
+#endif
+
+#ifdef USE_AUDIO
+	initaudio();
+#endif
+	
+#ifdef USE_AMOEBA
+	initamoeba();
+#endif
+	
+#ifdef USE_STDWIN
+	if (use_stdwin)
+		initstdwin();
+#endif
+	
+#ifdef USE_GL
+	initgl();
+#endif
+	
+#ifdef USE_PANEL
+	initpanel();
+#endif
+	
+	if (!isatty(fileno(fp))) {
+		ret = runfile(fp, file_input, (char *)NULL, (char *)NULL);
+	}
+	else {
+		sysset("ps1", newstringobject(">>> "));
+		sysset("ps2", newstringobject("... "));
+		for (;;) {
+			object *v = sysget("ps1"), *w = sysget("ps2");
+			char *ps1 = NULL, *ps2 = NULL;
+			if (v != NULL && is_stringobject(v)) {
+				INCREF(v);
+				ps1 = getstringvalue(v);
+			}
+			else
+				v = NULL;
+			if (w != NULL && is_stringobject(w)) {
+				INCREF(w);
+				ps2 = getstringvalue(w);
+			}
+			else
+				w = NULL;
+			ret = runfile(fp, single_input, ps1, ps2);
+			if (v != NULL)
+				DECREF(v);
+			if (w != NULL)
+				DECREF(w);
+			if (ret == E_EOF || ret == E_NOMEM)
+				break;
+		}
+	}
+	goaway(ret == E_DONE || ret == E_EOF ? 0 : 1);
+	/*NOTREACHED*/
+}
+
+goaway(sts)
+	int sts;
+{
+	closerun();
+#ifdef USE_STDWIN
+	if (use_stdwin)
+		wdone();
+#endif
+#ifdef THINK_C
+#ifndef TRACE_REFS
+	/* Avoid 'click mouse to continue' in Lightspeed C */
+	if (sts == 0)
+		Click_On(0);
+#endif
+#endif	
+	exit(sts);
+	/*NOTREACHED*/
+}
+
+/* Parse input from a file and execute it */
+
+static int
+runfile(fp, start, ps1, ps2)
+	FILE *fp;
+	int start;
+	char *ps1, *ps2;
+{
+	node *n;
+	int ret;
+	ret = parsefile(fp, &gram, start, ps1, ps2, &n);
+	if (ret != E_DONE)
+		return ret;
+	return execute(n) == 0 ? E_DONE : E_ERROR;
+}
+
+#ifdef THINK_C
+
+/* Ask a yes/no question */
+
+int
+askyesno(prompt)
+	char *prompt;
+{
+	char buf[256];
+	
+	printf("%s [ny] ", prompt);
+	if (fgets(buf, sizeof buf, stdin) == NULL)
+		return 0;
+	return buf[0] == 'y' || buf[0] == 'Y';
+}
+
+/* Check for file descriptor connected to interactive device.
+   Pretend that stdin is always interactive, other files never. */
+
+int
+isatty(fd)
+	int fd;
+{
+	return fd == fileno(stdin);
+}
+
+/* Kludge to get arguments on the Mac */
+
+#define MAXARGS 20
+
+static char *
+nextarg(pnext)
+	char **pnext;
+{
+	char *ret;
+	char *p = *pnext;
+	while (isspace(*p))
+		p++;
+	if (*p == '\0')
+		return NULL;
+	ret = p;
+	while (!isspace(*p))
+		p++;
+	if (*p != '\0')
+		*p++ = '\0';
+	*pnext = p;
+	return ret;
+}
+
+static
+askargs(pargc, pargv)
+	int *pargc;
+	char ***pargv; /* sic */
+{
+	static char buf[256];
+	static char *argv[MAXARGS];
+	int argc;
+	char *p, *next;
+	fprintf(stderr, "Args: ");
+	if (fgets(buf, sizeof buf, stdin) == NULL)
+		return;
+	next = buf;
+	if ((p = nextarg(&next)) == NULL)
+		return;
+	if (*pargc > 0)
+		argv[0] = (*pargv)[0];
+	else
+		argv[0] = "PYTHON";
+	argc = 1;
+	argv[argc++] = p;
+	while (argc+1 < MAXARGS && (p = nextarg(&next)) != NULL)
+		argv[argc++] = p;
+	argv[argc] = NULL;
+	*pargc = argc;
+	*pargv = argv;
+}
+
+#endif
+
+/*	WISH LIST
+
+	- improved per-module error handling; different use of errno
+	- possible new types:
+		- iterator (for range, keys, ...)
+	- improve interpreter error handling, e.g., true tracebacks
+	- release parse trees when no longer needed (make them objects?)
+	- faster parser (for long modules)
+	- save precompiled modules on file?
+	- fork threads, locking
+	- allow syntax extensions
+*/

Python/strerror.c

@@ -0,0 +1,18 @@
+/* PD implementation of strerror() for BSD derivatives that don't have it.
+   Author: Guido van Rossum, CWI Amsterdam, Oct. 1990, <guido@cwi.nl>. */
+
+#include <stdio.h>
+
+extern int sys_nerr;
+extern char *sys_errlist[];
+
+char *
+strerror(err)
+	int err;
+{
+	static char buf[20];
+	if (err >= 0 && err < sys_nerr)
+		return sys_errlist[err];
+	sprintf(buf, "Unknown errno %d", err);
+	return buf;
+}

Python/sysmodule.c

@@ -0,0 +1,156 @@
+/* System module */
+
+/*
+Various bits of information used by the interpreter are collected in
+module 'sys'.
+Data members:
+- stdin, stdout, stderr: standard file objects
+- ps1, ps2: primary and secondary prompts (strings)
+- path: module search path (list of strings)
+- modules: the table of modules (dictionary)
+Function members:
+- exit(sts): call exit()
+*/
+
+#include <stdio.h>
+
+#include "PROTO.h"
+#include "object.h"
+#include "stringobject.h"
+#include "listobject.h"
+#include "dictobject.h"
+#include "fileobject.h"
+#include "moduleobject.h"
+#include "sysmodule.h"
+#include "node.h" /* For context.h */
+#include "context.h" /* For import.h */
+#include "import.h"
+#include "methodobject.h"
+#include "modsupport.h"
+#include "errors.h"
+
+static object *sysdict;
+
+object *
+sysget(name)
+	char *name;
+{
+	return dictlookup(sysdict, name);
+}
+
+FILE *
+sysgetfile(name, def)
+	char *name;
+	FILE *def;
+{
+	FILE *fp = NULL;
+	object *v = sysget(name);
+	if (v != NULL)
+		fp = getfilefile(v);
+	if (fp == NULL)
+		fp = def;
+	return fp;
+}
+
+int
+sysset(name, v)
+	char *name;
+	object *v;
+{
+	if (v == NULL)
+		return dictremove(sysdict, name);
+	else
+		return dictinsert(sysdict, name, v);
+}
+
+static object *
+makeargv(argc, argv)
+	int argc;
+	char **argv;
+{
+	int i;
+	object *av, *v;
+	if (argc < 0 || argv == NULL)
+		argc = 0;
+	av = newlistobject(argc);
+	if (av != NULL) {
+		for (i = 0; i < argc; i++) {
+			v = newstringobject(argv[i]);
+			if (v == NULL) {
+				DECREF(av);
+				av = NULL;
+				break;
+			}
+			setlistitem(av, i, v);
+		}
+	}
+	if (av == NULL)
+		fatal("no mem for sys.argv");
+	return av;
+}
+
+/* sys.exit method */
+
+static object *
+sys_exit(self, args)
+	object *self;
+	object *args;
+{
+	int sts;
+	if (!getintarg(args, &sts))
+		return NULL;
+	goaway(sts);
+	exit(sts); /* Just in case */
+	/* NOTREACHED */
+}
+
+static object *sysin, *sysout, *syserr;
+
+void
+initsys(argc, argv)
+	int argc;
+	char **argv;
+{
+	object *v;
+	object *exit;
+	if ((sysdict = newdictobject()) == NULL)
+		fatal("can't create sys dict");
+	/* NB keep an extra ref to the std files to avoid closing them
+	   when the user deletes them */
+	sysin = newopenfileobject(stdin, "<stdin>", "r");
+	sysout = newopenfileobject(stdout, "<stdout>", "w");
+	syserr = newopenfileobject(stderr, "<stderr>", "w");
+	v = makeargv(argc, argv);
+	exit = newmethodobject("exit", sys_exit, (object *)NULL);
+	if (err_occurred())
+		fatal("can't create sys.* objects");
+	dictinsert(sysdict, "stdin", sysin);
+	dictinsert(sysdict, "stdout", sysout);
+	dictinsert(sysdict, "stderr", syserr);
+	dictinsert(sysdict, "argv", v);
+	dictinsert(sysdict, "exit", exit);
+	if (err_occurred())
+		fatal("can't insert sys.* objects in sys dict");
+	DECREF(v);
+	/* The other symbols are added elsewhere */
+	
+	/* Only now can we initialize the import stuff, after which
+	   we can turn ourselves into a module */
+	initimport();
+	if ((v = new_module("sys")) == NULL)
+		fatal("can't create sys module");
+	if (setmoduledict(v, sysdict) != 0)
+		fatal("can't assign sys dict to sys module");
+}
+
+void
+closesys()
+{
+	object *mtab;
+	mtab = sysget("modules");
+	if (mtab != NULL && is_dictobject(mtab))
+		dictremove(mtab, "sys"); /* Get rid of recursion */
+	else
+		fprintf(stderr, "[module sys not found]\n");
+	DECREF(sysdict);
+}