source: to-imperative/trunk/java/refal/refal/plus/Lexer.rf @ 3989

Last change on this file since 3989 was 3831, checked in by yura, 12 years ago
  • It is needed to store default value in Collect_Errors_Box.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.2 KB
Line 
1// $Id: Lexer.rf 3831 2008-07-01 08:38:36Z orlov $
2
3//X/$functor Lexer (Stream : IndexedStream);
4//X/$module Err = Stream-Error (Stream);
5//X/$use Err;
6$use "IndexedStream";
7$use "Stream";
8$use "StreamErr";
9$use "internal.Lexer";
10
11$use Arithm Box Class Compare Convert;
12
13
14//$box Collect_Errors_Box; Defined in internal.Lexer
15/*
16 * A number.  Initially should be 0.
17 */
18
19//** $func  Start-Collect-Errors = ;
20//** $func  Stop-Collect-Errors  = ;
21//** $func? Collecting-Errors?   = ;
22
23Start_Collect_Errors =
24  <Get &Collect_Errors_Box> : s.num,
25  <Store &Collect_Errors_Box <Add s.num 1>>;
26
27Stop_Collect_Errors =
28  <Get &Collect_Errors_Box> : {
29    0;
30    s.num = <Store &Collect_Errors_Box <Sub s.num 1>>;
31  };
32
33IsCollecting_Errors = # \{ <Get &Collect_Errors_Box> : 0; };
34
35
36
37$func? IsBlank term = ;
38
39IsBlank \{ ' '; '\t'; '\n'; '\r'; };
40
41IsSkip_Blank stream = <Get_While stream &IsBlank> : v;
42
43
44IsSkip_Comment stream =
45  { # <IsCollecting_Errors> = <Clear_Errors>;; },
46  <Getc stream> : {
47    '*' = <Get_Line stream> : e;
48    '/' =
49      <Current_Pos stream> :: t.pos,
50      {
51        <Getc stream> : {
52          '/' = <Get_Line stream> : e;
53          '*' =
54            $iter {
55              <Get_Delim stream '*'> : v, {
56                <Getc stream> : {
57                  '/' = Stop;
58                  t;
59                };
60                <Error_At t.pos "Unclosed comment">, Stop;
61              };
62              <Error_At t.pos "Unclosed comment">, Stop;
63            } :: e.Isstop,
64            e.Isstop : Stop;
65          t1  =
66            <Error stream "Invalid character '" t1 "'">,
67            $fail;
68        };
69        <Error_At t.pos "Unexpected end of file"> = $fail;
70      };
71    t1  = <Ungets stream t1>, $fail;
72  };
73
74
75$func? IsVar_Sym term = ;
76
77IsVar_Sym sym =
78  \{
79    <IsLetter sym>;
80    <IsDigit sym>;
81    '-?!' : e sym e;
82  };
83
84
85IsScan_Keyword stream =
86  <Getc stream> : {
87    '$';
88    t1 = <Ungets stream t1>, $fail;
89  },
90  <Get_While stream &IsVar_Sym> :: e.ident,
91  {
92    <Get &Case_Insensitive> : 1 = <ToLower e.ident>;
93    e.ident;
94  } : {
95    'box' = BOX;
96    'channel' = CHANNEL;
97    'const' = CONST;
98    'error' = ERROR;
99    'fail' = FAIL;
100    'func' = FUNC;
101    'func?' = "FUNC?";
102    'iter' = ITER;
103    'l' = L;
104    'r' = R;
105    'string' = STRING;
106    'table' = TABLE;
107    'trace' = TRACE;
108    'traceall' = TRACEALL;
109    'trap' = TRAP;
110    'use' = USE;
111    'vector' = VECTOR;
112    'with' = WITH;
113    e1 = <Ungets stream '$' e1>, $fail;
114  };
115
116
117IsScan_Number stream =
118  <Getc stream> : s.first,
119  {
120    <IsDigit s.first>;
121    s.first : \{ '+'; '-'; };
122    <Ungets stream s.first> = $fail;
123  },
124  NUMBER s.first <Get_While stream &IsDigit>;
125
126
127IsScan_Variable stream =
128  <Getc stream> : {
129    's', SVAR;
130    'e', EVAR;
131    'v', VVAR;
132    't', TVAR;
133    t1 = <Ungets stream t1>, $fail;
134  } :: s.type,
135  <Getc stream> : {
136    '.' = <Get_While stream &IsVar_Sym>;
137    s1, <IsVar_Sym s1> = s1 <Get_While stream &IsVar_Sym>;
138    t1 = <Ungets stream t1>, /*empty*/;
139  } :: e.name,
140  {
141//    e.name : /*empty*/ =
142//      s.type '!!tmp-' <To-Chars <Name stream> '-' <Row stream> '-' <Column stream>>;
143    s.type e.name;
144  };
145
146
147$func? IsUppercase_Letter s.letter = ;
148$func? IsFun_Sym term = ;
149
150IsScan_Identifier stream =
151  <Getc stream> : s.first,
152  {
153    \{
154      <IsUppercase_Letter s.first>;
155      '_' : s.first;
156    } =
157      WORD s.first <Get_While stream &IsFun_Sym>;
158    <Ungets stream s.first> = $fail;
159  };
160
161IsUppercase_Letter s.letter =
162  <IsLetter s.letter>,
163  <Eq (<ToUpper s.letter>) (s.letter)>;
164
165IsFun_Sym sym =
166  \{
167    <IsLetter sym>;
168    <IsDigit sym>;
169    '_.' : e sym e;
170  };
171
172
173$func Scan_String_Rest t.pos s.max s.term stream = e.characters;
174
175IsScan_Quoted_Word stream =
176  { # <IsCollecting_Errors> = <Clear_Errors>;; },
177  <Current_Pos stream> :: t.pos,
178  <Getc stream> : {
179    '\"' = QWORD <Scan_String_Rest t.pos -1 '\"' stream>;
180    t1   = <Ungets stream t1>, $fail;
181  };
182
183IsScan_String stream =
184  { # <IsCollecting_Errors> = <Clear_Errors>;; },
185  <Current_Pos stream> :: t.pos,
186  <Getc stream> : {
187    '\'' = SYMBOLS <Scan_String_Rest t.pos -1 '\'' stream>;
188    t1   = <Ungets stream t1>, $fail;
189  };
190
191IsScan_Char stream =
192  { # <IsCollecting_Errors> = <Clear_Errors>;; },
193  <Current_Pos stream> :: t.pos,
194  <Getc stream> : {
195    '\'' =
196      <Scan_String_Rest t.pos 1 '\'' stream> : {
197        v.str =
198          <Ungets stream '\''>,
199          SYMBOLS v.str;
200        empty =
201          SYMBOLS /*empty*/;
202      };
203    t1   = <Ungets stream t1>, $fail;
204  };
205
206Scan_String_Rest t.pos s.max s.term stream =
207  (/*e.s*/) s.max $iter {
208    <Getc stream> : {
209      s.term = (e.s) 0;
210      '\\' = {
211        <Getc stream> : {
212          'n'  = (e.s '\n') <Sub s.max 1>;
213          't'  = (e.s '\t') <Sub s.max 1>;
214//          'v'  = (e.s '\v') <Sub s.max 1>;
215          'b'  = (e.s '\b') <Sub s.max 1>;
216          'r'  = (e.s '\r') <Sub s.max 1>;
217          'f'  = (e.s '\f') <Sub s.max 1>;
218          '\\' = (e.s '\\') <Sub s.max 1>;
219          '\'' = (e.s '\'') <Sub s.max 1>;
220          '\"' = (e.s '\"') <Sub s.max 1>;
221          '\n' = (e.s) s.max;
222          s1   =
223            <Error stream "Unknown control sequence '\\" s1 "'">,
224            (e.s s1) <Sub s.max 1>;
225          t1   =
226            <Error stream "Bad symbol '" t1 "'">, (e.s) s.max;
227        };
228        <Error_At t.pos "Unclosed quotes">, (e.s) 0;
229      };
230      '\n' = (e.s '\n') <Sub s.max 1>; //FIXME: should be option-controlled!
231      s1 = (e.s s1) <Sub s.max 1>;
232      t1 = <Error stream "Invalid character '" t1 "'">, (e.s) s.max;
233    };
234    <Error_At t.pos "Unclosed quotes">, (e.s) 0;
235  } :: (e.s) s.max,
236  s.max : 0 =
237  e.s;
238
239
240$box Parenth_Level;
241
242$func? Read_Term_Aux stream = term;
243
244IsRead_Term stream =
245  <Start_Collect_Errors>,
246  <Store &Parenth_Level 0>,
247  {
248    <Read_Term_Aux stream> :: term =
249      <Stop_Collect_Errors>,
250      term;
251    <Stop_Collect_Errors> = $fail;
252  };
253
254Read_Term_Aux stream =
255  $iter {
256    <IsSkip_Blank stream>;
257    <IsSkip_Comment stream>;
258    Stop;
259  } :: e.Isstop,
260  e.Isstop : Stop =
261  \{
262    <Current_Pos stream> :: t.pos,
263      <Getc stream> : \{
264        '(' =
265          <Get &Parenth_Level> : s.level,
266          <Store &Parenth_Level <Add s.level 1>>,
267          /*e.terms*/ (/*e.last*/) $iter {
268            e.terms e.last (<Read_Term_Aux stream>);
269            <Error_At t.pos "Unclosed parentheses"> = $fail;
270          } :: e.terms (e.last),
271          <Get &Parenth_Level> : s.level =
272          (e.terms);
273        ')' =
274          <Get &Parenth_Level> : s.level,
275          {
276            <Gt (s.level) (0)> =
277              <Store &Parenth_Level <Sub s.level 1>>,
278              ("Time-To-Close-Parentheses");
279            <Error stream "Unexpected right parenthesis"> = $fail;
280          };
281        t1, <Ungets stream t1>, $fail;
282      };
283    \{
284      <IsScan_Identifier  stream>;
285      <IsScan_Quoted_Word stream>;
286      <IsScan_Char        stream>;
287      <IsScan_Number      stream>;
288    } : s.type e.value,
289      s.type : {
290        WORD =
291          {
292            <Get &Case_Insensitive> : 1 = <ToWord <ToUpper e.value>>;
293            <ToWord e.value>;
294          };
295        QWORD = <ToWord e.value>;
296        SYMBOLS =
297          \{
298            e.value : symbol, symbol;
299            <Read_Term_Aux stream>;
300          };
301        NUMBER = <ToInt e.value>;
302      };
303    <Getc stream> : t1 =
304      <Error stream "Invalid character '" t1 "'">,
305      <Read_Term_Aux stream>;
306  };
307
Note: See TracBrowser for help on using the repository browser.