The Education Master 1994 (4th Edition)/EDUCATIONS_MASTER_4TH_EDITION.bin/files/progscal/tinypasc/tusems.pas

Pascal/Delphi Source File | 1986-02-24 | 22.8 KB | 792 lines

  {TUSEMS -- semantics stuff for simple Turbo compiler }

  {**********************}
  procedure TAB;
  begin
    if llen<opcd_position then begin
      write(rfile, ' ':opcd_position-llen);
      llen:=opcd_position;
      end
    else
    if llen<opnd_position then begin
      write(rfile, ' ':opnd_position-llen);
      llen:=opnd_position;
      end
    else begin
      write(rfile, ' ');
      llen:=llen+1;
      end
    end;

  {***********************}
  procedure WRCODE(STR: string31);
    var SX: int;
  begin
    sx:=1;
    while sx<=length(str) do begin
      if str[sx]=' ' then begin
        tab;
        while str[sx]=' ' do sx:=sx+1;
        end
      else begin
        write(rfile, str[sx]);
        llen:=llen+1;
        sx:=sx+1;
        end
      end;
    if length(comment)>0 then begin
      writeln(rfile, ' ; ', comment);
      comment:='';
      end
    else writeln(rfile);
    llen:=0;
    end;

  {*******************}
  procedure CODE(STR: string31);
  begin
    tab;
    wrcode(str);
    end;

  {*******************}
  procedure CODE2(S1, S2: string31);
  begin
    code(concat(s1, s2));
    end;

  {*******************}
  procedure CODE3(S1, S2, S3: string31);
  begin
    code(concat(s1, concat(s2, s3)));
    end;

  {*******************}
  procedure CODE4(S1, S2, S3, S4: string31);
  begin
    code(concat(s1, concat(s2, concat(s3, s4))));
    end;

  {*******************}
  procedure LCODE(THE_LABEL, STR: string31);
  begin
    write(rfile, the_label  {, ':'} );
             {NOTE: the Microsoft assembler expects
               a colon or other separator between a label and
               the operation code.  CHASM doesn't}
    llen:=llen+length(the_label) {+1} ;
    tab;
    wrcode(str);
    end;

  {*******************}
  procedure CODESTRINGS;
    var STR: string80;
        SX: integer;
  begin
    while gslist<>nil do
    with gslist^.left^ do begin  {points to a STRNG}
      str:='';
      sx:=stx;
      while strtab[sx]<>chr(0) do begin
        str:=concat(str, ' ');
        str[length(str)]:=strtab[sx];
        if strtab[sx]='''' then
          str:=concat(str, '''');
        sx:=sx+1;
        end;
      lcode(concat('SS', num2string(strngnum)),
            concat('DB ''',
              concat(str, ''',0')));
      gslist:=gslist^.right;  {next list member}
      end;
    strx:=0;
    gslist:=nil;
    end;

  {******************}
  procedure INCL_FILE(FNAME: string31);
    var IFILE: text;
        LINE: longstring;
  begin
    writeln(rfile, ' ; <', fname, '> included');
    {$I-}
    assign(ifile, fname);
    reset(ifile);  {$I+}
    if ioresult<>0 then error(concat('can''t open ', fname))
    else begin
      while not(eof(ifile)) do begin
        readln(ifile, line);
        writeln(rfile, line);
        end;
      close(ifile);
      end;
    writeln(rfile, ' ; ... end of include ', fname);
    end;

  {******************}
  procedure INIT_SEM;
    { Semantics initialization -- called before any productions
      are applied. }

    {..................}
    procedure DEF_FUNCTION(NAME: string15; PARMS: int);
      var TSYMP: symtabp;
    begin   {some predefined functions}
      tsymp:=makesym(symtab, name, func_type, plevel);
      with tsymp^ do begin
        faddr:=0;
        is_system:=true;
        pbytes:=parms*varsize;
        is_actual:=true;
        end
      end;

  begin
    llen:=0;
    labcount:=0;        {for made-up labels}
    trcount:=0;
    main_symp:=nil;
    plevel:=0;
    gslist:=nil;
    comment:='';
    next_snum:=0;   {string code numbers}
    def_function('WRITE', 0);  {takes integers and strings}
    def_function('READ', 0);   {reads and returns an integer}
    def_function('WRITELN', 0);  {takes integers and strings}
    def_function('EOF', 0);    {returns 1 if end of file, 0 otherwise}
    def_function('HALT', 0);   {stops process}
    writeln(rfile, ' ; Tiny Pascal assembler code');
    code('MOV SP,OFFSET(STACKORG)');   {set stack pointer}
    code('MOV BP,SP');         {and marker pointer}
    code('CALL MAIN');       {must be name of some procedure}
    code('INT 020H');   {return to system}
    incl_file('STDIO.HDR');  {system procedures}
    end;

  {******************}
  procedure END_SEM;
    var HX: integer;
        TSYMP: symtabp;
  begin
    {dump global variables}
    writeln(rfile, ' ; GLOBAL VARIABLES');
    for hx:=0 to hlimit do begin
      tsymp:=symtab[hx];
      while tsymp<>nil do
      with tsymp^ do begin
        if (level=0) and
           (symt=var_type) then
          lcode(sym, 'DW 0');
        tsymp:=next;
        end
      end;
    writeln(rfile, ' ; RUNTIME STACK');
    code('DS 2000');
    lcode('STACKORG', 'DW 0');  {bottom of stack}
    if main_symp=nil then
    error('no MAIN procedure found')
    else begin
      writeln(rfile, ' ; MAIN stack space');
      for hx:=1 to (main_symp^.pbytes div 2)+1 do code('DW 0');
          {these allow space for the MAIN program's formal parameters}
      end;
    if errors>0 then begin
      writeln(rfile, '; **** ', errors:1, ' error(s) seen');
      writeln('**** ', errors:1, ' error(s) seen');
      end
    else begin
      writeln(rfile, '; NO errors');
      writeln('NO errors');
      end
    end;

  {******************}
  function NEW_SEM {(SEMTYP: semtype): semrecp} ;
    var TSEMP, TSEMP1: semrecp;
  begin
    new(tsemp);
    new_sem:=tsemp;
    with tsemp^ do begin
      semt:=semtyp;
      case semtyp of
        ident: symp:=nil;
        fixed: numval:=0;
        strng: begin
          stx:=strx;
          strngnum:=next_snum;
          next_snum:=next_snum+1;
          tsemp1:=new_sem(stmtlist);
          with tsemp1^ do begin  {link into a global list of strings}
            left:=tsemp;
            right:=gslist;
            end;
          gslist:=tsemp1;
          end;
        addop..funcall: begin
          left:=nil;
          right:=nil;
          end;
        if_then_else: begin
          b1:=nil;
          s1:=nil;
          s2:=nil;
          end;
        ELSE ;
        end
      end
    end;

  {************************}
  procedure TRACEIT(TRACE: boolean; MSG: string80; SEMP: semrecp);
    var STR: longstring;
  begin
    if trace then begin
      write(rfile, ' ':trcount, msg, ': ');
      if semp<>nil then begin
        write(rfile, sem_names[semp^.semt]);
        if semp^.semt=ident then begin
          write(rfile, ': ', semp^.symp^.sym);
          end
        end
      else write(rfile, sem_names[other]);
      writeln(rfile);
      trcount:=trcount+2;
      end
    end;

  {************************}
  procedure ENDIT(TRACE: boolean);
  begin
    if trace then begin
      trcount:=trcount-2;
      writeln(rfile, ' ':trcount, '[exit]');
      end
    end;

  {************************}
  procedure DUMPTREE(MSG: string80; ROOT: semrecp);
    var CH: char;
  begin
    if trace then begin
      write(rfile, '***DUMP ', msg, ' ');
      dump_sem(2, root, '');
      writeln(rfile);
      writeln(rfile, '***END');
      end
    end;

  {***********************}
  procedure DISP_SEM(TSEMP: semrecp);
  begin  {recursively dispose a SEMREC tree}
    if tsemp<>nil then
    with tsemp^ do begin
      case semt of
        addop..funcall: begin
          disp_sem(left);
          disp_sem(right);
          end;
        if_then_else: begin
          disp_sem(b1);
          disp_sem(s1);
          disp_sem(s2);
          end;
        ELSE  ;
        end;
      dispose(tsemp);
      end
    end;

  {************************}
  function OPCODE(SEMT: semtype): string8;
  begin
    case semt of
      addop: opcode:='ADD';
      subop: opcode:='SUB';
      mpyop: opcode:='IMULW';
      divop: opcode:='IDIVW';
      end
    end;

  {***********************}
  function IS_SIMPLE(ROOT: semrecp): boolean;
  begin
    if root^.semt=fixed then is_simple:=true
    else
    if root^.semt=ident then
    is_simple:=(root^.symp^.symt=var_type)
    else is_simple:=false;
    end;

  {***********************}
  function NAMEOF(ROOT: semrecp): string15;
  begin   {ROOT has to be an IDENT or a FIXED;
             this returns a string that will go into an
             appropriate instruction location}
    with root^ do begin
      nameof:='';  {default}
      if semt=fixed then nameof:=num2string(numval)
      else
      if semt=ident then begin
        with symp^ do begin
          if length(comment)>0 then
            comment:=concat(comment, ', ');
          comment:=concat(comment, symp^.sym);
          case symt of
            var_type: if level=0 then nameof:=sym
              else nameof:=concat(num2string(vaddr), '[BP]');
            func_type: nameof:=
                   concat(num2string(pbytes+2*varsize), '[BP]');
            user: symerror(sym, 'undeclared variable');
            ELSE  ;
            end
          end
        end
      else error('BUG2: nameof');
      end
    end;

  {***********************}
  function NEW_LABEL: string8;
  begin
    new_label:=concat('XXX', num2string(labcount));
    labcount:=labcount+1;
    end;

  procedure EVAL (ROOT: semrecp); forward;

  {************************}
  procedure CODE_USER(ROOT: semrecp);
    var FPARM: semrecp;
        POSITION: integer;
  begin  {an ordinary user procedure}
    code('PUSH AX');  {place for return value}
    fparm:=root^.right;
    position:=0;
    while fparm<>nil do
    with fparm^ do begin
      eval(left);  {one parameter to AX}
      code('PUSH AX');    {push it on the stack}
      if left^.semt=strng then
        error('string parameter is invalid');
      position:=position+varsize;
      fparm:=fparm^.right;
      end;
    with root^.left^.symp^ do begin
      if (position>pbytes) then
      error('too many actual parameters')
      else
      if (position<pbytes) then begin
        code('MOV AX,0');
        while (position<pbytes) do begin
            {add more parameter places for local variables}
          code('PUSH AX');
          position:=position+varsize;
          end
        end;
      code2('CALL ', sym);
      end
    end;

  {*************************}
  procedure CODE_SYSTEM(ROOT: semrecp);
    var FPARM: semrecp;
  begin  {system procedure -- broken into
            unit calls, but at high level takes
            an arbitrary number of mixed integers
            and string addresses}
    {The only one we have so far is WRITE/WRITELN}
    with root^.left^.symp^ do
    if (sym='WRITE') or
       (sym='WRITELN') then begin
      fparm:=root^.right;   {formal parameter list}
      while fparm<>nil do
      with fparm^.left^ do begin
        if semt=strng then begin
          code3('MOV BX,OFFSET(SS', num2string(strngnum), ')');
                    {address to BX}
          code('CALL SYS_SWRT');
          end
        else begin
          eval(fparm^.left);  {integer left over in AX}
          code('CALL SYS_IWRT');
          end;
        fparm:=fparm^.right;
        end;
      if sym='WRITELN' then
        code('CALL SYS_WRTLN');
      end
    else if sym='HALT' then code('INT 020H')
    else if sym='READ' then code('CALL READ')
    else symerror(sym, 'missing system procedure');
    end;

  {***********************}
  procedure CODE_FUNCALL(ROOT: semrecp);
    var FPARM: semrecp;
        POS: integer;
        FROOT: semrecp;
  begin
    if root^.semt=ident then begin
      froot:=new_sem(funcall);
      froot^.left:=root;
      code_funcall(froot);
      end
    else
    if root^.left^.symp^.is_system then code_system(root)
    else code_user(root);
    end;

  {************************}
  procedure EVAL {(ROOT: semrecp)} ;
    var LABEL1, LABEL2: string8;
  begin
    if root<>nil then
    with root^ do
    case semt of
      ident: if symp^.symt=var_type then code2('MOV AX,', nameof(root))
             else if symp^.symt=func_type then code_funcall(root)
             else symerror(symp^.sym, 'invalid as an expression');
      fixed: code2('MOV AX,', num2string(numval));
      strng: code2('MOV AX,SS', num2string(stx));
      addop, subop:
        if is_simple(right) then begin
          eval(left);  {goes to AX}
          code3(opcode(semt), ' AX,', nameof(right));
          end
        else begin
          eval(right);
          code('PUSH AX');  {put in stack temporarily}
          eval(left);  {left side to AX}
          code('POP DX');  {get the right value back from stack}
          code2(opcode(semt), ' AX,DX');
          end;
      mpyop, divop: begin
        eval(right);     {divisor to AX}
        code('PUSH AX');
        eval(left);      {dividend to AX}
        if semt=divop then code('CWD');  {sign extend into DX}
        code('POP CX');
        code2(opcode(semt), ' CX');
        end;
      assignop: begin
        if right^.semt=fixed then  {an immediate on the right is OK}
          code4('MOVW ', nameof(left), ',', nameof(right))
        else begin
          eval(right);  {goes to AX}
          code3('MOV ', nameof(left), ',AX');
          end
        end;
      while_do: begin
        label1:=new_label;
        lcode(label1, 'EQU $');
        eval(left);   {boolean condition}
        code('CMP AX,0');
        label2:=new_label;
        code2('JLE ', label2);
        eval(right);  {statement or statement list}
        code2('JMP ', label1);
        lcode(label2, 'EQU $');
        end;
      stmtlist:
        while root<>nil do begin
          eval(root^.left);
          root:=root^.right;
          end;
      funcall: code_funcall(root);
      if_then_else: begin
        label1:=new_label;
        eval(b1);   {boolean condition}
        code('CMP AX,0');
        code2('JLE ', label1);
        eval(s1);   {THEN statement}
        label2:=new_label;
        code2('JMP ', label2);
        lcode(label1, 'EQU $');
        eval(s2);   {ELSE statement}
        lcode(label2, 'EQU $');
        end
      end
    end;

  {***********************}
  procedure FUNC_OPEN(ID: semrecp);
  begin
   { Picture of stack just after a call:
               function return value  (2 bytes)
               parm1                  (2 bytes)
               parm2                  (2 bytes)
                ...
               parmN                  (2 bytes)  <-- SP+2
               return address         (2 bytes)  <-- SP

   We then push a `previous' BP, and set BP to the new SP, adding
     one more word to the stack.
   This convention is nearly like that used in Turbo, but with
     the following two exceptions:
     1) in Turbo, parameters are pushed in reverse order, i.e.
        last parameter is pushed first and vice versa.
     2) no stack space for a return value is provided in Turbo, as
        in our scheme.
   In both, the function's return value is returned in AX}

    lcode(id^.symp^.sym, 'PROC NEAR');
       {marks the procedure's entry location}
    code('PUSH BP');  {marker location}
    code('MOV BP,SP');  {set BP to current SP}
    end;

  {***********************}
  procedure FUNC_CLOSE(ID: semrecp);
  begin    {code an EXIT operation}
    comment:=id^.symp^.sym;
    code3('MOV AX,', num2string(id^.symp^.pbytes+2*varsize), '[BP]');
    code('POP BP');     {restore BP}
    code2('RET ', num2string(id^.symp^.pbytes+varsize));
    codestrings;
    code('ENDP');
    end;

  {**************************}
  function LIST_SYM(SYM: symbol; POSITION: int):int;
  begin
    writeln(rfile, ' ; ', sym, ' ':(maxtoklen+2-length(sym)),
                   position:1, '[BP]');
    list_sym:=position-varsize;
    end;

  {***********************}
  procedure LIST_SYMS(FID, FPLIST: semrecp);
    var POSITION: int;
  begin
    writeln(rfile, ' ;    SYMBOL TABLE');
    position:=fid^.symp^.pbytes+4;   {return value}
    position:=list_sym(fid^.symp^.sym, position);
    while fplist<>nil do begin
      position:=list_sym(fplist^.left^.symp^.sym, position);
      fplist:=fplist^.right;
      end;
    writeln(rfile);
    end;

  {*************************}
  procedure DECL_VARS(IDLIST: semrecp; NEXT_ADDR: int; FPS: boolean);
  begin  {declare local (fps) or global ~(fps) variables}
    while idlist<>nil do begin
      if idlist^.left^.semt<>ident then
        error('need an identifier')
      else
      with idlist^.left^ do begin
        if fps then begin   {locals}
          if symp^.symt=user then begin  {hasn't been declared yet}
            symp^.symt:=var_type;
            symp^.level:=plevel;
            end
          else
          if symp^.level<plevel then {this shadows a global}
          symp:=forcesym(symtab, symp^.sym, var_type, plevel)
          else
          symerror(symp^.sym, 'multiply declared');
          with symp^ do begin
            vaddr:=next_addr;
            next_addr:=next_addr-varsize;
            end
          end
        else   {global variables}
        with symp^ do begin
          if symt<>user then
            symerror(sym, 'multiply declared');
          symt:=var_type;  {vaddr isn't needed}
          end
        end;
      idlist:=idlist^.right;
      end
    end;

  {************************}
  procedure DECL_FUNC(ID, PARMS, BODY: semrecp);
    var NPARMS: int;
        TP: semrecp;
  begin
    nparms:=0;
    tp:=parms;
    while tp<>nil do begin  {count the parameters}
      nparms:=nparms+1;
      tp:=tp^.right;
      end;
    with id^, symp^ do begin
      if (symt=var_type) or  {previously declared a variable}
         ((symt=func_type) and is_actual)
             {previously declared as a full procedure}
        then symerror(sym, 'multiply declared');
      if symt=user then begin   {hasn't been seen before}
        faddr:=0;
        is_system:=false;
        end;
      symt:=func_type;
      is_actual:=(body<>nil);
      plevel:=plevel+1;   {at local level for parameters}
      decl_vars(parms, varsize*(nparms+1), true);
      pbytes:=varsize*(nparms);
      if sym='MAIN' then main_symp:=symp;
      end
    end;

  {*********************}
  procedure APPLY(PFLAG: int; var TSEMP: semrecp);

    {.....................}
    function IS_ARITH(TSEMP: semrecp): boolean;
    begin
      is_arith:=tsemp^.semt in [ident, fixed, addop, subop,
                                mpyop, divop, funcall];
      end;

    {....................}
    function IS_STRING(TSEMP: semrecp): boolean;
    begin
      is_string:=tsemp^.semt=strng;
      end;

    {....................}
    procedure BIN_TREE(STYPE: semtype);
    begin
      tsemp:=new_sem(stype);
      tsemp^.left:=sem[tos-2];
      tsemp^.right:=sem[tos];
      if not(is_arith(sem[tos-2]) and
             is_arith(sem[tos])) then
        error('nonarithmetic operand');
      end;

    {....................}
    function NCONC(STL, ST: semrecp): semrecp;
    begin   {STL is a list based on the RIGHT pointer.
             It may be NIL}
      if stl=nil then nconc:=st
      else begin
        nconc:=stl;
        while stl^.right<>nil do stl:=stl^.right;
        stl^.right:=st;
        end
      end;

    {....................}
    function IS_VOID(TSEMP: semrecp): boolean;
    begin   {look for the special identifier VOID}
      if tsemp=nil then is_void:=true
      else begin
        is_void:=false;
        if tsemp^.semt=ident then
        if tsemp^.symp^.sym='VOID' then is_void:=true;
        end
      end;

  begin
    case pflag of
      ADDOPR:  { Expr -> Expr + Term }
        begin
          bin_tree(addop);
          end;
      ASSIGN:  { Stmt -> <identifier> := Expr }
        begin
          bin_tree(assignop);
          end;
      BLOCK:  { Stmt -> BEGIN StmtList END }
        begin
          tsemp:=sem[tos-1];
          end;
      DIVOPR:  { Term -> Term / Primary }
        begin
          bin_tree(divop);
          end;
      EXPRLIST1:  { ExprList -> Expr }
        if not(is_void(sem[tos])) then begin
          tsemp:=new_sem(expr_list);
          tsemp^.left:=sem[tos];
          end;
      EXPRLIST2:  { ExprList -> ExprList , Expr }
        if not(is_void(sem[tos])) then begin
          tsemp:=new_sem(expr_list);
          tsemp^.left:=sem[tos];
          tsemp:=nconc(sem[tos-2], tsemp);
          end
        else tsemp:=sem[tos-2];
      FDECL:  { FuncDecl -> FUNCTION <identifier> ( ExprList ) ; Stmt }
        begin  {should be at global level}
          plevel:=0;   {just in case}
          decl_func(sem[tos-5], sem[tos-3], sem[tos]);
            {... also increments PLEVEL by one}
          if sem[tos]<>nil then begin
            func_open(sem[tos-5]);
            eval(sem[tos]);   {evaluate the Stmt}
            func_close(sem[tos-5]);
            list_syms(sem[tos-5], sem[tos-3]);
            end;
          disp_sem(sem[tos-5]);
          disp_sem(sem[tos-3]);
          disp_sem(sem[tos]);
          clearsym(symtab, plevel);
          plevel:=0;
          end;
      FUNCP:  { Primary -> <identifier> ( ExprList ) }
        begin   {function call}
          tsemp:=new_sem(funcall);
          tsemp^.left:=sem[tos-3];
          tsemp^.right:=sem[tos-1];
          end;
      IFTHEN:  { Stmt -> IF Expr THEN Stmt ELSE Stmt }
        begin
          tsemp:=new_sem(if_then_else);
          with tsemp^ do begin
            b1:=sem[tos-4];
            s1:=sem[tos-2];
            s2:=sem[tos];
            if is_string(b1) then
              error('if-expr is a string');
            end
          end;
      MPYOPR:  { Term -> Term * Primary }
        begin
          bin_tree(mpyop);
          end;
      PAREN:  { Primary -> ( Expr ) }
        begin
          tsemp:=sem[tos-1];
          end;
      SEXPR:  { Stmt -> Expr }
        begin
          if not(sem[tos]^.semt in [ident, funcall]) then
            error('invalid statement');
            {Can't check for function call since function names
               haven't been defined yet}
          end;
      STLIST2:  { StmtList -> StmtList Stmt ; }
        begin
          tsemp:=new_sem(stmtlist);
          tsemp^.left:=sem[tos-1];
          tsemp:=nconc(sem[tos-2], tsemp);
          end;
      SUBOPR:  { Expr -> Expr - Term }
        begin
          bin_tree(subop);
          end;
      VDECL:  { FuncDecl -> VAR ExprList }
        begin
          decl_vars(sem[tos], 0, false);
          disp_sem(sem[tos]);
          end;
      WHILEDO:  { Stmt -> WHILE Expr DO Stmt }
        begin
          tsemp:=new_sem(while_do);
          tsemp^.left:=sem[tos-2];
          tsemp^.right:=sem[tos];
          if is_string(tsemp^.left) then
            error('while-expr is a string');
          end
      ELSE  writeln(rfile, pflag);
        error('unknown production flag');
      end  { apply case };
    end;