unit strtype;

interface

type	strec = object
		function isblank (c: char): Boolean;
		function isdigit (c: char): Boolean;
		function isletter (c: char): Boolean;
		function isname (c: char): Boolean;
		function hasat (i: integer; s1: string): Boolean;
		function posof (s1: string): integer;
		procedure replace (j, k: integer; s1: string);
		function hasprefix (s1: string): Boolean;
		function empty: Boolean;
		function str: string;
		procedure ini (s1: string);
	(* token functions: *)
		procedure resetposition;
		function nexttoken: string;
		function lasttoken: string;
		function firsttoken: string;
		function nthtoken (n: integer): string;
		function lookuptoken (s1: string): Boolean;
		function findtoken (s1: string): Boolean;
		procedure gotonexttoken;
		procedure replacelasttoken (s1: string);
	private
		s: string;
		len: integer;
		position: integer	(* current scan position *);
		startpos: integer	(* start of last retrieved token *);
		function cc: char;
	end;

implementation

function strec.isblank (c: char): Boolean;
begin	isblank := (c = ' ') or (c = '	')
end;

function strec.isdigit (c: char): Boolean;
begin	isdigit := (c >= '0') and (c <= '9')
end;

function strec.isletter (c: char): Boolean;
begin	isletter := ((c >= 'A') and (c <= 'Z')) or ((c >= 'a') and (c <= 'z'))
end;

function strec.isname (c: char): Boolean;
begin	(*
	isname := not isblank (c) and
		(c <> '(') and (c <> ')') and (c <> '<') and (c <> '>') and
		(c <> '[') and (c <> ']') and (c <> '{') and (c <> '}') and
		(c <> '/') and (c <> '%')
	*)
	isname := not (c in [' ', '	', '(', ')', '<', '>', '[', ']', '{', '}', '/', '%'])
end;

function strec.cc: char;
begin	if position > len
	then cc := ' '
	else cc := s [position]
end;

function strec.hasat (i: integer; s1: string): Boolean;
begin	hasat := pos (s1, s) = i end;

function strec.posof (s1: string): integer;
begin	posof := pos (s1, s) end;

procedure strec.replace (j, k: integer; s1: string);
begin	delete (s, j, k - j + 1);
	insert (s1, s, j)
end;

function strec.hasprefix (s1: string): Boolean;
begin	hasprefix := pos (s1, s) = 1 end;

function strec.empty: Boolean;
begin	empty := s = '' end;

function strec.str: string;
begin	str := s end;

procedure strec.ini (s1: string);
begin   s := s1; position := 0; len := length (s) end;

procedure strec.resetposition;
begin	position := 0 end;

function strec.nexttoken: string;
const specialchars = [' ', '	', '(', ')', '<', '>', '[', ']', '{', '}', '/', '%'];
var level: integer;
    quote: Boolean;
    nexttok: string;
begin
	if position = 0 then position := position + 1;
	while (position <= len) and isblank (s [position])
	do position := position + 1;
	startpos := position;
	if startpos > len
	then	nexttok := ''
	else begin
		if (cc = '/') or not (cc in specialchars)
		then begin	(* scan name or number *)
			if cc = '/'
			then begin
				position := position + 1;
				(* ignore the special cases /[ and /] *)
				if cc = '/' then position := position + 1;
			end;
			while not (cc in specialchars) do position := position + 1
		end else if cc = '='
		then begin	(* scan special symbol *)
			position := position + 1;
			if cc = '=' then position := position + 1
		end else if cc = '<'
		then begin	(* scan hex string *)
			while (position <= len) and (cc <> '>')
				do position := position + 1;
			if position <= len
			then position := position + 1
		end else if cc = '('
		then begin	(* scan string *)
			position := position + 1;
			level := 1;
			quote := false;
			while (position <= len) and (level > 0) do begin
				if not quote
				then	if cc = '\'
					then quote := true
					else begin
					     quote := false;
					     if cc = '('
					     then level := level + 1
					     else if cc = ')'
					     then level := level - 1
					end;
				position := position + 1
			end
		end else if cc = '%'
		then	(* scan comment *)
			position := len + 1
		else	(* scan one-character symbol *)
			position := position + 1;
		nexttok := copy (s, startpos, position - startpos)
	end;
	(* writeln ('nexttoken: ¯', nexttok, '®'); *)
	nexttoken := nexttok
end;

function strec.lasttoken: string;
begin	if startpos > len
	then	lasttoken := ''
	else	lasttoken := copy (s, startpos, position - startpos)
end;

function strec.firsttoken: string;
begin	position := 0;
	firsttoken := nexttoken
end;

function strec.nthtoken (n: integer): string;
var i: integer;
    r: string;
begin	position := 0;
	for i := 1 to n do r := nexttoken;
	nthtoken := r
end;

function strec.lookuptoken (s1: string): Boolean;
var t: string;
    r: Boolean;
begin	r := false;
	t := nexttoken;
	while t <> '' do
		if t = s1 then begin r := true; t := '' end
		else t := nexttoken;
	lookuptoken := r
end;

function strec.findtoken (s1: string): Boolean;
begin	position := 0;
	findtoken := lookuptoken (s1)
end;

procedure strec.gotonexttoken;
var t: string;
begin	t := nexttoken
end;

procedure strec.replacelasttoken (s1: string);
begin	replace (startpos, position - 1, s1)
end;

end.