implement Regex; include "regex.m"; # syntax # RE	ALT		regular expression#	NUL# ALT	CAT		alternation# 	CAT | ALT## CAT	DUP		catenation# 	DUP CAT## DUP	PRIM		possibly duplicated primary# 	PCLO# 	CLO# 	OPT## PCLO	PRIM +		1 or more# CLO	PRIM *		0 or more# OPT	PRIM ?		0 or 1## PRIM	( RE )#	()# 	DOT		any character# 	CHAR		a single character#	ESC		escape sequence# 	[ SET ]		character set# 	NUL		null string# 	HAT		beginning of string# 	DOL		end of string# NIL : con -1;		# a refRex constantNONE: con -2;		# ditto, for an un-set valueBAD: con 1<<16;		# a non-character HUGE: con (1<<31) - 1; # the data structures of re.m would like to be ref-linked, but are# circular (see fn walk), thus instead of pointers we use indexes# into an array (arena) of nodes of the syntax tree of a regular expression.# from a storage-allocation standpoint, this replaces many small# allocations of one size with one big one of variable size. ReStr: adt {	s : string;	i : int;	# cursor postion	n : int;	# number of chars left; -1 on error	peek : fn(s: self ref ReStr): int;	next : fn(s: self ref ReStr): int;}; ReStr.peek(s: self ref ReStr): int{	if(s.n <= 0)		return BAD;	return s.s[s.i];} ReStr.next(s: self ref ReStr): int{	if(s.n <= 0)		return BAD;	s.n--;	return s.s[s.i++];} newRe(kind: int, left, right: refRex, set: ref Set, ar: ref Arena, pno: int): refRex{	ar.rex[ar.ptr] = Rex(kind, left, right, set, pno);	return ar.ptr++;} # parse a regex by recursive descent to get a syntax tree re(s: ref ReStr, ar: ref Arena): refRex{	left := cat(s, ar);	if(left==NIL || s.peek()!='|')		return left;	s.next();	right := re(s, ar);	if(right == NIL)		return NIL;	return newRe(ALT, left, right, nil, ar, 0);} cat(s: ref ReStr, ar: ref Arena): refRex{	left := dup(s, ar);	if(left == NIL)		return left;	right := cat(s, ar);	if(right == NIL)		return left;	return newRe(CAT, left, right, nil, ar, 0);} dup(s: ref ReStr, ar: ref Arena): refRex{	case s.peek() {	BAD or ')' or ']' or '|' or '?' or '*' or '+' =>		return NIL;	}	prim: refRex;	case kind:=s.next() {	'(' =>	if(ar.pno < 0) {			if(s.peek() == ')') {				s.next();				prim = newRe(NUL, NONE, NONE, nil, ar, 0);			} else {				prim = re(s, ar);				if(prim==NIL || s.next()!=')')					s.n = -1;			}		} else {			pno := ++ar.pno;			lp := newRe(LPN, NONE, NONE, nil, ar, pno);			rp := newRe(RPN, NONE, NONE, nil, ar, pno);			if(s.peek() == ')') {				s.next();				prim = newRe(CAT, lp, rp, nil, ar, 0);							} else {				prim = re(s, ar);				if(prim==NIL || s.next()!=')')					s.n = -1;				else {					prim = newRe(CAT, prim, rp, nil, ar, 0);					prim = newRe(CAT, lp, prim, nil, ar, 0);				}			}		}	'[' =>	prim = newRe(SET, NONE, NONE, newSet(s), ar, 0);	* =>	case kind {		'.' =>	kind = DOT;		'^' =>	kind = HAT;		'$' =>	kind = DOL;		}		prim = newRe(esc(s, kind), NONE, NONE, nil, ar, 0);	}	case s.peek() {	'*' =>	kind = CLO;	'+' =>	kind = PCLO;	'?' =>	kind = OPT;	* =>	return prim;	}	s.next();	return newRe(kind, prim, NONE, nil, ar, 0);} esc(s: ref ReStr, char: int): int{	if(char == '\\') {		char = s.next();		case char {		BAD =>	s.n = -1;		'n' =>	char = '\n';		}	}	return char;} # walk the tree adjusting pointers to refer to # next state of the finite state machine walk(r: refRex, succ: refRex, ar: ref Arena){	if(r==NONE)		return;	rex := ar.rex[r];	case rex.kind {	ALT =>	walk(rex.left, succ, ar);		walk(rex.right, succ, ar);		return;	CAT =>	walk(rex.left, rex.right, ar);		walk(rex.right, succ, ar);		ar.rex[r] = ar.rex[rex.left];	# optimization		return;	CLO or PCLO =>		end := newRe(OPT, r, succ, nil, ar, 0); # here's the circularity		walk(rex.left, end, ar);	OPT =>	walk(rex.left, succ, ar);	}	ar.rex[r].right = succ;} compile(e: string, flag: int): (Re, string){	if(e == nil)		return (nil, "missing expression");		s := ref ReStr(e, 0, len e);	ar := ref Arena(array[2*s.n] of Rex, 0, 0, (flag&1)-1);	start := ar.start = re(s, ar);	if(start==NIL || s.n!=0)		return (nil, "invalid regular expression");	walk(start, NIL, ar);	if(ar.pno < 0)		ar.pno = 0;	return (ar, nil);} # todo1, todo2: queues for epsilon and advancing transitionsGaz: adt {	pno: int;	beg: int;	end: int;};Trace: adt {	cre: refRex;		# cursor in Re	beg: int;		# where this trace began;	gaz: list of Gaz;};Queue: adt {	ptr: int;	q: array of Trace;}; execute(re: Re, s: string): array of (int, int){	return executese(re, s, (-1,-1), 1, 1);} executese(re: Re, s: string, range: (int, int), bol: int, eol: int): array of (int,int){	if(re==nil)		return nil;	(s0, s1) := range;	if(s0 < 0)		s0 = 0;	if(s1 < 0)		s1 = len s;	gaz : list of Gaz;	(beg, end) := (-1, -1);	todo1 := ref Queue(0, array[re.ptr] of Trace);	todo2 := ref Queue(0, array[re.ptr] of Trace);	for(i:=s0; i<=s1; i++) {		small2 := HUGE;		# earliest possible match if advance		if(beg == -1)		# no leftmost match yet			todo1.q[todo1.ptr++] = Trace(re.start, i, nil);		for(k:=0; k<todo1.ptr; k++) {			q := todo1.q[k];			rex := re.rex[q.cre];			next1 := next2 := NONE;			case rex.kind {			NUL =>				next1 = rex.right;			DOT =>				if(i<len s && s[i]!='\n')					next2 = rex.right;			HAT =>				if(i == s0 && bol)					next1 = rex.right;			DOL =>				if(i == s1 && eol)					next1 = rex.right;			SET =>				if(i<len s && member(s[i], rex.set))					next2 = rex.right;			CAT or			PCLO =>				next1 = rex.left;			ALT or 			CLO or 			OPT =>				next1 = rex.right;				k = insert(rex.left, q.beg, q.gaz, todo1, k);			LPN =>				next1 = rex.right;				q.gaz = Gaz(rex.pno,i,-1)::q.gaz;			RPN =>				next1 = rex.right;				for(r:=q.gaz; ; r=tl r) {					(pno,beg1,end1) := hd r;					if(rex.pno==pno && end1==-1) {						q.gaz = Gaz(pno,beg1,i)::q.gaz;						break;					}				}			* =>				if(i<len s && rex.kind==s[i])					next2 = rex.right;			}			if(next1 != NONE) {				if(next1 != NIL)					k =insert(next1, q.beg, q.gaz, todo1, k);				else if(better(q.beg, i, beg, end))					(gaz, beg, end) = (q.gaz, q.beg, i);			}			if(next2 != NONE) {				if(next2 != NIL) {					if(q.beg < small2)						small2 = q.beg;					insert(next2, q.beg, q.gaz, todo2, 0);				 } else if(better(q.beg, i+1, beg, end))					(gaz, beg, end) = (q.gaz, q.beg, i+1);			}					}		if(beg!=-1 && beg<small2)	# nothing better possible			break;		(todo1,todo2) = (todo2, todo1);		todo2.ptr = 0;	}	if(beg == -1)		return nil;	result := array[re.pno+1] of { 0 => (beg,end), * => (-1,-1) };	for( ; gaz!=nil; gaz=tl gaz) {		(pno, beg1, end1) := hd gaz;		(rbeg, nil) := result[pno];		if(rbeg==-1 && (beg1|end1)!=-1)			result[pno] = (beg1,end1);	}	return result;} better(newbeg, newend, oldbeg, oldend: int): int{	return oldbeg==-1 || newbeg<oldbeg ||	       newbeg==oldbeg && newend>oldend;} insert(next: refRex, tbeg: int, tgaz: list of Gaz, todo: ref Queue, k: int): int{	for(j:=0; j<todo.ptr; j++)		if(todo.q[j].cre == next)			if(todo.q[j].beg <= tbeg)			 	return k;			else				break;	if(j < k)		k--;	if(j < todo.ptr)		todo.ptr--;	for( ; j<todo.ptr; j++)		todo.q[j] = todo.q[j+1];	todo.q[todo.ptr++] = Trace(next, tbeg, tgaz);	return k;} ASCII : con 128;WORD : con 32; member(char: int, set: ref Set): int{	if(char < 128)		return ((set.ascii[char/WORD]>>char%WORD)&1)^set.neg;	for(l:=set.unicode; l!=nil; l=tl l) {		(beg, end) := hd l;		if(char>=beg && char<=end)			return !set.neg;	}	return set.neg;} newSet(s: ref ReStr): ref Set{	set := ref Set(0, array[ASCII/WORD] of {* => 0}, nil);	if(s.peek() == '^') {		set.neg = 1;		s.next();	}	while(s.n > 0) {		char1 := s.next();		if(char1 == ']')			return set;		char1 = esc(s, char1);		char2 := char1;		if(s.peek() == '-') {			s.next();			char2 = s.next();			if(char2 == ']')				break;			char2 = esc(s, char2);			if(char2 < char1)				break;		}		for( ; char1<=char2; char1++)			if(char1 < ASCII)				set.ascii[char1/WORD] |= 1<<char1%WORD;			else {				set.unicode = (char1,char2)::set.unicode;				break;			}	}	s.n = -1;	return nil;}