RIGAL/rigdos/TOYLAN.RIG

#TOYLAN_COMPILER
   
    OPEN REP ' ';  --message file is connected with the screen
    $LEXEMS:=#CALL_PAS(35 'A.TOY');
     -- a list of tokens is loaded from the file A.TOY by scanner
    $S_TREE := #A_PROGRAM($LEXEMS);
    -- 1st  phase; result of parsing - abstract syntax tree - is
    -- imbedded in the variable $S_TREE; during parsing messages
    -- about discovered errors in file REP can be output.
    IF $S_TREE  ->  OPEN GEN 'A.BAL'; -- if the tree is created,
         -- then file is opened to output the generated BAL text
           #G_PROGRAM($S_TREE); -- 2nd phase-code generation
           #INTERPRETER($S_TREE) -- 2nd phase-code interpretation
    ELSIF  T  ->  REP << errors are discovered   FI;
    REP << end ##




#A_PROGRAM    -- the rule is applied to the list of tokens
    (. PROGRAM  $Id
         (*  $DECL++:= #A_DECLARATION  ';'  *)
                  --formation of variables table
          (+  $STATEMENTS !.:= #A_STATEMENT   + ';' )
                  --formation of statements list
    .)  / RETURN 'PROGRAM' :: <. NAME : $Id,
                                  DECLARATIONS : $DECL ,
                                  STATEMENTS : $STATEMENTS .>/ ##
#A_DECLARATION     $TYPE := ( INTEGER ! BOOLEAN )
  (+ $Id /IF LAST #A_PROGRAM $DECL.$Id OR $REZ.$Id ->
              REP << VARIABLE $Id DOUBLE DEFINED  FI;
           $REZ++:= <.$Id : $TYPE .>/  + ',' ) / RETURN $REZ / ##
#A_STATEMENT   $REZ := ( #A_ASSIGNMENT ! #A_INPUT !
               #A_OUTPUT ! #A_CONDITIONAL )  / RETURN $REZ / ;;

     (* $A!.:=S'($$ <> ';' ) *)   -- skip until nearest ';'
               / REP << UNRECOGNIZED STATEMENT $A /
##

#A_ASSIGNMENT $Id  ':='/ $LPType := LAST #A_PROGRAM $DECL .$Id;
        IF NOT $LPType  -> REP << VARIABLE $Id 'IS NOT DEFINED' FI /
    $E:= #A_EXPRESSION
         /IF $LPType <> $E . TYPE ->
              REP<< 'LEFT AND RIGHT SIDE TYPES ARE DIFFERENT '
                     'IN ASSIGNMENT STATEMENT ' FI;
         RETURN ASSIGNMENT::<. LEFT: $Id, RIGHT: $E .> /
 ONFAIL IF $LPType  -> REP<< 'WRONG EXPRESSION IN ASSIGNMENT'  FI  ##
#A_INPUT      GET  '('
    (+ $E !.:= $Id  /IF  LAST #A_PROGRAM $DECL.$Id <> INTEGER ->
            REP << $Id 'IN STATEMENT GET IS NOT OF THE TYPE INTEGER'
                      FI / + ',' ) ')' / RETURN INPUT :: $E /   ##
#A_OUTPUT   PUT  '(' (+  $C := #A_EXPRESSION  / $E !.:= $C;
              IF  $C . TYPE  <> INTEGER ->
        REP << 'OPERAND OF PUT STATEMENT IS NOT OF THE TYPE INTEGER'
                FI /   + ',' ) ')'/ RETURN OUTPUT :: $E /       ##
#A_CONDITIONAL     'IF' $BE := #A_EXPRESSION
    /IF $BE . TYPE <> BOOLEAN ->
              REP<< 'CONDITION IS NOT OF BOOLEAN TYPE' FI /
                   'THEN' (+ $P1 !.:= #A_STATEMENT + ';' )
         [ 'ELSE' (+ $P2 !.:= #A_STATEMENT + ';' ) ]      'FI'
    / RETURN CONDITIONAL :: <. COND : $BE , THEN : $P1 ,
                               ELSE : $P2  .> /            ##
#A_EXPRESSION      $A := #A_SUM   [  '=' $B := #A_SUM
    / $A := COMPARE::<. ARG1 : $A, ARG2 : $B, TYPE : BOOLEAN.>/ ]
    / RETURN $A /           ##
#A_SUM   $A := #A_FACTOR    (* '+' $B := #A_FACTOR
         / $A := ADD::<. ARG1: $A, ARG2: $B, TYPE: INTEGER .>/ *)
    / RETURN $A  /          ##
#A_FACTOR  $A := #A_TERM     (* '*' $B := #A_TERM
         /$A := MULT::<. ARG1: $A, ARG2: $B, TYPE: INTEGER .>/ *)
    / RETURN $A /           ##
#A_TERM
    $N  / RETURN <. CONSTANT : $N , TYPE : INTEGER .>/;;
  ( ( TRUE / $K :=1/ ) ! ( FALSE / $K :=0 / ) )
                 /RETURN <. CONSTANT: $K, TYPE: BOOLEAN .>/  ;;
    $Id  / $X:= LAST #A_PROGRAM $DECL.$Id;
         IF NOT $X  ->  REP << VARIABLE $Id IS NOT DECLARED
         ELSIF T -> RETURN <. VARIABLE: $Id, TYPE: $X .> FI / ;;
    '(' $E := #A_EXPRESSION ')' / RETURN $E /        ##


#INTERPRETER
  $P
 / $++:= <. VARIABLES : #CREATE_TABLE ($P.DECLARATIONS) .>;
--PRINT $;
   #I_PROGRAM ($);
PRINT $.VARIABLES;
 /
##
#CREATE_TABLE
 <* $Id : $Type / $Y ++ := <. $Id : 0 .> / *>
 / RETURN $Y /
##

#I_PROGRAM
 <. STATEMENTS : #I_STATEMENTS .>
##

#I_STATEMENTS (. (* #I_STATEMENT
/ PRINT LAST #INTERPRETER $.VARIABLES;
  #CALL_PAS(1) /
 *) .) ##
#I_STATEMENT
 ( #I_INPUT ! #I_OUTPUT ! #I_ASSIGNMENT ! #I_CONDITIONAL ) ##
#I_INPUT
  INPUT :: (. (* $Id
    /
     LAST #INTERPRETER $.VARIABLES.$Id:= 
         #CALL_PAS(1 'toylan>') /
  *) .)
##
#I_OUTPUT
  OUTPUT :: (. (* $E:= #I_EXPRESSION
   / REP << $E /
   *) .)
##

#I_ASSIGNMENT
  ASSIGNMENT :: <. LEFT : $Id,
                   RIGHT : $R:=#I_EXPRESSION
                .>
   / LAST #INTERPRETER $.VARIABLES.$Id:=$R/
##
#I_CONDITIONAL
  CONDITIONAL :: <. COND : $E:=#I_EXPRESSION .>
  / IF $E<>0 -> #I_STATEMENTS ($.THEN)
    ELSIF $.ELSE -> #I_STATEMENTS ($.ELSE)
    FI  /
##
#I_EXPRESSION
 <. CONSTANT : $N .> / RETURN $N /;;
 <. VARIABLE : $Id .> 
   / RETURN LAST #INTERPRETER $.VARIABLES.$Id/;;
 ADD:: <. ARG1 : $E1:=#I_EXPRESSION,
         ARG2 : $E2:=#I_EXPRESSION
       .>
      / RETURN $E1+$E2 /;;
 MULT:: <. ARG1 : $E1:=#I_EXPRESSION,
         ARG2 : $E2:=#I_EXPRESSION
       .>
      / RETURN $E1*$E2 /;;
 COMPARE:: <. ARG1 : $E1:=#I_EXPRESSION,
         ARG2 : $E2:=#I_EXPRESSION
       .> / IF $E1=$E2 -> RETURN 1 
            ELSIF T ->    RETURN 0
            FI/ ##


#G_PROGRAM    / $LABEL := 0 /   --global variable $LABEL serves
                                 --to generate unique labels.
  PROGRAM::<.DECLARATIONS: $TAB := #TABLE_OF_NUMBERS,
              --creation of the table of unique variable numbers
             STATEMENTS: (.(* #G_STATEMENT *).) / GEN << 'EOJ' /,
             DECLARATIONS : #G_DECLARATIONS      .>       ##
#TABLE_OF_NUMBERS <* $Id: $TYPE /$N :=$N+1; $T++:=<. $Id: $N.>/ *>
                   /RETURN $T/    ##
#G_STATEMENT ( #G_ASSIGNMENT ! #G_INPUT !
              #G_OUTPUT     ! #G_CONDITIONAL )      ##
#G_ASSIGNMENT    ASSIGNMENT::<. LEFT: $Id := #NAME,
  RIGHT :( ( <. VARIABLE: $Id1:=#NAME .>
              /GEN << MOV @ $Id1 ',' $Id / ) !
           ( <. CONSTANT : $N .> /GEN << MOV @ '=' $N ',' $Id /) !
           ( $NREG := #G_EXPRESSION
              /GEN << 'SAVE' @ 'R' $NREG ',' $Id / ) )  .>    ##
#G_INPUT INPUT::(. (* $Id := #NAME /GEN << READ $Id / *) .)   ##
#G_OUTPUT     OUTPUT :: (. (*
    ( ( <. VARIABLE : $Id := #NAME .> /GEN << WRITE $Id / ) !
       ( <. CONSTANT : $N .> /GEN << WRITE @ '=' $N / )  !
       ( $NREG := #G_EXPRESSION /GEN << WRITE @ 'R' $NREG /) )
                         *) .)                                ##
#G_CONDITIONAL     CONDITIONAL ::
     <. COND : $NREG := #G_EXPRESSION
            / $LABEL1 :=#NEW_LABEL(); $LABEL2 :=#NEW_LABEL() /,
         THEN   : / GEN << BRANCH @ 'R' $NREG ',L' $LABEL1  /
                  (. (* #G_STATEMENT *) .)
               / IF $.ELSE -> GEN << JUMP @ 'L' $LABEL2 FI;
                             GEN << @ 'L' $LABEL1 ': NOP' / ,
       [ ELSE : (. (* #G_STATEMENT *) .)
               / GEN << @ 'L' $LABEL2 ': NOP' / ]     .>  ##
#G_EXPRESSION --returns the number of the register containing
               --result of the evaluation of expression
  $EXPR
/ $NREG := 0 / -- number of the first accessible register
/RETURN #G_EXPR($EXPR)/
 ##


#G_EXPR     ( <. VARIABLE: $ID :=#NAME .>  !
              <. CONSTANT: $N / $ID := #IMPLODE('=' $N)/ .>)
            / $REG := COPY( LAST #G_EXPRESSION $NREG ) ;
              GEN << 'LOAD' @ 'R' $REG ',' $ID  ;
              LAST #G_EXPRESSION $NREG + := 1; RETURN $REG /  ;;
         $OP::<. ARG1 : $R1 := #G_EXPR, ARG2 : $R2 := #G_EXPR .>
          / GEN << $OP @ 'R' $R1 ',R' $R2 ; RETURN $R1 /   ##
#G_DECLARATIONS
<* $ID: $TYPE /$ID1 := #NAME($ID); GEN<< $ID1 ':' DEFWORD 0 /*> ##
#NEW_LABEL    --auxiliary rule
    /LAST #G_PROGRAM  $LABEL+:=1;
     RETURN COPY (LAST #G_PROGRAM $LABEL )/              ##
#NAME    $ID --returns standard name of the variable $ID in $TAB
     / RETURN #IMPLODE( VAR  LAST #G_PROGRAM $TAB.$ID)/    ##