Subject: v13i067: Patches for Pascal-to-C translator Newsgroups: comp.sources.unix Sender: sources Approved: rsalz@uunet.UU.NET Submitted-by: Per Bergsten Posting-number: Volume 13, Issue 67 Archive-name: pas2c.pch The following diffs adress all errors in the Pascal-to-C-translator that have been reported to me. The translator was posted during summer -87 and a few bug-reports came in during August. I have had no reports since late September which I take to mean that either nobody has found any use for the program or that there are no remaining serious problems. Happily, with one exception, no report concerned cases where the translator silently produced wrong code. There were some cases where the translator would fail or where it generated code that was syntactically incorrect. The exception concerned the status of "input" before the program had tested "eof". This was actually a "feature" since the behaviour was intended (though not formally correct). Comments, questions etc to: Per Bergsten perb@holtec.se (....mcvax!enea!chalmers!holtec!perb) perb%holtec.uucp@chalmers.csnet ------------------------------------------------------------------------------- #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # READ_ME # ptc.diff export PATH; PATH=/bin:$PATH if test -f 'READ_ME' then echo shar: will not over-write existing file "'READ_ME'" else cat << \SHAR_EOF > 'READ_ME' The following problems have been adressed. 1) In some circumstances the reader misread 1..n which lead to a complaint about malplaced floating point numbers. 2) The translator generated double "->" arrows for references to VAR-parameters that were pointers. 3) Missing initialisation of pointers in a record variant for case-statements sometimes caused the translator to crash. 4) Calling "write" with a boolean literal as parameter caused the translator to crash. 5) Initialization of input. Programs that read input before testing for eof can be made to work by defining a compiletime constant STDINIT otherwise the first returned character will be null. 6) The code generated for procedurecalls with string-literal parameters could cause the resulting program to crash due to alignment errors. This is truly a PATCH, i.e. the "correct" solution would require a redesign of the translator. In this case the problem has been swept under the carpet at the cost of some runtime overhead by copying data. The behaviour of the translator is controlled by a boolean constant "align" which, if true, cuses the translator to generate calls to to functions STRALIGN and SETALIGN. STRALIGN and SETALIGN are macros which by default call simple subroutines that will copy data to well aligned structures. 7) Types and variables in nested procedures were not always moved to an enclosing scope when the procedures were un-nested. 8) The I/O macros were modified so that "rewind" was replaced by "fseek" and so that the generated code is type-correct. 9) The translator didn't handle incomplete Pascal programs as documented. 10) A few changes were made to remove illegal Pascal-code. SHAR_EOF fi # end of overwriting check if test -f 'ptc.diff' then echo shar: will not over-write existing file "'ptc.diff'" else cat << \SHAR_EOF > 'ptc.diff' *** ptc.p Fri Nov 13 18:45:21 1987 --- nptc.p Fri Nov 13 18:44:29 1987 *************** *** 42,48 **** (** The code generated by the translator assumes that there is a **) (** C-implementation with at least a reasonable library **) (** since all input/output is implemented in terms of C functions **) ! (** like fprintf(), getc(), fopen(), rewind() etc. **) (** If the source-program uses Pascal functions like sin(), sqrt() **) (** etc, there must also exist such functions in the C-library. **) (** **) --- 42,48 ---- (** The code generated by the translator assumes that there is a **) (** C-implementation with at least a reasonable library **) (** since all input/output is implemented in terms of C functions **) ! (** like fprintf(), getc(), fopen(), fseek() etc. **) (** If the source-program uses Pascal functions like sin(), sqrt() **) (** etc, there must also exist such functions in the C-library. **) (** **) *************** *** 53,59 **** label 9999; (* end of program *) ! const version = '@(#)ptc.p 1.5 Date 87/05/01'; keytablen = 38; (* nr of keywords *) keywordlen = 10; (* length of a keyword *) --- 53,59 ---- label 9999; (* end of program *) ! const version = '@(#)ptc.p 2.6 Date 87/09/12'; keytablen = 38; (* nr of keywords *) keywordlen = 10; (* length of a keyword *) *************** *** 67,75 **** setbits = 15; (* CPU *) (* a Pascal file is implemented as a struct which (among other *) ! (* things) contain a flag-field, currently 3 bits are used *) filebits = 'unsigned short'; (* flags for files *) ! filefill = 12; (* 16 less used 3 bits *) maxsetrange = 15; (* nr of words in a set *) scalbase = 0; (* ordinal value of first scalar member *) --- 67,75 ---- setbits = 15; (* CPU *) (* a Pascal file is implemented as a struct which (among other *) ! (* things) contain a flag-field, currently 4 bits are used *) filebits = 'unsigned short'; (* flags for files *) ! filefill = 12; (* 16 less used 4 bits *) maxsetrange = 15; (* nr of words in a set *) scalbase = 0; (* ordinal value of first scalar member *) *************** *** 106,111 **** --- 106,112 ---- temporary files for reset/rewrite, the last character is supplied by the reset/rewrite routine *) tmpfilename = '"/tmp/ptc%d%c", getpid(), '; (* OS *) + maxfilename = 'MAXFILENAME'; (* some frequently used characters *) space = ' '; *************** *** 146,151 **** --- 147,154 ---- voidtyp = 'void'; (* for procedures *) voidcast = '(void)'; + align = true; (* align literal params *) + intlen = 10; (* length of written integer *) fixlen = 20; (* length of written real *) *************** *** 239,244 **** --- 242,264 ---- sinteger: (vint : integer); sreal: (vflt : strindx); sstring: (vstr : strindx); + + sand, sarray, sbegin, scase, + sconst, sdiv, sdo, sdownto, + selse, send, sextern, sfile, + sfor, sforward, sfunc, sgoto, + sif, sinn, slabel, smod, + snil, snot, sof, sor, + sother, spacked, sproc, spgm, + srecord, srepeat, sset, sthen, + sto, stype, suntil, svar, + swhile, swith, seof, + splus, sminus, smul, squot, + sarrow, slpar, srpar, slbrack, + srbrack, seq, sne, slt, + sle, sgt, sge, scomma, + scolon, ssemic, sassign, sdotdot, + sdot: () end; (* enumeration of symnode variants *) *************** *** 648,653 **** --- 668,674 ---- cstdout, cstderr, cstrncmp, cstrncpy, cstruct, cstatic, cswitch, ctypedef, cundef, cungetc, cunion, cunlink, + cfseek, cgetchar, cputchar, cunsigned, cwrite ); *************** *** 661,667 **** enew, esetbase, esetsize, eoverflow, etree, etag, euprconf, easgnconf, ecmpconf, econfconf, evrntfile, evarfile, ! emanymachs, ebadmach ); machdefstr = packed array [ 1 .. machdeflen ] of char; --- 682,688 ---- enew, esetbase, esetsize, eoverflow, etree, etag, euprconf, easgnconf, ecmpconf, econfconf, evrntfile, evarfile, ! emanymachs, ebadmach, eprconf ); machdefstr = packed array [ 1 .. machdeflen ] of char; *************** *** 683,688 **** --- 704,711 ---- useins, usescpy, usecomp, (* source program uses string-compare *) + usealig, (* source program uses aligned params *) + usesal, usefopn, (* source program uses reset/rewrite *) usescan, usegetl, *************** *** 738,745 **** varno : integer; (* counter for unique id's *) ! hexdig : packed array [ 0 .. 15 ] of char; (* Prtmsg produces an error message. It asssumes that procedure *) (* "message" (predefined) will "writeln" to user tty. OS *) procedure prtmsg(m : errors); --- 761,771 ---- varno : integer; (* counter for unique id's *) ! pushchr : char; (* pushback for lexical scanner *) ! pushed : boolean; + hexdig : array [ 0 .. 15 ] of char; + (* Prtmsg produces an error message. It asssumes that procedure *) (* "message" (predefined) will "writeln" to user tty. OS *) procedure prtmsg(m : errors); *************** *** 814,819 **** --- 840,847 ---- message(restr, 'Too many machine integer types'); ebadmach: message(inter, 'Bad name for machine integer type'); + eprconf: + message(restr, 'Cannot write conformant arrays'); end;(* case *) if lastline <> 0 then begin *************** *** 1219,1225 **** var c : char; begin ! if eof then c := chr(null) else begin colno := colno + 1; --- 1247,1258 ---- var c : char; begin ! if pushed then ! begin ! c := pushchr; ! pushed := false ! end ! else if eof then c := chr(null) else begin colno := colno + 1; *************** *** 1235,1241 **** else write(c); if c = tab1 then ! colno := ((colno div tabwidth) + 1) * tabwidth end; if lastchr > 0 then begin --- 1268,1275 ---- else write(c); if c = tab1 then ! colno := (((colno - 1) div tabwidth) + 1) * ! tabwidth end; if lastchr > 0 then begin *************** *** 1249,1255 **** function peekchar : char; begin ! if eof then peekchar := chr(null) else peekchar := input^ --- 1283,1291 ---- function peekchar : char; begin ! if pushed then ! peekchar := pushchr ! else if eof then peekchar := chr(null) else peekchar := input^ *************** *** 1458,1466 **** end; st := sinteger; vint := n; if realok then begin - (* accept real numbers *) if peekchar = '.' then begin (* this is a real number *) --- 1494,1508 ---- end; st := sinteger; vint := n; + if realok and (peekchar = '.') then + begin + c := nextchar; + realok := numchar(peekchar); + pushchr := c; + pushed := true + end; if realok then begin if peekchar = '.' then begin (* this is a real number *) *************** *** 1579,1585 **** quote: begin (* assume the symbol is a literal string *) ! wl := 0; ready := false; repeat if eoln then --- 1621,1627 ---- quote: begin (* assume the symbol is a literal string *) ! wl := 1; ready := false; repeat if eoln then *************** *** 1602,1608 **** end; if not ready then begin ! wl := wl + 1; if wl >= maxtoknlen then begin lasttok[lastchr] := --- 1644,1650 ---- end; if not ready then begin ! wb[wl] := c; if wl >= maxtoknlen then begin lasttok[lastchr] := *************** *** 1609,1618 **** chr(null); error(elongstring) end; ! wb[wl] := c end until ready; ! if wl = 1 then begin (* only 1 character => not a string *) st := schar; --- 1651,1660 ---- chr(null); error(elongstring) end; ! wl := wl + 1; end until ready; ! if wl = 2 then begin (* only 1 character => not a string *) st := schar; *************** *** 1620,1631 **** end else begin (* > 1 character => its a string *) - wl := wl + 1; - if wl >= maxtoknlen then - begin - lasttok[lastchr] := chr(null); - error(elongstring) - end; wb[wl] := chr(null); st := sstring; vstr := savestr(wb) --- 1662,1667 ---- *************** *** 2645,2650 **** --- 2681,2687 ---- sproc, sfunc, sbegin]); pbody(tp); checksymbol([sdot]); + nextsymbol([seof]); tp^.tscope := currscope; leavescope; pprogram := tp *************** *** 2662,2668 **** tp^.tsubid := nil; tp^.tsubpar := nil; pbody(tp); ! checksymbol([ssemic]); tp^.tscope := currscope; leavescope; pmodule := tp --- 2699,2707 ---- tp^.tsubid := nil; tp^.tsubpar := nil; pbody(tp); ! checksymbol([ssemic, seof]); ! if currsym.st = ssemic then ! nextsymbol([seof]); tp^.tscope := currscope; leavescope; pmodule := tp *************** *** 2799,2805 **** enterscope(dp); dp := currscope end; ! nextsymbol([sid, scase] + [cs]); tq := nil; while currsym.st = sid do begin --- 2838,2844 ---- enterscope(dp); dp := currscope end; ! nextsymbol([sid, scase, cs]); tq := nil; while currsym.st = sid do begin *************** *** 2820,2826 **** tq^.tbind := ptypedef; enterscope(dp); if currsym.st = ssemic then ! nextsymbol([sid, scase] + [cs]) end; if currsym.st = scase then begin --- 2859,2865 ---- tq^.tbind := ptypedef; enterscope(dp); if currsym.st = ssemic then ! nextsymbol([sid, scase, cs]) end; if currsym.st = scase then begin *************** *** 2852,2858 **** tv := nil; repeat nextsymbol([sid, sinteger, schar, splus, ! sminus] + [cs]); if currsym.st = cs then goto 999; if tv = nil then --- 2891,2897 ---- tv := nil; repeat nextsymbol([sid, sinteger, schar, splus, ! sminus, cs]); if currsym.st = cs then goto 999; if tv = nil then *************** *** 3650,3655 **** --- 3689,3696 ---- tq^.tnext := mknode(nchoise); tq := tq^.tnext end; + tq^.tchocon := nil; + tq^.tchostmt := nil; tv := nil; repeat nextsymbol([sid, sinteger, schar, *************** *** 3845,3852 **** if currsym.st = spgm then top := pprogram else ! top := pmodule; ! nextsymbol([seof]); end; (* parse *) (* Compute value for a node (which must be some kind of constant). *) --- 3886,3892 ---- if currsym.st = spgm then top := pprogram else ! top := pmodule end; (* parse *) (* Compute value for a node (which must be some kind of constant). *) *************** *** 4317,4328 **** move := true; sp := ip^.tsym; if sp^.lid^.inref > 1 then - begin sp^.lid := ! mkrename( 'M', sp^.lid); ! sp^.lid^.inref := ! sp^.lid^.inref - 1 ! end; ip := nil end else --- 4357,4364 ---- move := true; sp := ip^.tsym; if sp^.lid^.inref > 1 then sp^.lid := ! mkrename('M', sp^.lid); ip := nil end else *************** *** 4619,4624 **** --- 4655,4662 ---- (* mark those used in nested subroutines *) global(tp^.tsubsub, tp, false); + global(tp^.tsubvar, tp, false); + global(tp^.tsubtype, tp, false); (* move out variables used in inner scope *) movevars(tp, tp^.tsubpar); *************** *** 4887,4896 **** a unique name *) sp := tp^.tsubid^.tsym; if sp^.lid^.inref > 1 then ! begin ! sp^.lid := mkrename('P', sp^.lid); ! sp^.lid^.inref := sp^.lid^.inref - 1 ! end end; tp := tp^.tnext end --- 4925,4931 ---- a unique name *) sp := tp^.tsubid^.tsym; if sp^.lid^.inref > 1 then ! sp^.lid := mkrename('P', sp^.lid) end; tp := tp^.tnext end *************** *** 5131,5136 **** --- 5166,5172 ---- const include = '# include '; define = '# define '; + undef = '# undef '; ifdef = '# ifdef '; ifndef = '# ifndef '; elsif = '# else'; *************** *** 5145,5152 **** var conflag, setused, dropset, - donearr : boolean; doarrow, indnt : integer; procedure increment; --- 5181,5188 ---- var conflag, setused, dropset, doarrow, + donearr : boolean; indnt : integer; procedure increment; *************** *** 5203,5216 **** (* Emit code to select a record member. *) procedure eselect(tp : treeptr); begin ! doarrow := doarrow + 1; eexpr(tp); - doarrow := doarrow - 1; if donearr then donearr := false else ! write('.') end; (* Emit code for call to a predefined function/procedure. *) --- 5239,5255 ---- (* Emit code to select a record member. *) procedure eselect(tp : treeptr); + var da : boolean; + begin ! da := doarrow; ! doarrow := true; eexpr(tp); if donearr then donearr := false else ! write('.'); ! doarrow := da end; (* Emit code for call to a predefined function/procedure. *) *************** *** 5435,5441 **** else write('*.*'); write('s') ! end end (* case *) end; (* eformat *) --- 5474,5482 ---- else write('*.*'); write('s') ! end; ! 'v': ! fatal(eprconf) end (* case *) end; (* eformat *) *************** *** 5572,5578 **** write(', '); eexpr(tq) end ! end end (* case *) end; (* ewrite *) --- 5613,5621 ---- write(', '); eexpr(tq) end ! end; ! 'v': ! fatal(eprconf) end (* case *) end; (* ewrite *) *************** *** 6212,6218 **** write(', '); tq := tp^.taparm^.tnext; if tq = nil then ! write('NULL') else begin tq := typeof(tq); if tq = typnods[tchar] then --- 6255,6261 ---- write(', '); tq := tp^.taparm^.tnext; if tq = nil then ! write('NULL, 0') else begin tq := typeof(tq); if tq = typnods[tchar] then *************** *** 6221,6234 **** ch := chr(cvalof(tp^.taparm^.tnext)); if (ch = bslash) or (ch = cite) then write(bslash); ! write(ch, cite) end else if tq = typnods[tstring] then ! eexpr(tp^.taparm^.tnext) ! else if tq^.tt in [narray, nconfarr] then begin eexpr(tp^.taparm^.tnext); ! write('.A') end else fatal(etree) --- 6264,6282 ---- ch := chr(cvalof(tp^.taparm^.tnext)); if (ch = bslash) or (ch = cite) then write(bslash); ! write(ch, cite, ', -1') end else if tq = typnods[tstring] then ! begin ! eexpr(tp^.taparm^.tnext); ! write(', -1') ! end ! else if tq^.tt = narray then begin eexpr(tp^.taparm^.tnext); ! write('.A, sizeof('); ! eexpr(tp^.taparm^.tnext); ! write('.A)') end else fatal(etree) *************** *** 6487,6507 **** eexpr(tq); write(')') end else eexpr(tq); end ! else if (tx = typnods[tstring]) or ! (tx = typnods[tset]) then begin - (* cast literal to proper type *) write('*(('); etypedef(tf^.tup^.tbind); write(' *)'); ! if tx = typnods[tset] then begin ! dropset := true; eexpr(tq); ! dropset := false end else eexpr(tq); --- 6535,6574 ---- eexpr(tq); write(')') end + else if tf^.tup^.tt = nvarpar then + eaddr(tq) else + eexpr(tq) + end + else if tx = typnods[tset] then + begin + write('*(('); + etypedef(tf^.tup^.tbind); + write(' *)'); + dropset := true; + if align then + begin + usesal := true; + write('SETALIGN('); eexpr(tq); + write(')') + end + else + eexpr(tq); + dropset := false; + write(')') end ! else if tx = typnods[tstring] then begin write('*(('); etypedef(tf^.tup^.tbind); write(' *)'); ! if align then begin ! usealig := true; ! write('STRALIGN('); eexpr(tq); ! write(')') end else eexpr(tq); *************** *** 6521,6528 **** eexpr(tq); (* add upper bound of actual value *) if tq^.tnext = nil then ! write(', ', ! crange(tx^.taindx):1) end else begin if tf^.tup^.tt = nvarpar then --- 6588,6600 ---- eexpr(tq); (* add upper bound of actual value *) if tq^.tnext = nil then ! begin ! write(', ('); ! eexpr(tx^.taindx^.thi); ! write(' - '); ! eexpr(tx^.taindx^.tlo); ! write(' + 1)') ! end end else begin if tf^.tup^.tt = nvarpar then *************** *** 6930,6944 **** eexpr(tp^.texps); write('.buf') end ! else if doarrow = 0 then begin ! write('*'); ! eexpr(tp^.texps) ! end ! else begin eexpr(tp^.texps); write('->'); donearr := true end end; nid: --- 7002,7018 ---- eexpr(tp^.texps); write('.buf') end ! else if doarrow then begin ! doarrow := false; eexpr(tp^.texps); write('->'); donearr := true + end + else begin + write('(*'); + eexpr(tp^.texps); + write(')') end end; nid: *************** *** 6947,6966 **** var-parameter or as a procedure-parameter *) tq := idup(tp); if tq^.tt = nvarpar then ! begin ! if (doarrow = 0) or ! (tq^.tattr = areference) then begin ! write('(*'); printid(tp^.tsym^.lid); ! write(')') end else begin printid(tp^.tsym^.lid); ! write('->'); ! donearr := true end - end else if (tq^.tt = nconst) and conflag then write(cvalof(tp):1) else if tq^.tt in [nparproc, nparfunc] then --- 7021,7038 ---- var-parameter or as a procedure-parameter *) tq := idup(tp); if tq^.tt = nvarpar then ! if doarrow then begin ! doarrow := false; printid(tp^.tsym^.lid); ! write('->'); ! donearr := true end else begin + write('(*'); printid(tp^.tsym^.lid); ! write(')') end else if (tq^.tt = nconst) and conflag then write(cvalof(tp):1) else if tq^.tt in [nparproc, nparfunc] then *************** *** 7107,7112 **** --- 7179,7206 ---- end end; (* econst *) + (* Undefine constants. *) + procedure edconst(tp : treeptr); + + var sp : symptr; + + begin + while tp <> nil do + begin + sp := tp^.tidl^.tsym; + if tp^.tbind^.tt <> nstring then + begin + (* all non-strings are emitted as + preprocessor # defines *) + write(undef); + printid(sp^.lid); + writeln + end; + tp := tp^.tnext + end + end; (* edconst *) + + (* Emit a typedef. *) procedure etypedef; *************** *** 7867,7876 **** ncase: begin indent; ! write('switch ('); increment; eexpr(tp^.tcasxp); ! writeln(') {'); decrement; echoise(tp^.tcaslst); indent; --- 7961,7970 ---- ncase: begin indent; ! write('switch ((int)('); increment; eexpr(tp^.tcasxp); ! writeln(')) {'); decrement; echoise(tp^.tcaslst); indent; *************** *** 8052,8058 **** indent; writeln(' case 0:'); indent; ! writeln(tab1, 'break'); tq := tp^.tsublab; while tq <> nil do begin --- 8146,8152 ---- indent; writeln(' case 0:'); indent; ! writeln(tab1, 'break;'); tq := tp^.tsublab; while tq <> nil do begin *************** *** 8071,8077 **** indent; writeln(' default:'); indent; ! writeln(tab1, 'Caseerror(Line)'); indent; writeln('}') end --- 8165,8171 ---- indent; writeln(' default:'); indent; ! writeln(tab1, 'Caseerror(Line);'); indent; writeln('}') end *************** *** 8198,8203 **** --- 8292,8298 ---- writeln(';'); end; decrement; + edconst(tp^.tsubconst); writeln('}'); 999: writeln; *************** *** 8337,8345 **** writeln(define, 'Putl(f, v) (f).eoln = v') end; if use(dreset) or use(drewrite) or use(dclose) then writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ', '(Putchr(', nlchr, ', f), 0) : 0, ', ! 'rewind((f).fp)'); (* LIB *) if use(dclose) then begin writeln(define, 'Close(f) (f).init = ', --- 8432,8443 ---- writeln(define, 'Putl(f, v) (f).eoln = v') end; if use(dreset) or use(drewrite) or use(dclose) then + begin writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ', '(Putchr(', nlchr, ', f), 0) : 0, ', ! '!fseek((f).fp, 0L, 0)'); (* LIB *) ! writeln(xtern, 'int', tab1, 'fseek();') (* LIB *) ! end; if use(dclose) then begin writeln(define, 'Close(f) (f).init = ', *************** *** 8359,8371 **** writeln(elsif); writeln(static, chartyp, tab1, 'Rmode[] = "r+";'); writeln(endif); ! writeln(define, 'Reset(f, n) (f).init = ', ! '(f).init ? rewind((f).fp) : ', (* LIB *) ! '(((f).fp = Fopen(n, Rmode)), 1), ', '(f).eof = (f).out = 0, Get(f)'); ! writeln(define, 'Resetx(f, n) (f).init = ', '(f).init ? (Finish(f)) : ', ! '(((f).fp = Fopen(n, Rmode)), 1), ', '(f).eof = (f).out = 0, Getx(f)'); usefopn := true end; --- 8457,8469 ---- writeln(elsif); writeln(static, chartyp, tab1, 'Rmode[] = "r+";'); writeln(endif); ! writeln(define, 'Reset(f, n, l) (f).init = ', ! '(f).init ? !fseek((f).fp, 0L, 0) : ', (* LIB *) ! '(((f).fp = Fopen(n, l, Rmode)), 1), ', '(f).eof = (f).out = 0, Get(f)'); ! writeln(define, 'Resetx(f, n, l) (f).init = ', '(f).init ? (Finish(f)) : ', ! '(((f).fp = Fopen(n, l, Rmode)), 1), ', '(f).eof = (f).out = 0, Getx(f)'); usefopn := true end; *************** *** 8376,8388 **** writeln(elsif); writeln(static, chartyp, tab1, 'Wmode[] = "w+";'); writeln(endif); ! writeln(define, 'Rewrite(f, n) (f).init = ', ! '(f).init ? rewind((f).fp) : ', (* LIB *) ! '(((f).fp = Fopen(n, Wmode)), 1), ', '(f).out = (f).eof = 1'); ! writeln(define, 'Rewritex(f, n) (f).init = ', '(f).init ? (Finish(f)) : ', ! '(((f).fp = Fopen(n, Wmode)), 1), ', '(f).out = (f).eof = (f).eoln = 1'); usefopn := true end; --- 8474,8486 ---- writeln(elsif); writeln(static, chartyp, tab1, 'Wmode[] = "w+";'); writeln(endif); ! writeln(define, 'Rewrite(f, n, l) (f).init = ', ! '(f).init ? !fseek((f).fp, 0L, 0) : ', (* LIB *) ! '(((f).fp = Fopen(n, l, Wmode)), 1), ', '(f).out = (f).eof = 1'); ! writeln(define, 'Rewritex(f, n, l) (f).init = ', '(f).init ? (Finish(f)) : ', ! '(((f).fp = Fopen(n, l, Wmode)), 1), ', '(f).out = (f).eof = (f).eoln = 1'); usefopn := true end; *************** *** 8389,8395 **** if usefopn then begin writeln('FILE *Fopen();'); ! writeln(define, 'MAXFILENAME 256') end; if usecase or usejmps then begin --- 8487,8495 ---- if usefopn then begin writeln('FILE *Fopen();'); ! writeln(ifndef, maxfilename); ! writeln(define, maxfilename, ' ', (maxtoknlen+1):1); ! writeln(endif) end; if usecase or usejmps then begin *************** *** 8443,8449 **** write(' ('); printid(defnams[dboolean]^.lid); writeln(')1'); ! writeln(xtern, chartyp, tab1, '*Bools[];') end; capital(defnams[dinteger]); if use(dinteger) then --- 8543,8549 ---- write(' ('); printid(defnams[dboolean]^.lid); writeln(')1'); ! writeln(chartyp, tab1, '*Bools[];') end; capital(defnams[dinteger]); if use(dinteger) then *************** *** 8519,8527 **** writeln(setptyp, tab1, 'Insmem(), Mksubr();'); writeln(setptyp, tab1, 'Currset(), Inter();'); writeln(static, setptyp, tab1, 'Tmpset;'); ! writeln(xtern, setptyp, tab1, 'Conset[];'); writeln(voidtyp, tab1, 'Setncpy();') end; writeln(xtern, chartyp, ' *strncpy();'); (* LIB *) if use(dargc) or use(dargv) then begin --- 8619,8640 ---- writeln(setptyp, tab1, 'Insmem(), Mksubr();'); writeln(setptyp, tab1, 'Currset(), Inter();'); writeln(static, setptyp, tab1, 'Tmpset;'); ! writeln(setptyp, tab1, 'Conset[];'); writeln(voidtyp, tab1, 'Setncpy();') end; + if align then (* CPU *) + begin + writeln(ifndef, 'SETALIGN'); + writeln(define, 'SETALIGN(x) Alignset(x)'); + writeln('struct Set { ', wordtype, tab1, 'S[', + maxsetrange:1, '+1]; } *Alignset();'); + writeln(endif); + writeln(ifndef, 'STRALIGN'); + writeln(define, 'STRALIGN(x) Alignstr(x)'); + writeln('struct String { char A[', + maxtoknlen:1, '+1]; } *Alignstr();'); + writeln(endif) + end; writeln(xtern, chartyp, ' *strncpy();'); (* LIB *) if use(dargc) or use(dargv) then begin *************** *** 8577,8589 **** --- 8690,8711 ---- writeln('main()'); writeln('{') end; + if use(dinput) then + begin + writeln(ifdef, 'STDINIT'); + writeln(tab1, voidcast, '(Getx(input));'); + writeln(endif) + end; increment; elabel(tp); estmt(tp^.tsubstmt); indent; writeln('exit(0);'); + indent; + writeln('/', '* NOTREACHED *', '/'); decrement; writeln('}'); + edconst(tp^.tsubconst); writeln('/', '*'); writeln('** End of program code'); writeln('*', '/') *************** *** 8716,8725 **** conflag := false; setused := false; dropset := false; ! doarrow := 0; eprogram(top); if usebool then ! writeln(chartyp, tab1, '*Bools[] = { "false", "true" };'); if usescan then begin writeln; --- 8838,8848 ---- conflag := false; setused := false; dropset := false; ! doarrow := false; ! donearr := false; eprogram(top); if usebool then ! writeln(static, chartyp, tab1, '*Bools[] = { "false", "true" };'); if usescan then begin writeln; *************** *** 8749,8770 **** begin writeln; writeln(static, 'FILE *'); ! writeln('Fopen(n, m)'); writeln(chartyp, tab1, '*n, *m;'); writeln('{'); writeln(tab1, 'FILE', tab2, '*f;'); writeln(tab1, registr, chartyp, tab1, '*s;'); writeln(tab1, static, chartyp, tab1, 'ch = ', quote, 'A', quote, ';'); ! writeln(tab1, static, chartyp, tab1, 'tmp[MAXFILENAME];'); ! writeln(tab1, xtern , inttyp, tab1, 'unlink();'); (* OS *) writeln; writeln(tab1, 'if (n == NULL)'); writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);'); writeln(tab1, 'else {'); writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));'); writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ', ! spchr, ' || *s == ', nulchr, '; )'); writeln(tab3, '*s-- = ', nulchr, ';'); writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {'); writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ', --- 8872,8897 ---- begin writeln; writeln(static, 'FILE *'); ! writeln('Fopen(n, l, m)'); writeln(chartyp, tab1, '*n, *m;'); + writeln(inttyp, tab1, 'l;'); writeln('{'); writeln(tab1, 'FILE', tab2, '*f;'); writeln(tab1, registr, chartyp, tab1, '*s;'); writeln(tab1, static, chartyp, tab1, 'ch = ', quote, 'A', quote, ';'); ! writeln(tab1, static, chartyp, tab1, 'tmp[', maxfilename, '];'); ! writeln(tab1, xtern , inttyp, tab1, 'unlink(),'); (* OS *) ! writeln(tab3, 'strlen();'); (* OS *) writeln; writeln(tab1, 'if (n == NULL)'); writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);'); writeln(tab1, 'else {'); + writeln(tab2, 'if (l < 0)'); + writeln(tab3, 'l = strlen(n);'); writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));'); writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ', ! spchr, ' || *s == ', nulchr, ' || s - tmp > l; )'); writeln(tab3, '*s-- = ', nulchr, ';'); writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {'); writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ', *************** *** 8782,8788 **** writeln(tab2, 'unlink(tmp);'); (* OS *) writeln(tab1, 'return (f);'); writeln('}'); - writeln(xtern, inttyp, tab1, 'rewind();') end; if setcnt > 0 then econset(setlst, setcnt); --- 8909,8914 ---- *************** *** 9098,9106 **** writeln(tab2, '*S1++ = 0;'); writeln('}') end; ! if usecase then begin writeln; writeln(static, voidtyp); writeln('Caseerror(n)'); writeln(tab1, inttyp, tab1, 'n;'); --- 9224,9263 ---- writeln(tab2, '*S1++ = 0;'); writeln('}') end; ! if usesal then begin writeln; + writeln(static, 'struct Set *'); + writeln('Alignset(Sp)'); + writeln(tab1, registr, wordtype, tab1, '*Sp;'); + writeln('{'); + writeln(tab1, static, 'struct Set', tab1, 'tmp;'); + writeln(tab1, registr, wordtype, tab1, '*tp = tmp.S;'); + writeln(tab1, registr, inttyp, tab2, 'i = *Sp;'); + writeln; + writeln(tab1, 'while (i-- >= 0)'); + writeln(tab2, '*tp++ = *Sp++;'); + writeln(tab1, 'return (&tmp);'); + writeln('}') + end; + if usealig then + begin + writeln; + writeln(static, 'struct String *'); + writeln('Alignstr(Cp)'); + writeln(tab1, registr, chartyp, tab1, '*Cp;'); + writeln('{'); + writeln(tab1, static, 'struct String', tab1, 'tmp;'); + writeln(tab1, registr, chartyp, tab1, '*sp = tmp.A;'); + writeln; + writeln(tab1, 'while (*sp++ = *Cp++)'); + writeln(tab2, ';'); + writeln(tab1, 'return (&tmp);'); + writeln('}') + end; + if usecase or usejmps then + begin + writeln; writeln(static, voidtyp); writeln('Caseerror(n)'); writeln(tab1, inttyp, tab1, 'n;'); *************** *** 9108,9113 **** --- 9265,9271 ---- writeln(tab1, voidcast, 'fprintf(stderr, "Missing case limb: line %d\n", n);'); writeln(tab1, 'exit(1);'); + writeln(tab1, '/', '* NOTREACHED *', '/'); writeln('}') end; if usemax then *************** *** 9153,9158 **** --- 9311,9318 ---- t : pretyps; d : predefs; + hx : packed array [ 1 .. 16 ] of char; + (* Define names in ctable. *) procedure defname(cn : cnames; str : keyword); *************** *** 9328,9339 **** begin (* initialize *) lineno := 1; colno := 0; initstrstore; setlst := nil; setcnt := 0; ! hexdig := '0123456789ABCDEF'; symtab := nil; statlvl := 0; --- 9488,9501 ---- begin (* initialize *) lineno := 1; colno := 0; + pushed := false; initstrstore; setlst := nil; setcnt := 0; ! hx := '0123456789ABCDEF'; ! unpack(hx, hexdig, 0); symtab := nil; statlvl := 0; *************** *** 9366,9371 **** --- 9528,9535 ---- usecomp := false; usemax := false; + usealig := false; + usesal := false; for s := 0 to hashmax do idtab[s] := nil; *************** *** 9541,9546 **** --- 9705,9713 ---- defname(cungetc, 'ungetc '); (* LIB *) defname(cunion, 'union '); defname(cunlink, 'unlink '); (* OS *) + defname(cfseek, 'fseek '); (* LIB *) + defname(cgetchar, 'getchar '); (* LIB *) + defname(cputchar, 'putchar '); (* LIB *) defname(cunsigned, 'unsigned '); defname(cwrite, 'write '); (* OS *) *************** *** 9613,9619 **** describing type, fill in constant identifying type *) case t of tboolean: ! typnods[t] := deftab[dboolean]; (* scalar type *) tchar: typnods[t] := deftab[dchar]^.tbind; tinteger: --- 9780,9786 ---- describing type, fill in constant identifying type *) case t of tboolean: ! typnods[t] := deftab[dboolean]^.tbind; tchar: typnods[t] := deftab[dchar]^.tbind; tinteger: SHAR_EOF fi # end of overwriting check # End of shell archive exit 0