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

// $Id: Lexer.rf 3615 2008-03-29 22:19:28Z yura $

//X/$functor Lexer (Stream : IndexedStream);
//X/$module Err = Stream-Error (Stream);
//X/$use Err;
$use "IndexedStream";
$use "Stream";
$use "StreamErr";

$use Arithm Box Class Compare Convert;


$box Collect_Errors_Box;
/*
 * A number.  Initially should be 0.
 */

//** $func  Start-Collect-Errors = ;
//** $func  Stop-Collect-Errors  = ;
//** $func? Collecting-Errors?   = ;

Start_Collect_Errors =
  <Get &Collect_Errors_Box> : s.num,
  <Store &Collect_Errors_Box <Add s.num 1>>;

Stop_Collect_Errors =
  <Get &Collect_Errors_Box> : {
    0;
    s.num = <Store &Collect_Errors_Box <Sub s.num 1>>;
  };

IsCollecting_Errors = # \{ <Get &Collect_Errors_Box> : 0; };



$func? IsBlank term = ;

IsBlank \{ ' '; '\t'; '\n'; '\r'; };

IsSkip_Blank stream = <Get_While stream &IsBlank> : v;


IsSkip_Comment stream =
  { # <IsCollecting_Errors> = <Clear_Errors>;; },
  <Getc stream> : {
    '*' = <Get_Line stream> : e;
    '/' =
      <Current_Pos stream> :: t.pos,
      {
        <Getc stream> : {
          '/' = <Get_Line stream> : e;
          '*' =
            $iter {
              <Get_Delim stream '*'> : v, {
                <Getc stream> : {
                  '/' = Stop;
                  t;
                };
                <Error_At t.pos "Unclosed comment">, Stop;
              };
              <Error_At t.pos "Unclosed comment">, Stop;
            } :: e.Isstop,
            e.Isstop : Stop;
          t1  =
            <Error stream "Invalid character '" t1 "'">,
            $fail;
        };
        <Error_At t.pos "Unexpected end of file"> = $fail;
      };
    t1  = <Ungets stream t1>, $fail;
  };


$func? IsVar_Sym term = ;

IsVar_Sym sym =
  \{
    <IsLetter sym>;
    <IsDigit sym>;
    '-?!' : e sym e;
  };


IsScan_Keyword stream =
  <Getc stream> : {
    '$';
    t1 = <Ungets stream t1>, $fail;
  },
  <Get_While stream &IsVar_Sym> :: e.ident,
  {
    <Get &Case_Insensitive> : 1 = <ToLower e.ident>;
    e.ident;
  } : {
    'box' = BOX;
    'channel' = CHANNEL;
    'const' = CONST;
    'error' = ERROR;
    'fail' = FAIL;
    'func' = FUNC;
    'func?' = "FUNC?";
    'iter' = ITER;
    'l' = L;
    'r' = R;
    'string' = STRING;
    'table' = TABLE;
    'trace' = TRACE;
    'traceall' = TRACEALL;
    'trap' = TRAP;
    'use' = USE;
    'vector' = VECTOR;
    'with' = WITH;
    e1 = <Ungets stream '$' e1>, $fail;
  };


IsScan_Number stream =
  <Getc stream> : s.first,
  {
    <IsDigit s.first>;
    s.first : \{ '+'; '-'; };
    <Ungets stream s.first> = $fail;
  },
  NUMBER s.first <Get_While stream &IsDigit>;


IsScan_Variable stream =
  <Getc stream> : {
    's', SVAR;
    'e', EVAR;
    'v', VVAR;
    't', TVAR;
    t1 = <Ungets stream t1>, $fail;
  } :: s.type,
  <Getc stream> : {
    '.' = <Get_While stream &IsVar_Sym>;
    s1, <IsVar_Sym s1> = s1 <Get_While stream &IsVar_Sym>;
    t1 = <Ungets stream t1>, /*empty*/;
  } :: e.name,
  {
//    e.name : /*empty*/ =
//      s.type '!!tmp-' <To-Chars <Name stream> '-' <Row stream> '-' <Column stream>>;
    s.type e.name;
  };


$func? IsUppercase_Letter s.letter = ;
$func? IsFun_Sym term = ;

IsScan_Identifier stream =
  <Getc stream> : s.first,
  {
    \{
      <IsUppercase_Letter s.first>;
      '_' : s.first;
    } =
      WORD s.first <Get_While stream &IsFun_Sym>;
    <Ungets stream s.first> = $fail;
  };

IsUppercase_Letter s.letter =
  <IsLetter s.letter>,
  <Eq (<ToUpper s.letter>) (s.letter)>;

IsFun_Sym sym =
  \{
    <IsLetter sym>;
    <IsDigit sym>;
    '_.' : e sym e;
  };


$func Scan_String_Rest t.pos s.max s.term stream = e.characters;

IsScan_Quoted_Word stream =
  { # <IsCollecting_Errors> = <Clear_Errors>;; },
  <Current_Pos stream> :: t.pos,
  <Getc stream> : {
    '\"' = QWORD <Scan_String_Rest t.pos -1 '\"' stream>;
    t1   = <Ungets stream t1>, $fail;
  };

IsScan_String stream =
  { # <IsCollecting_Errors> = <Clear_Errors>;; },
  <Current_Pos stream> :: t.pos,
  <Getc stream> : {
    '\'' = SYMBOLS <Scan_String_Rest t.pos -1 '\'' stream>;
    t1   = <Ungets stream t1>, $fail;
  };

IsScan_Char stream =
  { # <IsCollecting_Errors> = <Clear_Errors>;; },
  <Current_Pos stream> :: t.pos,
  <Getc stream> : {
    '\'' =
      <Scan_String_Rest t.pos 1 '\'' stream> : {
        v.str =
          <Ungets stream '\''>,
          SYMBOLS v.str;
        empty =
          SYMBOLS /*empty*/;
      };
    t1   = <Ungets stream t1>, $fail;
  };

Scan_String_Rest t.pos s.max s.term stream =
  (/*e.s*/) s.max $iter {
    <Getc stream> : {
      s.term = (e.s) 0;
      '\\' = {
        <Getc stream> : {
          'n'  = (e.s '\n') <Sub s.max 1>;
          't'  = (e.s '\t') <Sub s.max 1>;
          'v'  = (e.s '\v') <Sub s.max 1>;
          'b'  = (e.s '\b') <Sub s.max 1>;
          'r'  = (e.s '\r') <Sub s.max 1>;
          'f'  = (e.s '\f') <Sub s.max 1>;
          '\\' = (e.s '\\') <Sub s.max 1>;
          '\'' = (e.s '\'') <Sub s.max 1>;
          '\"' = (e.s '\"') <Sub s.max 1>;
          '\n' = (e.s) s.max;
          s1   =
            <Error stream "Unknown control sequence '\\" s1 "'">,
            (e.s s1) <Sub s.max 1>;
          t1   =
            <Error stream "Bad symbol '" t1 "'">, (e.s) s.max;
        };
        <Error_At t.pos "Unclosed quotes">, (e.s) 0;
      };
      '\n' = (e.s '\n') <Sub s.max 1>; //FIXME: should be option-controlled!
      s1 = (e.s s1) <Sub s.max 1>;
      t1 = <Error stream "Invalid character '" t1 "'">, (e.s) s.max;
    };
    <Error_At t.pos "Unclosed quotes">, (e.s) 0;
  } :: (e.s) s.max,
  s.max : 0 =
  e.s;


$box Parenth_Level;

$func? Read_Term_Aux stream = term;

IsRead_Term stream =
  <Start_Collect_Errors>,
  <Store &Parenth_Level 0>,
  {
    <Read_Term_Aux stream> :: term =
      <Stop_Collect_Errors>,
      term;
    <Stop_Collect_Errors> = $fail;
  };

Read_Term_Aux stream =
  $iter {
    <IsSkip_Blank stream>;
    <IsSkip_Comment stream>;
    Stop;
  } :: e.Isstop,
  e.Isstop : Stop =
  \{
    <Current_Pos stream> :: t.pos,
      <Getc stream> : \{
        '(' =
          <Get &Parenth_Level> : s.level,
          <Store &Parenth_Level <Add s.level 1>>,
          /*e.terms*/ (/*e.last*/) $iter {
            e.terms e.last (<Read_Term_Aux stream>);
            <Error_At t.pos "Unclosed parentheses"> = $fail;
          } :: e.terms (e.last),
          <Get &Parenth_Level> : s.level =
          (e.terms);
        ')' =
          <Get &Parenth_Level> : s.level,
          {
            <Gt (s.level) (0)> =
              <Store &Parenth_Level <Sub s.level 1>>,
              ("Time-To-Close-Parentheses");
            <Error stream "Unexpected right parenthesis"> = $fail;
          };
        t1, <Ungets stream t1>, $fail;
      };
    \{
      <IsScan_Identifier  stream>;
      <IsScan_Quoted_Word stream>;
      <IsScan_Char        stream>;
      <IsScan_Number      stream>;
    } : s.type e.value,
      s.type : {
        WORD =
          {
            <Get &Case_Insensitive> : 1 = <ToWord <ToUpper e.value>>;
            <ToWord e.value>;
          };
        QWORD = <ToWord e.value>;
        SYMBOLS =
          \{
            e.value : symbol, symbol;
            <Read_Term_Aux stream>;
          };
        NUMBER = <ToInt e.value>;
      };
    <Getc stream> : t1 =
      <Error stream "Invalid character '" t1 "'">,
      <Read_Term_Aux stream>;
  };