alan@leadsv.UUCP (Alan Strassberg) (08/15/88)
Posting-number: Volume 4, Issue 23
Submitted-by: "Alan Strassberg" <alan@leadsv.UUCP>
Archive-name: tptc/Part2
[WARNING!!! This software is shareware and copyrighted. Those who do not
accept such programs should give this a miss. ++bsa]
#--------------------------------CUT HERE-------------------------------------
#! /bin/sh
#
# This is a shell archive. Save this into a file, edit it
# and delete all lines above this comment. Then give this
# file to sh by executing the command "sh file". The files
# will be extracted into the current directory owned by
# you with default permissions.
#
# The files contained herein are:
#
# -rw-r--r-- 1 allbery System 17450 Aug 14 16:46 tpcexpr.inc
# -rw-r--r-- 1 allbery System 4274 Aug 14 16:46 tpcmisc.inc
# -rw-r--r-- 1 allbery System 18755 Aug 14 16:46 tpcscan.inc
#
echo 'x - tpcexpr.inc'
if test -f tpcexpr.inc; then echo 'shar: not overwriting tpcexpr.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > tpcexpr.inc
X
X(*
X * TPTC - Turbo Pascal to C translator
X *
X * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
X *
X *)
X
X
X(*
X * expression parser
X *
X *)
Xfunction pterm: string; forward;
X
Xfunction iscall(var lv: string): boolean;
X {see if the given lvalue is a function call or not}
Xbegin
X iscall := lv[length(lv)] = ')';
Xend;
X
X
Xprocedure make_pointer(var expr: string);
X {convert the expression into a pointer constant, if possible}
Xvar
X sym: symptr;
Xbegin
X
X case(expr[1]) of
X '*':
X begin
X delete(expr,1,1);
X exit;
X end;
X
X 'a'..'z','A'..'Z','_':
X begin {pass pointer to strings/arrays}
X sym := locatesym(expr);
X if (sym <> nil) and ((sym^.symtype = s_string) or
X (sym^.suptype = ss_array)) then
X begin
X {null}
X end
X else
X
X if expr[length(expr)-1] = '(' then {remove () from function calls}
X dec(expr[0],2)
X
X else
X expr := '&' + expr;
X end;
X
X end;
X
Xend;
X
X
Xfunction isnumber(var lv: string): boolean;
X {see if the given value is a literal number}
Xvar
X i: integer;
Xbegin
X for i := 1 to length(lv) do
X case lv[i] of
X '0'..'9','.': ;
X else
X isnumber := false;
X exit;
X end;
X isnumber := true;
Xend;
X
X
Xprocedure subtract_base(var expr: string; base: integer);
X {subtract the specified base from the given expression;
X use constant folding if possible}
Xbegin
X if base <> 0 then
X if isnumber(expr) then
X expr := itoa(atoi(expr) - base)
X else
X if base > 0 then
X expr := expr + '-' + itoa(base)
X else
X expr := expr + '+' + itoa(-base);
Xend;
X
X
Xfunction exprtype: char;
X {determine expression type and return the printf code for the type}
Xvar
X xt: char;
X
Xbegin
X case cexprtype of
X s_char: xt := 'c';
X s_file: xt := '@';
X s_double: xt := 'f';
X s_string: xt := 's';
X s_bool: xt := 'b';
X s_int: xt := 'd';
X s_long: xt := 'D'; { calling routine should convert to "ld" }
X else xt := '?';
X end;
X
X exprtype := xt;
Xend;
X
X
Xfunction strtype(ty: char): boolean;
X {see if the expression is a string data type or not}
Xbegin
X case ty of
X 's','c': strtype := true;
X else strtype := false;
X end;
Xend;
X
X
X
Xfunction psetof: string;
X {parse a literal set; returns the set literal translated into
X the form: setof(.....)}
Xvar
X ex: string;
X
Xbegin
X ex := 'setof(';
X if tok[1] <> ']' then
X ex := ex + pterm;
X
X while (tok = '..') or (tok[1] = ',') do
X begin
X if tok = '..' then
X ex := ex + ',__,'
X else
X ex := ex + ',';
X
X gettok;
X ex := ex + pterm;
X end;
X
X if ex[length(ex)] <> '(' then
X ex := ex + ',';
X ex := ex + '_E)';
X psetof := ex;
Xend;
X
X
Xfunction pterm: string;
X {parse an expression term; returns the translated expression term;
X detects subexpressions, set literals and lvalues(variable names)}
Xvar
X ex: string;
X builtin: boolean;
X
Xbegin
X if debug_parse then write(' <term>');
X
X if (toktype = identifier) and (cursym <> nil) then
X builtin := cursym^.suptype = ss_builtin
X else
X builtin := false;
X
X (* process pos(c,str) and pos(str,str) *)
X if builtin and (tok = 'POS') then
X begin
X if debug_parse then write(' <pos>');
X gettok; {consume the keyword}
X if tok[1] <> '(' then
X syntax('"(" expected (pterm.pos)');
X
X gettok; {consume the (}
X ex := pexpr;
X if exprtype{(ex)} = 'c' then
X ex := 'cpos(' + ex
X else
X ex := 'spos(' + ex;
X
X gettok; {consume the ,}
X ex := ex + ',' + pexpr;
X gettok; {consume the )}
X pterm := ex + ')';
X cexprtype := s_int;
X end
X else
X
X (* process chr(n) *)
X if builtin and (tok = 'CHR') then
X begin
X if debug_parse then write(' <chr>');
X gettok; {consume the keyword}
X if tok[1] <> '(' then
X syntax('"(" expected (pterm.chr)');
X
X gettok; {consume the (}
X ex := pexpr;
X gettok; {consume the )}
X
X if isnumber(ex) then
X ex := numlit(atoi(ex))
X else
X ex := 'chr('+ex+')';
X
X pterm := ex;
X cexprtype := s_char;
X end
X else
X
X (* translate NOT term into !term *)
X if builtin and (tok = 'NOT') then
X begin
X if debug_parse then write(' <not>');
X gettok;
X pterm := '!' + pterm;
X cexprtype := s_bool;
X end
X else
X
X (* process port/memory array references *)
X if builtin and ((tok = 'PORT') or (tok = 'PORTW') or
X (tok = 'MEM') or (tok = 'MEMW')) then
X begin
X if debug_parse then write(' <port>');
X if tok = 'PORT' then ex := 'inportb(' else
X if tok = 'PORTW' then ex := 'inport(' else
X if tok = 'MEM' then ex := 'peekb(' else
X ex := 'peek(';
X
X gettok; {consume the keyword}
X gettok; {consume the [ }
X
X repeat
X ex := ex + pexpr;
X if tok[1] = ':' then
X begin
X gettok;
X ex := ex + ',';
X end;
X until (tok[1] = ']') or recovery;
X
X gettok; {consume the ] }
X pterm := ex + ')';
X cexprtype := s_int;
X end
X else
X
X (* translate bitwise not (mt+) *)
X if (tok[1] = '?') or (tok[1] = '~') or (tok[1] = '\') then
X begin
X if debug_parse then write(' <bitnot>');
X gettok;
X pterm := '!' + pterm; {what is a bitwise NOT in c?}
X end
X else
X
X (* process unary minus *)
X if tok = '-' then
X begin
X if debug_parse then write(' <unary>');
X gettok;
X pterm := '-' + pterm;
X end
X else
X
X (* translate address-of operator *)
X if tok[1] = '@' then
X begin
X if debug_parse then write(' <ref>');
X gettok; {consume the '@'}
X ex := plvalue;
X make_pointer(ex);
X pterm := ex;
X end
X else
X
X (* pass numbers *)
X if toktype = number then
X begin
X if debug_parse then write(' <number>');
X pterm := tok;
X gettok;
X cexprtype := s_int;
X end
X else
X
X (* pass strings *)
X if toktype = strng then
X begin
X if debug_parse then write(' <string>');
X pterm := tok;
X gettok;
X cexprtype := s_string;
X end
X else
X
X (* pass characters *)
X if toktype = chars then
X begin
X if debug_parse then write(' <char>');
X pterm := tok;
X gettok;
X cexprtype := s_char;
X end
X else
X
X (* pass sub expressions *)
X if tok[1] = '(' then
X begin
X if debug_parse then write(' <subexp>');
X gettok;
X pterm := '(' + pexpr + ')';
X gettok;
X end
X else
X
X (* translate literal sets *)
X if tok[1] = '[' then
X begin
X if debug_parse then write(' <setlit>');
X gettok;
X pterm := psetof;
X gettok;
X cexprtype := s_struct;
X end
X
X (* otherwise the term will be treated as an lvalue *)
X else
X pterm := plvalue;
Xend;
X
X
Xfunction pexpr: string;
X {top level expression parser; parse and translate an expression and
X return the translated expr}
Xvar
X ex: string;
X ty: char;
X ex2: string;
X ty2: char;
X
X procedure relop(newop: string40);
X begin
X if debug_parse then write(' <relop>');
X gettok; {consume the operator token}
X
X ex2 := pterm; {get the second term}
X ty2 := exprtype;
X
X {use strcmp if either param is a string}
X if ty = 's' then
X begin
X if ty2 = 's' then
X ex := 'strcmp(' + ex + ',' + ex2 + ') ' + newop + ' 0'
X else
X if ex2[1] = '''' then
X ex := 'strcmp(' + ex + ',"' +
X copy(ex2,2,length(ex2)-2) + '") ' + newop + ' 0'
X else
X ex := 'strcmp(' + ex + ',ctos(' + ex2 + ')) ' + newop + ' 0'
X end
X else
X
X if ty = 'c' then
X begin
X if ty2 = 's' then
X ex := 'strcmp(ctos(' + ex + '),' + ex2 + ') ' + newop + ' 0'
X else
X ex := ex + ' ' + newop + ' ' + ex2
X end
X
X else
X ex := ex + ' ' + newop + ' ' + ex2;
X cexprtype := s_bool;
X end;
X
X
X procedure addop;
X
X procedure add_scat;
X var
X p: integer;
X
X begin
X {find end of control string}
X p := 7; {position of 'scat("%'}
X while (ex[p] <> '"') or
X ((ex[p] = '"') and (ex[p-1] = '\') and (ex[p-2] <> '\')) do
X p := succ(p);
X p := succ(p);
X
X {add literals to the control string if possible}
X if (ex2[1] = '''') or (ex2[1] = '"') then
X ex := copy(ex,1,p-2) +
X copy(ex2,2,length(ex2)-2) +
X copy(ex,p-1,length(ex)-p+2)
X
X else {add a parameter to the control string}
X ex := copy(ex,1,p-2) + '%' + ty2 +
X copy(ex,p-1,length(ex)-p+1) + ',' + ex2 + ')';
X end;
X
X begin
X if debug_parse then write(' <addop>');
X gettok; {consume the operator token}
X
X ex2 := pterm; {get the second term}
X ty2 := exprtype;
X
X(* writeln('ex{',ex,'}',ty,' ex2{',ex2,'}',ty2); *)
X
X {continue adding string params to scat control string}
X if (ex[5] = '(') and (copy(ex,1,4) = 'scat') then
X add_scat
X else
X
X {start new scat call if any par is a string}
X if strtype(ty) or strtype(ty2) then
X begin
X if (ex[1] = '''') or (ex[1] = '"') then
X ex := 'scat("' + copy(ex,2,length(ex)-2) + '")'
X else
X ex := 'scat("%' + ty + '",' + ex + ')';
X add_scat;
X end
X else
X ex := ex + ' + ' + ex2;
X
X(* writeln('ex=',ex); *)
X end;
X
X procedure mulop(newop: string40);
X begin
X if debug_parse then write(' <mulop>');
X gettok; {consume the operator token}
X
X ex2 := pterm; {get the second term}
X ex := ex + ' ' + newop + ' ' + ex2;
X end;
X
X procedure andop(newop: char);
X begin
X if debug_parse then write(' <andop>');
X gettok; {consume the operator token}
X
X ex2 := pterm; {get the second term}
X ty2 := exprtype;
X
X {boolean and/or?}
X if (ty = 'b') or (ty2 = 'b') then
X begin
X ex := ex + ' ' + newop + newop + ' ' + ex2;
X cexprtype := s_bool;
X end
X else {otherwise bitwise}
X ex := ex + ' ' + newop + ' ' + ex2;
X end;
X
X
Xbegin
X if debug_parse then write(' <expr>');
X ex := pterm;
X ty := exprtype;
X
X while true do
X begin
X (* process operators *)
X if tok = '>=' then relop(tok)
X else if tok = '<=' then relop(tok)
X else if tok = '<>' then relop('!=')
X else if tok[1] = '>' then relop(tok)
X else if tok[1] = '<' then relop(tok)
X else if tok[1] = '=' then relop('==')
X else if tok[1] = '+' then addop
X else if tok[1] = '-' then mulop(tok)
X else if tok[1] = '*' then mulop(tok)
X else if tok[1] = '/' then mulop(tok)
X else if tok[1] = '&' then mulop(tok) {mt+}
X else if tok[1] = '!' then mulop('|') {mt+}
X else if tok[1] = '|' then mulop('|') {mt+}
X else if tok = 'DIV' then mulop('/')
X else if tok = 'MOD' then mulop('%')
X else if tok = 'SHR' then mulop('>>')
X else if tok = 'SHL' then mulop('<<')
X else if tok = 'XOR' then mulop('^')
X else if tok = 'AND' then andop('&')
X else if tok = 'OR' then andop('|')
X else
X
X (* translate the expr IN set operator *)
X if tok = 'IN' then
X begin
X gettok;
X ex := 'inset('+ex+',' + pterm + ')';
X end
X else
X
X (* ran out of legal expression operators; return what we found *)
X begin
X pexpr := ex;
X exit;
X end;
X end;
X
Xend;
X
X
Xfunction plvalue: string;
X {parse and translate an lvalue specification and return the translated
X lvalue as a string}
X
Xvar
X lv: string;
X expr: string;
X funcid: string40;
X pref: string40;
X idok: boolean;
X sym: symptr;
X func: symptr;
X btype: symtypes;
X cstype: supertypes;
X bstype: supertypes;
X pvars: integer;
X cbase: integer;
X bbase: integer;
X
Xbegin
X if debug_parse then write(' <lvalue>');
X plvalue := 'lvalue';
X
X(* lvalues must begin with an identifier in pascal *)
X if toktype <> identifier then
X begin
X syntax('Identifier expected (plvalue)');
X exit;
X end;
X
X(* assign initial part of the lvalue *)
X idok := false;
X pref := '';
X lv := ltok;
X funcid := tok;
X bstype := ss_scalar;
X bbase := 0;
X cbase := 0;
X
X sym := cursym;
X if sym <> nil then
X begin
X cstype := sym^.suptype;
X cbase := sym^.base;
X cexprtype := sym^.symtype;
X lv := sym^.repid; {use replacement identifier}
X
X {dereference VAR paremter pointers}
X if sym^.parcount = -2 then
X begin
X if debug_parse then write(' <var.deref>');
X pref := '*';
X end;
X
X {prefix with pointer if this is a member identifier and a with
X is in effect}
X if (sym^.parcount < 0) and (sym^.pvar > 0) and (withlevel > 0) then
X begin
X if debug_parse then write(' <with.deref>');
X pref := 'with'+itoa(withlevel)+'->';
X end;
X
X end;
X
X
X(* process a list of qualifiers and modifiers *)
X gettok;
X
X repeat
X if toktype = identifier then
X begin
X
X if cursym <> nil then {find record member types}
X begin
X sym := cursym;
X cstype := sym^.suptype;
X cbase := sym^.base;
X cexprtype := sym^.symtype;
X ltok := sym^.repid; {use replacement identifier}
X end;
X
X end;
X
X (* process identifiers (variable or field names) *)
X if idok and (toktype = identifier) then
X begin
X if debug_parse then write(' <ident>');
X lv := lv + ltok;
X gettok;
X idok := false;
X end
X else
X
X (* pointers *)
X if tok = '^' then
X begin
X if debug_parse then write(' <deref>');
X pref := '*' + pref;
X gettok;
X end
X else
X
X (* pointer subscripts *)
X if tok = '^[' then
X begin
X if debug_parse then write(' <ptr.subs>');
X lv := lv + '[';
X gettok;
X
X while tok <> ']' do
X begin
X lv := lv + pexpr;
X if tok = ',' then
X begin
X lv := lv + '][';
X gettok;
X end;
X end;
X
X lv := lv + ']';
X gettok;
X end
X else
X
X (* pointer members *)
X if tok = '^.' then
X begin
X if debug_parse then write(' <ptr.deref>');
X lv := lv + '->';
X gettok;
X idok := true;
X end
X else
X
X (* record members *)
X if tok = '.' then
X begin
X if debug_parse then write(' <member>');
X if pref = '*' then {translate *id. into id->}
X begin
X pref := '';
X lv := lv + '->';
X end
X else
X lv := lv + '.';
X idok := true;
X gettok;
X end
X else
X
X (* subscripts *)
X if tok[1] = '[' then
X begin
X if debug_parse then write(' <subs>');
X btype := cexprtype;
X bstype := cstype;
X bbase := cbase;
X
X if copy(pref,1,1) = '*' then
X pref := ''; {replace '*id[' with 'id['}
X
X lv := lv + '[';
X gettok;
X
X repeat
X expr := pexpr;
X
X if tok[1] = ',' then
X begin
X lv := lv + expr + '][';
X gettok;
X bstype := ss_scalar;
X end;
X until tok[1] = ']';
X
X subtract_base(expr,bbase);
X lv := lv + expr + ']';
X
X if (btype = s_string) and (bstype <> ss_array) then
X begin
X btype := s_char;
X ltok := lv;
X if expr = '-1' then
X warning('Dynamic length reference');
X end;
X
X cexprtype := btype;
X cstype := ss_scalar;
X cbase := 0;
X gettok;
X end
X else
X
X (* function calls *)
X if tok[1] = '(' then
X begin
X if debug_parse then write(' <func>');
X func := locatesym(funcid);
X pvars := 0;
X if func <> nil then
X begin
X pvars := func^.pvar; {determine return type}
X cexprtype := func^.symtype;
X end;
X
X btype := cexprtype;
X lv := lv + '(';
X gettok;
X
X while tok[1] <> ')' do
X begin
X expr := pexpr;
X if (pvars and 1) = 1 then {prefix VAR paremeters}
X make_pointer(expr);
X
X lv := lv + expr;
X pvars := pvars shr 1;
X
X if (tok[1] = ',') or (tok = ':') then
X begin
X lv := lv + ',';
X gettok;
X end;
X end;
X
X lv := lv + ')';
X gettok;
X cexprtype := btype;
X end
X else
X
X(* otherwise just return what was found so far *)
X begin
X
X (* add dummy param list to function calls where the proc
X expects no parameters *)
X if sym <> nil then
X begin
X if (not iscall(lv)) and (sym^.parcount >= 0) then
X lv := lv + '()';
X end;
X
X plvalue := pref + lv;
X exit;
X end;
X
X until recovery;
X
X plvalue := pref + lv;
Xend;
X
________This_Is_The_END________
if test `wc -c < tpcexpr.inc` -ne 17450; then
echo 'shar: tpcexpr.inc was damaged during transit (should have been 17450 bytes)'
fi
fi ; : end of overwriting check
echo 'x - tpcmisc.inc'
if test -f tpcmisc.inc; then echo 'shar: not overwriting tpcmisc.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > tpcmisc.inc
X
X(*
X * TPTC - Turbo Pascal to C translator
X *
X * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
X *
X *)
X
X
X(********************************************************************)
Xprocedure mark_time(var long: longint);
X {report time in clock ticks since midnight}
Xvar
X words: record
X l,h: word;
X end absolute long;
X reg: registers;
X
Xbegin
X reg.ah := 0; {get time of day}
X intr($1a,reg);
X words.l := reg.dx;
X words.h := reg.cx;
Xend;
X
X
X(********************************************************************)
Xprocedure abortcheck;
X {check for the abort(escape) key}
Xvar
X c: char;
Xbegin
X if keypressed then
X begin
X c := readkey;
X if c = #27 then
X fatal('Aborted by <escape> key');
X end;
Xend;
X
X
X(********************************************************************)
Xprocedure puttok;
X {output the current token and a space to the output}
Xbegin
X write(ofd[unitlevel],ltok,' ');
X linestart := false;
Xend;
X
X
X(********************************************************************)
Xprocedure putline;
X {start a new line in the output file}
Xbegin
X writeln(ofd[unitlevel]);
X inc(objtotal);
X linestart := true;
Xend;
X
X
X(********************************************************************)
Xprocedure closing_statistics;
Xvar
X secs: real;
X rate: real;
X
Xbegin
X
X {terminate any active output files}
X if in_interface then
X pimplementation;
X purgetable(locals,nil);
X while unitlevel > 0 do
X exit_procdef;
X putline;
X putline;
X purgetable(globals,nil);
X close(ofd[unitlevel]);
X
X {determine statistics}
X mark_time(curtime);
X secs := int(curtime-starttime) / ticks_per_second;
X
X {rate := int(srctotal) / secs * 60.0;}
X rate := int(objtotal) / secs * 60.0;
X
X {report statistics}
X if debug then writeln;
X writeln(^M,srcfiles[srclevel],'(',srclines[srclevel],')');
X writeln(srctotal,' source lines, ',
X objtotal,' object lines, ',
X secs:0:1,' seconds, ',
X rate:0:0,' lines/min.');
Xend;
X
X
X(********************************************************************)
Xprocedure error_message (message: string);
X {place an error message into the object file and on the screen}
X
X procedure report(var fd: text);
X begin
X writeln(fd,'/* TPTC: ',srcfiles[srclevel],'(',srclines[srclevel],'): ',
X message,', tok=', ltok,' */');
X end;
X
Xbegin
X if debug then writeln
X else write(^M);
X report(output);
X
X putline;
X report(ofd[unitlevel]);
X write(ofd[unitlevel],spaces);
X inc(objtotal);
Xend;
X
X
X(********************************************************************)
Xprocedure comment_statement;
Xbegin
X puts(' /* ');
X
X repeat
X puttok;
X gettok;
X until (tok[1] = ';');
X
X puts(' */ ');
Xend;
X
X
X(********************************************************************)
Xprocedure warning (message: string);
X {report a warning message unless warnings are disabled}
Xbegin
X if not quietmode then
X error_message('Warning: '+message);
Xend;
X
X
X(********************************************************************)
Xprocedure syntax (message: string);
X {report a syntax error and skip to the next ';'}
Xbegin
X if (not recovery) or (not quietmode) then
X error_message('Error: '+message);
X gettok;
X recovery := true;
Xend;
X
X
X(********************************************************************)
Xprocedure fatal (message: string);
X {abort translation with a fatal error}
Xbegin
X error_message('Fatal: '+message);
X closing_statistics;
X halt(88);
Xend;
X
X
X(********************************************************************)
Xprocedure puts(s: string);
X {output a string the output file}
Xbegin
X write(ofd[unitlevel],s);
X if s[1] = ^J then
X begin
X inc(objtotal);
X linestart := true;
X end
X else
X linestart := false;
Xend;
X
X
X(********************************************************************)
Xprocedure putln(s: string);
X {output a string the output file and newline}
Xbegin
X puts(s);
X putline;
Xend;
X
X
X(********************************************************************)
Xprocedure newline;
X {start a new line in the output file; indent to the same level
X as the current line}
Xbegin
X putline;
X write(ofd[unitlevel],spaces);
Xend;
X
X
X
________This_Is_The_END________
if test `wc -c < tpcmisc.inc` -ne 4274; then
echo 'shar: tpcmisc.inc was damaged during transit (should have been 4274 bytes)'
fi
fi ; : end of overwriting check
echo 'x - tpcscan.inc'
if test -f tpcscan.inc; then echo 'shar: not overwriting tpcscan.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > tpcscan.inc
X
X(*
X * TPTC - Turbo Pascal to C translator
X *
X * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
X *
X *)
X
X
X(********************************************************************)
X(*
X * lexical scanner
X *
X *)
X
Xfunction numlit(n: integer): anystring;
Xvar
X lit: string[6];
X
X {convert an integer into a c style numeric character literal}
X function digit(n: integer): char;
X (* convert an integer into a hex digit *)
X begin
X n := n and 15;
X if n > 9 then n := n + 7;
X digit := chr( n + ord('0') );
X end;
X
Xbegin
X lit := '''\?''';
X
X case n of
X $07: lit[3] := 'a';
X $08: lit[3] := 'b';
X $09: lit[3] := 't';
X $0a: lit[3] := 'n';
X $0b: lit[3] := 'v';
X $0c: lit[3] := 'f';
X $0d: lit[3] := 'r';
X
X 32..126,128..254:
X lit := ''''+chr(n)+'''';
X
X else begin
X lit := '''\x??''';
X lit[4] := digit(n shr 4);
X lit[5] := digit(n);
X end;
X end;
X
X numlit := lit;
X toktype := chars;
Xend;
X
X
X(********************************************************************)
Xprocedure getchar;
X {consume the current char and get the next one}
Xvar
X stack: char;
Xbegin
X if ofs(stack) < minstack then
X fatal('Out of stack space');
X
X while (srclevel > 0) and eof(srcfd[srclevel]) do
X begin
X if not linestart then putline;
X putln('/* TPTC: end of '+srcfiles[srclevel]+' */');
X
X if debug then writeln;
X writeln(^M,srcfiles[srclevel],'(',srclines[srclevel],')');
X
X close(srcfd[srclevel]);
X freemem(inbuf[srclevel],inbufsiz);
X
X dec(srclevel);
X statustime := 0;
X end;
X
X if eof(srcfd[srclevel]) then
X nextc := '.'
X else
X read(srcfd[srclevel], nextc);
X
X if nextc = ^J then
X begin
X inc(srclines[srclevel]);
X inc(srctotal);
X
X mark_time(curtime);
X if (curtime >= statustime) or debug then
X begin
X if debug then writeln;
X write(^M,srcfiles[srclevel],'(',srclines[srclevel],')');
X statustime := curtime+statrate;
X abortcheck;
X end;
X end;
Xend;
X
X
X(********************************************************************)
Xfunction usec: char;
X {use up the current character(return it) and get
X the next one from the input stream}
Xvar
X c: char;
Xbegin
X c := nextc;
X getchar;
X usec := c;
Xend;
X
X
X(********************************************************************)
Xfunction newc(n: string40): string40;
X {replace the current character with a different one and get the next
X character from the input stream}
Xvar
X c: char;
Xbegin
X c := nextc;
X getchar;
X newc := n;
Xend;
X
X
X(********************************************************************)
Xprocedure concat_tokens;
X {concatenate the next token and the current token}
Xvar
X cur: string;
Xbegin
X cur := ltok;
X ltok := nextc;
X toktype := unknown;
X scan_tok;
X
X ltok := copy(cur,1,length(cur)-1) + copy(ltok,2,255);
X ltok[1] := '"';
X ltok[length(ltok)] := '"';
X toktype := strng;
Xend;
X
X
X(********************************************************************)
Xprocedure scan_ident;
X {scan an identifier; output is ltok; nextc is first character following
X the identifier; toktype = identifier; this is the protocol for all of
X the scan_xxxx procedures in the lexical analyzer}
Xbegin
X
X toktype := unknown;
X ltok := '';
X
X repeat
X case nextc of
X 'A'..'Z':
X begin
X if map_lower then
X nextc := chr( ord(nextc)+32 );
X ltok := ltok + nextc;
X getchar;
X end;
X
X 'a'..'z', '0'..'9', '_','@':
X ltok := ltok + usec;
X
X else
X toktype := identifier;
X end;
X
X until toktype = identifier;
Xend;
X
X
X
X(********************************************************************)
Xprocedure scan_preproc;
X {scan a tshell preprocessor directive; same syntax as C already}
Xbegin
X puts('#');
X
X repeat
X puts(nextc);
X getchar;
X until nextc = ^M;
X
X getchar;
X putline;
X toktype := unknown;
Xend;
X
X
X(********************************************************************)
Xprocedure scan_number;
X {scan a number; this also processes #nnn character literals, which are
X converted into octal character literals. imbedded periods are processed,
X and a special condition is noted for trailing periods. this is needed
X for scanning the ".." keyword when used after numbers. an ungetchar
X facility would be more general, but isn't needed anywhere else.
X in pascal/mt+, #nnn is translated into nnnL }
Xvar
X hasdot: boolean;
X charlit: boolean;
X islong: boolean;
X
Xbegin
X hasdot := false;
X islong := false;
X charlit := false;
X toktype := number;
X
X(* check for preprocessor directives, character literals or long literals *)
X if nextc = '#' then
X begin
X ltok := '';
X if mt_plus then
X islong := true
X else
X charlit := true;
X end;
X
X getchar;
X
X(* check for preprocessor directives *)
X if tshell and charlit and (nextc >= 'a') and (nextc <= 'z') then
X scan_preproc
X else
X
X repeat
X case nextc of
X '$','0'..'9','a'..'f','A'..'F':
X ltok := ltok + usec;
X
X '.':
X if hasdot then
X begin
X if ltok[length(ltok)] = '.' then
X begin
X ltok[0] := pred(ltok[0]); {remove trailing ., part of ..}
X if charlit then
X ltok := numlit(atoi(ltok));
X extradot := true;
X end;
X exit;
X end
X else
X
X begin
X hasdot := true;
X ltok := ltok + usec;
X end;
X
X else
X begin
X if charlit then
X begin
X ltok := numlit(atoi(ltok));
X if (nextc = '''') or (nextc = '^') or (nextc = '#') then
X concat_tokens;
X exit;
X end;
X
X if ltok[1] = '$' then
X ltok := '0x' + copy(ltok,2,99);
X if islong then
X ltok := ltok + 'L';
X exit;
X end;
X end;
X
X until true=false;
Xend;
X
X
X(********************************************************************)
Xprocedure scan_hat;
X {scan tokens starting with ^ - returns ^X as a character literal
X corresponding to the specified control character. returns ^ident as
X an identifier with the leading ^ intact. also scans ^. and ^[.}
Xvar
X c: char;
X
Xbegin
X getchar;
X
X if ((nextc = '.') or (nextc = '[')) and
X ((ptoktype = identifier) or (ptok = ']')) then
X begin
X ltok := '^' + usec; {^. or ^[}
X exit;
X end;
X
X case nextc of
X '@','['..'`':
X ltok := usec;
X
X 'A'..'Z','a'..'z':
X begin
X ltok := nextc;
X scan_ident;
X end;
X else
X exit;
X end;
X
X if length(ltok) = 1 then {^c = control char}
X begin
X ltok := numlit( ord(upcase(ltok[1])) - ord('@') );
X if (nextc = '''') or (nextc = '^') or (nextc = '#') then
X concat_tokens;
X end
X else
X ltok := '^' + ltok; {^ident = pointer to ident}
X
Xend;
X
X
X(********************************************************************)
Xprocedure scan_dot;
X {scans tokens starting with "."; knows about the 'extra dot' condition
X that comes up in number scanning. returns a token of either '.' or '..'}
Xbegin
X getchar;
X
X if (nextc = '.') or extradot then
X begin
X ltok := '..';
X extradot := false;
X end;
X
X if nextc = '.' then
X getchar;
Xend;
X
X
X(********************************************************************)
Xprocedure scan_string;
X {scans a literal string. processes imbedded quotes ala pascal. translates
X the string into a C string with the proper escapes on imbedded quotes.
X converts single character strings into character constants. these are
X sometimes converted back to strings when the parser needs to}
Xbegin
X toktype := unknown;
X ltok := '"';
X getchar;
X
X repeat
X case nextc of
X ^J,^M:
X begin
X error_message('Closing quote expected (scan_string)');
X toktype := strng;
X end;
X
X '''':
X begin
X getchar; {consume the quote}
X
X if nextc = '''' then
X ltok := ltok + usec
X {double quotes are coded as a single quote}
X else
X
X begin {end of string}
X ltok := ltok + '"';
X toktype := strng;
X end;
X end;
X
X '"': ltok := ltok + newc('\"');
X '\': ltok := ltok + newc('\\');
X
X else ltok := ltok + usec;
X end;
X
X until toktype = strng;
X
X if length(ltok) = 3 then
X begin
X ltok[1] := '''';
X ltok[3] := '''';
X toktype := chars;
X end;
X
X if ltok = '"\""' then
X begin
X ltok := '''"''';
X toktype := chars;
X end
X else
X
X if (ltok = '"''"') or (ltok = '''''''') then
X ltok := '''\'''''
X else
X
X if (ltok = '"\\"') then
X begin
X ltok := '''\\''';
X toktype := chars;
X end;
X
X if (nextc = '^') or (nextc = '#') then
X concat_tokens;
Xend;
X
X
X(********************************************************************)
Xprocedure scan_pragma(var isinclude: anystring);
X {scans a turbo pascal compiler option and translates it into a comment.
X include directive is translated into the #include.
X returns with the first non-blank after the pragma}
Xvar
X code: anystring;
X prag: anystring;
X arg: anystring;
X
X procedure scanword(var dest: anystring);
X begin
X dest := ' '; {insure dest[2] is initialized}
X dest := '';
X while true do
X case nextc of
X ' ', '*', '}', ',':
X exit;
X else
X begin
X dest := dest + upcase(nextc);
X getchar;
X end;
X end;
X end;
X
Xbegin
X isinclude := '';
X
X repeat
X if nextc = ',' then
X newline;
X
X getchar; {consume the $ or ,}
X
X {get the progma code}
X scanword(code);
X
X if nextc = ' ' then
X begin
X getchar;
X scanword(arg);
X end
X else
X arg := '';
X
X if code[2] = '+' then
X arg := 'ON'
X else
X if code[2] = '-' then
X arg := 'OFF';
X
X prag := '/* '+code[1]+'(' + arg + ')' + ' */';
X
X case code[1] of
X
X 'D': if code[2] = 'E' then
X prag := '#define '+arg;
X
X 'E': if code[2] = 'N' then
X prag := '#endif'
X else
X if code[2] = 'L' then
X prag := '#else';
X
X 'I': if code[2] = ' ' then
X begin
X if pos('.',arg) = 0 then
X arg := arg + '.PAS';
X prag := '#include "' + arg + '" ';
X
X if includeinclude then
X begin
X prag := '';
X isinclude := arg;
X end;
X end
X else
X
X if code[2] = 'F' then
X begin
X if code[3] = 'N' then
X prag := '#ifndef '+arg
X else
X prag := '#ifdef '+arg;
X end;
X
X 'U': if code[2] = 'N' then
X prag := '#undef '+arg;
X
X end;
X
X puts(prag);
X puts(' ');
X
X while nextc = ' ' do
X getchar;
X
X until nextc <> ',';
X
Xend;
X
X
X(********************************************************************)
Xprocedure open_include(name: anystring);
Xbegin
X if length(name) = 0 then exit;
X
X inc(srctotal);
X inc(objtotal);
X
X inc(srclevel);
X if srclevel > maxincl then
X fatal('Includes nested too deeply');
X
X srcfiles[srclevel] := name;
X srclines[srclevel] := 1;
X
X assign(srcfd[srclevel],name);
X {$I-} reset(srcfd[srclevel]); {$I+}
X if ioresult <> 0 then
X begin
X dec(srclevel);
X ltok := name;
X warning('Missing include file');
X end
X else
X
X begin
X if not linestart then putline;
X putln('/* TPTC: include '+name+' */');
X
X if maxavail-300 <= inbufsiz then
X begin
X ltok := name;
X fatal('Out of memory');
X end;
X
X getmem(inbuf[srclevel],inbufsiz);
X SetTextBuf(srcfd[srclevel],inbuf[srclevel]^,inbufsiz);
X end;
X
X if {quietmode and} not debug then
X write(^M,'':40,^M)
X else
X writeln;
X statustime := 0;
Xend;
X
X
X(********************************************************************)
Xprocedure scan_curlycomment;
X {processes a curly-brace enclosed comment}
Xvar
X isinclude: anystring;
X
Xbegin
X toktype := comment;
X getchar; {consume the open comment}
X
X isinclude := '';
X if nextc = '$' then
X scan_pragma(isinclude);
X
X if nextc = '}' then
X begin
X getchar;
X open_include(isinclude);
X exit;
X end;
X
X if pass_comments then
X puts(' /* ');
X
X while nextc <> '}' do
X begin
X if pass_comments then
X puts(nextc);
X getchar;
X end;
X
X if pass_comments then
X begin
X puts(' */ ');
X if nospace then newline;
X end;
X
X getchar; {consume the close comment}
X open_include(isinclude);
Xend;
X
X
X(********************************************************************)
Xprocedure scan_parencomment;
X {process a (* enclosed comment}
Xvar
X isinclude: anystring;
X
Xbegin
X toktype := comment;
X getchar; {consume the *}
X
X isinclude := '';
X if nextc = '$' then
X scan_pragma(isinclude);
X
X if pass_comments then
X puts('/*');
X
X repeat
X if pass_comments then
X puts(nextc);
X
X if nextc = '*' then
X begin
X getchar;
X
X if nextc = ')' then
X begin
X getchar;
X if pass_comments then
X begin
X puts('/ ');
X if nospace then putline;
X end;
X open_include(isinclude);
X exit;
X end;
X end
X else
X getchar;
X
X until true=false;
Xend;
X
X
X(********************************************************************)
Xprocedure scan_blanks;
X {scan white space. this procedure sometimes passes whitespace to the
X output. it keeps track of the indentation of the current line so it
X can be used by newline}
Xvar
X indent: anystring;
X valid: boolean;
X
Xbegin
X linestart := false;
X indent := '';
X valid := false;
X
X repeat
X
X case nextc of
X ^J,^M: begin
X if (nospace = false) and (nextc = ^J) then
X putline;
X
X indent := '';
X linestart := true;
X getchar;
X end;
X
X ' ',^I,^@,^L:
X indent := indent + usec;
X
X '#': if linestart and tshell then
X begin
X puts(indent); {pass preprocessor directives}
X indent := ''; {without change (single-line only)}
X
X repeat
X puts(nextc);
X getchar;
X until nextc = ^M;
X
X getchar;
X putline;
X end
X else
X valid := true;
X
X else
X valid := true;
X end;
X
X until valid;
X
X if linestart then
X begin
X spaces := indent;
X if nospace=false then
X puts(spaces);
X
X linestart := true;
X end;
Xend;
X
X
X(********************************************************************)
Xprocedure scan_tok;
X {scans the next lexical token; returns the token in ltok and toktype}
Xbegin
X scan_blanks;
X
X toktype := unknown;
X ltok := nextc;
X
X case nextc of
X 'a'..'z',
X '_', 'A'..'Z': scan_ident;
X
X '$': scan_number;
X '0'..'9': scan_number;
X
X '''': scan_string;
X
X '^': scan_hat;
X
X '#': begin
X scan_number;
X if toktype = unknown then
X scan_tok; {in case of #directive}
X end;
X
X
X '<': begin
X getchar;
X if (nextc = '>') or (nextc = '=') then
X ltok := '<' + usec;
X end;
X
X '>': begin
X getchar;
X if nextc = '=' then
X ltok := '>' + usec;
X end;
X
X ':': begin
X getchar;
X if nextc = '=' then
X ltok := ':' + usec;
X end;
X
X '.': scan_dot;
X
X '{': scan_curlycomment;
X
X '(': begin
X getchar;
X if nextc = '*' then
X scan_parencomment;
X end;
X
X else getchar; {consume the unknown char}
X end;
Xend;
X
X
X(********************************************************************)
Xprocedure gettok;
X {get the next input token; this is the top level of the lexical analyzer.
X it returns ltok, tok(ltok in upper case), toktype. it translates BEGIN
X and END into braces; it checks for statement and section keywords}
Xvar
X i: integer;
X
Xbegin
X ptoktype := toktype;
X ptok := tok;
X cursym := nil;
X
X repeat
X scan_tok;
X until toktype <> comment;
X tok := ltok;
X
X if debug then write(' {',ltok,'}');
X
X if toktype = identifier then
X begin
X stoupper(tok);
X
X if tok = 'BEGIN' then
X begin
X tok := '{';
X ltok := tok;
X toktype := keyword;
X end
X else
X
X if tok = 'END' then
X begin
X tok := '}';
X ltok := tok;
X toktype := keyword;
X end;
X
X (* check for statement keywords *)
X i := 0;
X repeat
X inc(i);
X if tok[1] = keywords[i][1] then {hack for speed}
X if length(tok) = length(keywords[i]) then
X if tok = keywords[i] then
X toktype := keyword;
X until (i = nkeywords) or (toktype = keyword);
X
X (* get symbol table information for this item *)
X cursym := locatesym(tok);
X end;
Xend;
X
X
X(********************************************************************)
Xfunction usetok: string80;
X {return (use) and consume current token}
Xvar
X tv: string80;
Xbegin
X tv := ltok;
X gettok;
X usetok := tv;
Xend;
X
X
________This_Is_The_END________
if test `wc -c < tpcscan.inc` -ne 18755; then
echo 'shar: tpcscan.inc was damaged during transit (should have been 18755 bytes)'
fi
fi ; : end of overwriting check
exit 0