source: to-imperative/trunk/compiler/rfpc.rf @ 897

Last change on this file since 897 was 897, checked in by orlov, 18 years ago
  • Include path in a C++ header-file name.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.5 KB
Line 
1//
2// Copyright (C) 1999, 2000 Refal+ Development Group
3//
4// Refal+ is free software; you can redistribute it and/or modify
5// it under the terms of the GNU General Public License as published by
6// the Free Software Foundation; either version 2 of the License, or
7// (at your option) any later version.
8//
9// Refal+ is distributed in the hope that it will be useful,
10// but WITHOUT ANY WARRANTY; without even the implied warranty of
11// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12// GNU General Public License for more details.
13//
14// You should have received a copy of the GNU General Public License
15// along with Refal+; if not, write to the Free Software
16// Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
17//
18// $Source$
19// $Revision: 897 $
20// $Date: 2003-06-29 19:11:31 +0000 (Sun, 29 Jun 2003) $
21
22// rfpc.rfi
23$use "rfp_src"; // rfp_src.rfi
24$use "rfp_err"; // rfp_err.rfi
25$use "rfp_lex"; // rfp_lex.rfi
26$use "rfp_parse"; // rfp_parse.rfi
27$use "rfp_compile"; // rfp_compile.rfi
28$use "rfp_asail"; //rfp_asail.rfi
29$use "rfp_as2as";
30$use "rfp_check";
31$use "rfp_helper";
32$use "rfp_format";
33$use "rfp_asail_optim"; //rfp_asail_optim.rfi
34
35$use StdIO;
36$use Box;
37$use Dos;
38$use Arithm;
39$use Table;
40$use Convert;
41$use Class;
42$use Access;
43$use Compare;
44
45// information about available compiler options
46$box Options;
47
48// put information about compiler options in the &Options box
49$func Init-Options = ;
50
51// display help screen
52$func Display-Help = ;
53
54$func RFP-Parse-Args (e.files) (e.prevarg) s.index = e.files;
55$func RFP-Set-Path = ;
56
57// initialize tables
58$func Get-Ready-To-Work e.Items = ;
59
60$func CPP-Pretty-Print s.inner-call? s.channel (e.indent) e.expr = ;
61
62// print information about compilation stages when -verbose option was
63// supplied on command line
64$func Verbose e.string = ;
65
66$func Open-Channel e.name (e.ext) = s.channel s.need-close?;
67
68$func Find-Includes = e.includes;
69
70
71Main =
72  <Init-Options>,
73  <RFP-Parse-Args () () 1> :: e.files,
74  <RFP-Set-Path>,
75  <Store &Error-Counter 0>,
76  <Store &Warning-Counter 0>,
77//  <PrintLN e.files>,
78  e.files : {
79    /*empty*/ =
80      {
81        <In-Table? &RFP-Options HELP>;
82        <PrintLN 'Refal+ compiler bla-bla-bla'>,
83          'Usage: rfpc' :: e.start,
84          <Length e.start> :: s.st-len,
85          <Print e.start>,
86          <Box> :: s.len,
87          <Store s.len s.st-len>,
88          {
89            <? &Options> : e (((e.next) e) t e.descr) e,
90              {
91                e.descr : (e.arg) e = ' [-' e.next ' <' e.arg '>]';
92                ' [-' e.next ']';
93              } :: e.next,
94              <Length e.next> :: s.n-len,
95              <"+" <To-Int <? s.len>> s.n-len> :: s.new,
96              {
97                <">" (s.new) (70)> =
98                  <Store s.len <"+" s.st-len s.n-len>>,
99                  <PrintLN>,
100                  <Print <Repeat s.st-len ' '>>;
101                <Store s.len s.new>;
102              },
103              <Print e.next>,
104              $fail;
105            <PrintLN ' file ...'>;
106          },
107          <PrintLN>,
108          <PrintLN! &StdErr 'No input files specified'>;
109      };
110    e01 (e.file) e02,
111      {
112        e.file : $r e.basename '.' e.ext = e.basename (' .' e.ext);
113        e.file ();
114      } :: e.in-basename (e.ext),
115      {
116        e01 : /*empty*/, <Lookup &RFP-Options NAME>;
117        e.in-basename;
118      } :: e.basename,
119      {
120        <Channel? e.basename> = e.in-basename;
121        e.basename;
122      } :: e.headname,
123      <Subst (&RFP-Dir-Separator) (('__')) e.headname> :: e.headname,
124      {
125        e.ext : \{ ' .rf'; ' .rfi'; } =
126          <Verbose "parsing started">,
127          <RFP-Lexer e.file> :: e.tokens,
128          <Store &RFP-Token-Stack e.tokens>,
129          <RFP-Parser> :: t.as,
130          <Verbose "parsing finished">,
131          AS-REFAL t.as;
132        e.ext : ' .asr' =
133          <Channel> :: s.channel,
134          <Open-File s.channel e.file R>,
135          AS-REFAL <Read! s.channel>;
136        e.ext : ' .ast' =
137          <Channel> :: s.channel,
138          <Open-File s.channel e.file R>,
139          AS-TRANSFORMED <Read! s.channel>;
140        e.ext : ' .asi' =
141          <Channel> :: s.channel,
142          <Open-File s.channel e.file R>,
143          AS-AIL (AS-AIL AS-AIL <Read! s.channel> <Read! s.channel>);
144        <PrintLN! &StdErr "Error: unknown extension" e.ext " in " e.file> = $fail;
145      } : s.type (s.tag t.ModuleName e.Items),
146      {
147        s.type : AS-AIL;
148        <Get-Ready-To-Work e.Items>;
149      },
150      s.type e.Items $iter s.type : {
151        AS-REFAL =
152          {
153            <In-Table? &RFP-Options AS-REFAL> =
154              <Open-Channel e.basename ('.asr')> :: s.channel s.need-close?,
155              <RFP-Pretty-Print s.channel () (s.tag t.ModuleName e.Items)>,
156              { s.need-close? : 1 = <Close-Channel s.channel>;; };;
157          },
158          <? &Error-Counter> : 0,
159          {
160            <In-Table? &RFP-Options NO-CHECK>;
161            <Verbose "syntax check started">,
162              <RFP-Check e.Items>,
163              <Verbose "syntax check finished"> =
164              <? &Error-Counter> : 0;
165          },
166          \{
167            <In-Table? &RFP-Options CC>;
168            <In-Table? &RFP-Options AS-AIL>;
169            <In-Table? &RFP-Options AS-TRANSFORMED>;
170            <In-Table? &RFP-Options HH>;
171          },
172          {
173            <In-Table? &RFP-Options NO-TRANSFORM> = e.Items;
174            <Verbose "as-to-as transformation started">,
175              <RFP-As2As-Transform e.Items> :: e.Items,
176              <Verbose "as-to-as transformation finished">,
177              e.Items;
178          } :: e.Items,
179          AS-TRANSFORMED e.Items;
180        AS-TRANSFORMED =
181          {
182            <In-Table? &RFP-Options AS-TRANSFORMED> =
183              <Open-Channel e.basename ('.ast')> :: s.channel s.need-close?,
184              <RFP-Pretty-Print s.channel () (s.tag t.ModuleName e.Items)>,
185              { s.need-close? : 1 = <Close-Channel s.channel>;; };;
186          },
187          \{
188            <In-Table? &RFP-Options CC>;
189            <In-Table? &RFP-Options AS-AIL>;
190            <In-Table? &RFP-Options HH>;
191          },
192          <Verbose "compilation to abstract imperative language started">,
193          <RFP-Compile e.Items> : (INTERFACE e.interf) (MODULE e.module),
194          <Verbose "compilation to abstract imperative language finished">,
195          AS-AIL
196          (INTERFACE t.ModuleName e.interf) (MODULE t.ModuleName e.module);
197        AS-AIL =
198          {
199            <In-Table? &RFP-Options AS-AIL> =
200              <Open-Channel e.basename ('.asi')> :: s.channel s.need-close?,
201              {
202                e.Items : e t.item e,
203                  <RFP-Pretty-Print s.channel () t.item>,
204                  $fail;;
205              },
206              { s.need-close? : 1 = <Close-Channel s.channel>;; };;
207          },
208          \{
209            <In-Table? &RFP-Options HH>,
210              e.Items : (INTERFACE t.asail-mod-name v.headers) e,
211              <Verbose "headers generation started">,
212              <RFP-ASAIL-To-CPP t.asail-mod-name v.headers> :: e.headers,
213              <Verbose "headers generation finished">,
214              <Open-Channel e.basename ('.hh')> :: s.channel s.need-close?,
215              <PrintLN! s.channel '#ifndef __' e.headname '_hh__'>,
216              <PrintLN! s.channel '#define __' e.headname '_hh__'>,
217              <PrintLN! s.channel '\n#include <rf_core.hh>'>,
218              <CPP-Pretty-Print 0 s.channel () e.headers>,
219              <PrintLN! s.channel '\n#endif // __' e.headname '_hh__'>,
220              { s.need-close? : 1 = <Close-Channel s.channel>;; },
221              $fail;
222            <In-Table? &RFP-Options CC>,
223              e.Items : e (MODULE t.asail-mod-name v.module),
224              {
225                <In-Table? &RFP-Options NO-OPTIM> = v.module;
226                <Verbose "optimization as-ail started">,
227                  <ASAIL-Optim v.module> :: e.module,
228                  <Verbose "optimization as-ail finished"> =
229                  e.module;
230              } :: e.module ,
231              <Verbose "compilation from as-ail to c++ started">,
232              <RFP-ASAIL-To-CPP t.asail-mod-name e.module> :: e.module,
233              <Verbose "compilation from as-ail to c++ finished">,
234              <Open-Channel e.basename ('.cc')> :: s.channel s.need-close?,
235              <PrintLN! s.channel '#include <rf_core.hh>'>,
236              {
237                <Find-Includes> : e (e.include) e,
238                  <PrintLN! s.channel '#include ' e.include>,
239                  $fail;;
240              },
241              <CPP-Pretty-Print 0 s.channel () e.module>,
242              { s.need-close? : 1 = <Close-Channel s.channel>;; },
243              $fail;
244          };
245      } :: s.type e.Items,
246      $fail;
247    e.all-files-have-gone;
248  };
249
250Init-Options = <Store &Options
251  ((('I') ('ipath')) IPATH
252    ('dir') "add <dir> to the list of directories to be searched" "for .rfi files")
253  ((('ne') ('no-elaborate')) (BIND NO-ELABORATE))
254  ((('nc') ('no-check')) (BIND NO-CHECK)
255    "don't perform syntax check")
256  ((('nt') ('no-transform')) (BIND NO-TRANSFORM)
257    "don't perform AS-to-AS transformations")
258  ((('c') ('check')) (BIND CHECK)
259    "check only, causes no file creation in the absence"
260    "of other output control options")
261  ((('ci') ('comp-item')) COMP-ITEM
262    ('item') "compile <item> only, not the whole source" "(may be used several times)")
263  ((('h') ('help')) HELP /*"display this help screen"*/)
264  ((('v') ('verbose')) (BIND VERBOSE)
265    "display information about the stages of compilation")
266  ((('u')) (BIND CASE-INSENSITIVE)
267    "convert all symbol-words without surrounding quotes" "to upper case")
268  ((('o')) NAME
269    ('name| - ') "place outputs for file1 into files <name>.* or send" "them to stdout")
270  ((('cc')) (BIND CC)
271    "output C++ code")
272  ((('hh')) (BIND HH)
273    "generate header files")
274  ((('asr') ('as-refal')) (BIND AS-REFAL)
275    "output Refal Abstract Syntax")
276  ((('ast') ('as-transformed')) (BIND AS-TRANSFORMED)
277    "output Refal Abstract Syntax after AS-to-AS" "transformations")
278  ((('asi') ('as-ail')) (BIND AS-AIL)
279    "output Abstract Syntax of Abstract Imperative" "Language")
280  ((('d') ('debug')) (BIND DEBUG))
281  ((('no') ('no-optim')) (BIND NO-OPTIM) "don't perform ASAIL-optimization")
282>;
283
284Display-Help =
285  <Box> :: s.line,
286  '  ' :: e.start1,
287  27 :: s.2nd-col,
288  <Repeat s.2nd-col ' '> :: e.start2,
289  <PrintLN "Refal+ compiler bla-bla-bla">,
290  <PrintLN "Copyright bla-bla-bla">,
291  <PrintLN>,
292  <PrintLN "Usage: rfpc [options] file1 [file2 ...]">,
293  <PrintLN "Options:">,
294  {
295    <? &Options> : e (((e.op) e.opts) t e.descr) e,
296      <Store s.line e.start1 '-' e.op>,
297      {
298        e.opts : e (e.next) e,
299          <Put s.line ', -' e.next>,
300          $fail;;
301      },
302      {
303        e.descr : (e.param) e.rest =
304          <Put s.line ' <' e.param '>'>,
305          e.rest;
306        e.descr;
307      } : \{
308        s.phrase e,
309          <PrintLN
310            <? s.line>
311            <Repeat <"-" s.2nd-col <Length <? s.line>>> ' '>
312            s.phrase
313          >,
314          $fail;
315        e s s.phrase e,
316          <PrintLN e.start2 s.phrase>,
317          $fail;
318      };;
319  };
320
321RFP-Parse-Args (e.files) (e.prevarg) s.index =
322{
323  <Arg s.index> : v.arg, <"+" s.index 1> :: s.index =
324    {
325      e.prevarg : v, e.prevarg :
326        {
327          IPATH = <Store &RFP-Include-Path <? &RFP-Include-Path> (v.arg)>;
328          COMP-ITEM =
329            {
330              <Lookup &RFP-Options ITEMS>;
331              /*empty*/;
332            } :: e.items,
333            <Bind &RFP-Options (ITEMS) (e.items <Make-Name v.arg>)>;
334          NAME =
335            {
336              v.arg : '-' = &StdOut;
337              v.arg;
338            } :: v.arg,
339            <Bind &RFP-Options (NAME) (v.arg)>;
340        },
341        <RFP-Parse-Args (e.files) () s.index>;
342      v.arg : '-' e.opt =
343        {
344          \{
345            <? &Options> : e ((e (e.opt) e) t.action e) e = t.action;
346            e.opt : '-' e.o,
347              <? &Options> : e ((t e (e.o) e) t.action e) e = t.action;
348          } : {
349            (BIND s.option) = <Bind &RFP-Options (s.option) ()>;
350            HELP = <Bind &RFP-Options (HELP) ()>, <Display-Help>;
351            s.other = s.other;
352          } :: e.prevarg,
353            <RFP-Parse-Args (e.files) (e.prevarg) s.index>;
354          <PrintLN! &StdErr "Unknown option \"-" e.opt "\"">,
355            <RFP-Parse-Args (e.files) () s.index>;
356        };
357      <RFP-Parse-Args (e.files (v.arg)) () s.index>;
358    };
359  {
360    \{
361      <In-Table? &RFP-Options CC>;
362      <In-Table? &RFP-Options HH>;
363      <In-Table? &RFP-Options AS-REFAL>;
364      <In-Table? &RFP-Options AS-TRANSFORMED>;
365      <In-Table? &RFP-Options AS-AIL>;
366      <In-Table? &RFP-Options CHECK>;
367    };
368    <Bind &RFP-Options (CC) ()> <Bind &RFP-Options (HH) ()>;
369  },
370    e.files;
371};
372
373RFP-Set-Path =
374  {
375    <In-Table? &RFP-Options CASE-INSENSITIVE> = &RFP-Default-Ci-Include-Path;
376    &RFP-Default-Include-Path;
377  } :: e.def-path,
378  <Store &RFP-Include-Path <? &RFP-Include-Path> e.def-path>;
379
380Get-Ready-To-Work e.Items =
381  <RFP-Clear-Table &Fun>,
382  <RFP-Clear-Table &Fun?>,
383  <RFP-Clear-Table &Const>,
384  <RFP-Clear-Table &Object>,
385  {
386    e.Items : e t.Item e,
387      t.Item : (s.Linkage s.ItemType t.Pragma t.ItemName e.ItemBody),
388      s.ItemType : {
389        FUNC =
390          <Left 0 2 e.ItemBody> : (e.in) (e.out),
391          &Fun (<Format-Exp e.in>) (<Format-Exp e.out>);
392        FUNC? =
393          <Left 0 2 e.ItemBody> : (e.in) (e.out),
394          &Fun? (<Format-Exp e.in>) (<Format-Exp e.out>);
395        CONST = &Const e.ItemBody;
396        s = &Object e.ItemBody;
397      } :: s.tab e.ItemDef,
398      <Bind s.tab (t.ItemName) (s.Linkage s.ItemType t.Pragma e.ItemDef)>,
399      $fail;;
400  };
401
402RFP-Pretty-Print s.channel (e.indent) e.expr = e.expr :
403  {
404    e0 (e1) e2 =
405      <Write! s.channel e0>,
406      { e.indent : v = <PrintLN! s.channel>;; },
407      <Print! s.channel e.indent '('>,
408      <RFP-Pretty-Print s.channel (e.indent '  ') e1>,
409      {
410        e1 : e (e) e =
411          <PrintLN! s.channel>,
412          <Print! s.channel e.indent ')'>;
413        <Print! s.channel ')'>;
414      },
415      {
416        e2 : (e) e = ;
417        e2 : , e.indent : v = ;
418        <PrintLN! s.channel>, <Print! s.channel e.indent>;
419      },
420      <RFP-Pretty-Print s.channel (e.indent) e2>;
421    v1 =
422      <Write! s.channel v1>;
423    =;
424  };
425
426$const Tab = '  ';
427
428CPP-Pretty-Print s.inner-call? s.channel (e.indent) e.expr, e.expr : {
429  e0 (e1) e2 =
430    { s.inner-call? : 0 = <PrintLN! s.channel>;; },
431    {
432      e0 : /*empty*/, {
433        e1 : LABEL e.label =
434          e.indent : e.ind &Tab,
435          <PrintLN! s.channel e.ind e.label>;
436        <CPP-Pretty-Print 1 s.channel (e.indent) e1>;
437      };
438      <PrintLN! s.channel e.indent e0>,
439        <CPP-Pretty-Print 1 s.channel (e.indent &Tab) (e1)>;
440    },
441    <CPP-Pretty-Print s.inner-call? s.channel (e.indent) e2>;
442  v1 = <PrintLN! s.channel e.indent v1>;
443  /*empty*/ = /*empty*/;
444};
445
446Verbose e.string, {
447  <In-Table? &RFP-Options VERBOSE> =
448    <PrintLN <Time> ": " e.string>;;
449};
450
451Open-Channel {
452  symbol (e), <Channel? symbol> = symbol 0;
453  e.name (e.ext) =
454    <Channel> :: s.channel,
455    {
456      <Open-File s.channel e.name e.ext W> =
457        s.channel 0; // When we need to close channel ???
458      <PrintLN! &StdErr "Error: cannot open file " e.name e.ext " for writing">,
459        <Exit 1>, $fail;
460    };
461};
462
463Find-Includes =
464  <Box> :: s.includes,
465  {
466    <Domain &RFP-Sources> : e (s.idx) e,
467      <Lookup &RFP-Sources s.idx> : e.full-name '.rfi',
468      {
469        <? &RFP-Include-Path> : e (e.path) e,
470          e.full-name : e.path &RFP-Dir-Separator e.name =
471          <Put s.includes ('<refal/' e.name '.hh>')>;
472        <RFP-Dir-Name <RFP-Source-File-Name 1>> : e.path,
473          e.full-name : e.path &RFP-Dir-Separator e.name =
474          <Put s.includes ('"' e.name '.hh"')>;
475        <Put s.includes ('"' e.full-name '.hh"')>;
476      },
477      $fail;;
478  },
479  <? s.includes>;
480
Note: See TracBrowser for help on using the repository browser.