编译器/解释器

开发平台：
C/C++

basic.p.2：源码内容
							                  if v^.sval^ <> nil then
                     dispose(v^.sval^);
                  new(v^.sval^);
                  v^.sval^^ := s;
                  if not iseos then
                     begin
                        require(tokcomma);
                        write('?? ');
                     end;
               until iseos;
            end
         else
            begin
               readln(s);
               parse(addr(s), tok);
               tok0 := tok;
               repeat
                  v := findvar;
                  while tok = nil do
                     begin
                        write('?? ');
                        readln(s);
                        disposetokens(tok0);
                        parse(addr(s), tok);
                        tok0 := tok;
                     end;
                  tok1 := t;
                  t := tok;
                  v^.val^ := realexpr;
                  if t <> nil then
                     if t^.kind = tokcomma then
                        t := t^.next
                     else
                        snerr;
                  tok := t;
                  t := tok1;
                  if not iseos then
                     require(tokcomma);
               until iseos;
               disposetokens(tok0);
            end;
      end;
   procedure cmdlet(implied : boolean);
      var
         v : varptr;
	 old : basicstring;
      begin
         if implied then
            t := stmttok;
         v := findvar;
         require(tokeq);
         if v^.stringvar then
            begin
               old := v^.sval^;
               v^.sval^ := strexpr;
               if old <> nil then
                  dispose(old);
            end
         else
            v^.val^ := realexpr;
      end;
   procedure cmdgoto;
      begin
         stmtline := mustfindline(intexpr);
         t := nil;
         gotoflag := true;
      end;
   procedure cmdif;
      var
         n : real;
         i : integer;
      begin
         n := realexpr;
         require(tokthen);
         if n = 0 then
            begin
               i := 0;
               repeat
                  if t <> nil then
                     begin
                        if t^.kind = tokif then
                           i := i + 1;
                        if t^.kind = tokelse then
                           i := i - 1;
                        t := t^.next;
                     end;
               until (t = nil) or (i < 0);
            end;
         if (t <> nil) and (t^.kind = toknum) then
            cmdgoto
         else
            elseflag := true;
      end;
   procedure cmdelse;
      begin
         t := nil;
      end;
   function skiploop(up, dn : tokenkinds) : boolean;
      label 1;
      var
         i : integer;
         saveline : lineptr;
      begin
         saveline := stmtline;
         i := 0;
         repeat
            while t = nil do
               begin
                  if (stmtline = nil) or (stmtline^.next = nil) then
                     begin
                        skiploop := false;
                        stmtline := saveline;
                        goto 1;
                     end;
                  stmtline := stmtline^.next;
                  t := stmtline^.txt;
               end;
            if t^.kind = up then
               i := i + 1;
            if t^.kind = dn then
               i := i - 1;
            t := t^.next;
         until i < 0;
         skiploop := true;
     1 :
      end;
   procedure cmdfor;
      var
         l : loopptr;
         lr : looprec;
         saveline : lineptr;
         i, j : integer;
      begin
         lr.vp := findvar;
         if lr.vp^.stringvar then snerr;
         require(tokeq);
         lr.vp^.val^ := realexpr;
         require(tokto);
         lr.max := realexpr;
         if (t <> nil) and (t^.kind = tokstep) then
            begin
               t := t^.next;
               lr.step := realexpr;
            end
         else
            lr.step := 1;
         lr.homeline := stmtline;
         lr.hometok := t;
         lr.kind := forloop;
         lr.next := loopbase;
         with lr do
            if ((step >= 0) and (vp^.val^ > max)) or ((step <= 0) and (vp^.val^ < max)) then
               begin
                  saveline := stmtline;
                  i := 0;
                  j := 0;
                  repeat
                     while t = nil do
                        begin
                           if (stmtline = nil) or (stmtline^.next = nil) then
                              begin
                                 stmtline := saveline;
                                 errormsg('FOR without NEXT');
                              end;
                           stmtline := stmtline^.next;
                           t := stmtline^.txt;
                        end;
                     if t^.kind = tokfor then
                        if (t^.next <> nil) and (t^.next^.kind = tokvar) and (t^.next^.vp = vp) then
                           j := j + 1
                        else
                           i := i + 1;
                     if (t^.kind = toknext) then
                        if (t^.next <> nil) and (t^.next^.kind = tokvar) and (t^.next^.vp = vp) then
                           j := j - 1
                        else
                           i := i - 1;
                     t := t^.next;
                  until (i < 0) or (j < 0);
                  skiptoeos;
               end
            else
               begin
                  new(l);
                  l^ := lr;
                  loopbase := l;
               end;
      end;
   procedure cmdnext;
      var
         v : varptr;
         found : boolean;
         l : loopptr;
      begin
         if not iseos then
            v := findvar
         else
            v := nil;
         repeat
            if (loopbase = nil) or (loopbase^.kind = gosubloop) then 
               errormsg('NEXT without FOR');
            found := (loopbase^.kind = forloop) and
                     ((v = nil) or (loopbase^.vp = v));
            if not found then
               begin
                  l := loopbase^.next;
                  dispose(loopbase);
                  loopbase := l;
               end;
         until found;
         with loopbase^ do
            begin
               vp^.val^ := vp^.val^ + step;
               if ((step >= 0) and (vp^.val^ > max)) or ((step <= 0) and (vp^.val^ < max)) then
                  begin
                     l := loopbase^.next;
                     dispose(loopbase);
                     loopbase := l;
                  end
               else
                  begin
                     stmtline := homeline;
                     t := hometok;
                  end;
            end;
      end;
   procedure cmdwhile;
      var
         l : loopptr;
      begin
         new(l);
         l^.next := loopbase;
         loopbase := l;
         l^.kind := whileloop;
         l^.homeline := stmtline;
         l^.hometok := t;
         if not iseos then
            if realexpr = 0 then
               begin
                  if not skiploop(tokwhile, tokwend) then 
                     errormsg('WHILE without WEND');
                  l := loopbase^.next;
                  dispose(loopbase);
                  loopbase := l;
                  skiptoeos;
               end;
      end;
   procedure cmdwend;
      var
         tok : tokenptr;
         tokline : lineptr;
         l : loopptr;
         found : boolean;
      begin
         repeat
            if (loopbase = nil) or (loopbase^.kind = gosubloop) then
               errormsg('WEND without WHILE');
            found := (loopbase^.kind = whileloop);
            if not found then
               begin
                  l := loopbase^.next;
                  dispose(loopbase);
                  loopbase := l;
               end;
         until found;
         if not iseos then
            if realexpr <> 0 then
               found := false;
         tok := t;
         tokline := stmtline;
         if found then
            begin
               stmtline := loopbase^.homeline;
               t := loopbase^.hometok;
               if not iseos then
                  if realexpr = 0 then
                     found := false;
            end;
         if not found then
            begin
               t := tok;
               stmtline := tokline;
               l := loopbase^.next;
               dispose(loopbase);
               loopbase := l;
            end;
      end;
   procedure cmdgosub;
      var
         l : loopptr;
      begin
         new(l);
         l^.next := loopbase;
         loopbase := l;
         l^.kind := gosubloop;
         l^.homeline := stmtline;
         l^.hometok := t;
         cmdgoto;
      end;
   procedure cmdreturn;
      var
         l : loopptr;
         found : boolean;
      begin
         repeat
            if loopbase = nil then
               errormsg('RETURN without GOSUB');
            found := (loopbase^.kind = gosubloop);
            if not found then
               begin
                  l := loopbase^.next;
                  dispose(loopbase);
                  loopbase := l;
               end;
         until found;
         stmtline := loopbase^.homeline;
         t := loopbase^.hometok;
         l := loopbase^.next;
         dispose(loopbase);
         loopbase := l;
         skiptoeos;
      end;
   procedure cmdread;
      var
         v : varptr;
         tok : tokenptr;
         found : boolean;
      begin
         repeat
            v := findvar;
            tok := t;
            t := datatok;
            if dataline = nil then
               begin
                  dataline := linebase;
                  t := dataline^.txt;
               end;
            if (t = nil) or (t^.kind <> tokcomma) then
               repeat
                  while t = nil do
                     begin
                        if (dataline = nil) or (dataline^.next = nil) then
                           errormsg('Out of Data');
                        dataline := dataline^.next;
                        t := dataline^.txt;
                     end;
                  found := (t^.kind = tokdata);
                  t := t^.next;
               until found and not iseos
            else
               t := t^.next;
            if v^.stringvar then
               begin
                  if v^.sval^ <> nil then
                     dispose(v^.sval^);
                  v^.sval^ := strexpr;
               end
            else
               v^.val^ := realexpr;
            datatok := t;
            t := tok;
            if not iseos then
               require(tokcomma);
         until iseos;
      end;
   procedure cmddata;
      begin
         skiptoeos;
      end;
   procedure cmdrestore;
      begin
         if iseos then
            restoredata
         else
            begin
               dataline := mustfindline(intexpr);
               datatok := dataline^.txt;
            end;
      end;
   procedure cmdgotoxy;
      var
         i : integer;
      begin
         i := intexpr;
         require(tokcomma);
         gotoxy(i, intexpr);
      end;
   procedure cmdon;
      var
         i : integer;
         l : loopptr;
      begin
         i := intexpr;
         if (t <> nil) and (t^.kind = tokgosub) then
            begin
               new(l);
               l^.next := loopbase;
               loopbase := l;
               l^.kind := gosubloop;
               l^.homeline := stmtline;
               l^.hometok := t;
               t := t^.next;
            end
         else
            require(tokgoto);
         if i < 1 then
            skiptoeos
         else
            begin
               while (i > 1) and not iseos do
                  begin
                     require(toknum);
                     if not iseos then
                        require(tokcomma);
                     i := i - 1;
                  end;
               if not iseos then
                  cmdgoto;
            end;
      end;
   procedure cmddim;
      var
         i, j, k : integer;
         v : varptr;
         done : boolean;
      begin
         repeat
            if (t = nil) or (t^.kind <> tokvar) then snerr;
            v := t^.vp;
            t := t^.next;
            with v^ do
               begin
                  if numdims <> 0 then
                     errormsg('Array already dimensioned');
                  j := 1;
                  i := 0;
                  require(toklp);
                  repeat
                     k := intexpr + 1;
                     if k < 1 then badsubscr;
                     if i >= maxdims then badsubscr;
                     i := i + 1;
                     dims[i] := k;
                     j := j * k;
                     done := (t <> nil) and (t^.kind = tokrp);
                     if not done then
                        require(tokcomma);
                  until done;
                  t := t^.next;
                  numdims := i;
                  if stringvar then
                     begin
                        hpm_new(sarr, j*4);
                        for i := 0 to j-1 do
                           sarr^[i] := nil;
                     end
                  else
                     begin
                        hpm_new(arr, j*8);
                        for i := 0 to j-1 do
                           arr^[i] := 0;
                     end;
               end;
            if not iseos then
               require(tokcomma);
         until iseos;
      end;
   procedure cmdpoke;
      var
         trick :
            record
               case boolean of
                  true : (i : integer);
                  false : (c : ^char);
            end;
      begin
         $range off$
         trick.i := intexpr;
         require(tokcomma);
         trick.c^ := chr(intexpr);
         $if checking$ $range on$ $end$
      end;
   begin {exec}
      try
         repeat
            repeat
               gotoflag := false;
               elseflag := false;
               while (stmttok <> nil) and (stmttok^.kind = tokcolon) do
                  stmttok := stmttok^.next;
               t := stmttok;
               if t <> nil then
                  begin
                     t := t^.next;
                     case stmttok^.kind of
                        tokrem     : ;
                        toklist    : cmdlist;
                        tokrun     : cmdrun;
                        toknew     : cmdnew;
                        tokload    : cmdload(false, stringexpr);
                        tokmerge   : cmdload(true, stringexpr);
                        toksave    : cmdsave;
                        tokbye     : cmdbye;
                        tokdel     : cmddel;
                        tokrenum   : cmdrenum;
                        toklet     : cmdlet(false);
                        tokvar     : cmdlet(true);
                        tokprint   : cmdprint;
                        tokinput   : cmdinput;
                        tokgoto    : cmdgoto;
                        tokif      : cmdif;
                        tokelse    : cmdelse;
                        tokend     : cmdend;
                        tokstop    : escape(-20);
                        tokfor     : cmdfor;
                        toknext    : cmdnext;
                        tokwhile   : cmdwhile;
                        tokwend    : cmdwend;
                        tokgosub   : cmdgosub;
                        tokreturn  : cmdreturn;
                        tokread    : cmdread;
                        tokdata    : cmddata;
                        tokrestore : cmdrestore;
                        tokgotoxy  : cmdgotoxy;
                        tokon      : cmdon;
                        tokdim     : cmddim;
                        tokpoke    : cmdpoke;
                     otherwise
                        errormsg('Illegal command');
                     end;
                  end;
               if not elseflag and not iseos then
                  checkextra;
               stmttok := t;
            until t = nil;
            if stmtline <> nil then
               begin
                  if not gotoflag then
                     stmtline := stmtline^.next;
                  if stmtline <> nil then
                     stmttok := stmtline^.txt;
               end;
         until stmtline = nil;
      recover
         begin
            if escapecode = -20 then
               begin
                  write('Break');
               end
            else if escapecode = 42 then
               begin end
            else
               case escapecode of
                  -4 : write(#7'Integer overflow');
                  -5 : write(#7'Divide by zero');
                  -6 : write(#7'Real math overflow');
                  -7 : write(#7'Real math underflow');
                  -8, -19..-15 : write(#7'Value range error');
                  -10 :
                     begin
                        new(ioerrmsg);
                        misc_getioerrmsg(ioerrmsg^, ioresult);
                        write(#7, ioerrmsg^);
                        dispose(ioerrmsg);
                     end;
                  otherwise
                     begin
                        if excp_line <> -1 then
                           writeln(excp_line);
                        escape(escapecode);
                     end;
               end;
            if stmtline <> nil then
               write(' in ', stmtline^.num:1);
            writeln;
         end;
   end; {exec}
begin {main}
   new(inbuf);
   linebase := nil;
   varbase := nil;
   loopbase := nil;
   writeln('Chipmunk BASIC 1.0');
   writeln;
   exitflag := false;
   repeat
      try
         repeat
            write('>');
            readln(inbuf^);
            parseinput(buf);
            if curline = 0 then
               begin
                  stmtline := nil;
                  stmttok := buf;
                  if stmttok <> nil then
                     exec;
                  disposetokens(buf);
               end;
         until exitflag or eof(input);
      recover
         if escapecode <> -20 then
            misc_printerror(escapecode, ioresult)
         else
            writeln;
   until exitflag or eof(input);
end.

						