home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / PASCAL / PPAS80.LBR / PPINC1.PQS / PPINC1.PAS
Pascal/Delphi Source File  |  2000-06-30  |  2KB  |  90 lines
  1. { Convert letters to upper case }
  2.  
  3. function upper (ch : char) : char;
  4.  
  5. begin
  6. if ch in ['a'..'z'] then upper := chr(ord(ch) - casediff)
  7. else upper := ch
  8. end; { upper }
  9.  
  10. { Read the next character and classify it }
  11.  
  12. procedure getchar;
  13.  
  14. var
  15. ch : char;
  16.  
  17. begin
  18. currchar := nextchar;
  19. with nextchar do
  20. if eof(infile) then
  21. begin name := filemark; value := blank end
  22. else
  23. if eoln(infile) then
  24. begin name := endofline; value := blank;
  25. inlines := inlines + 1; readln(infile) end
  26. else
  27. begin
  28. read(infile,ch);
  29. value := ch;
  30. if ch in ['a'..'z','A'..'Z','_'] then name := letter
  31. else
  32. if ch in ['0'..'9'] then name := digit
  33. else
  34. if ch = '''' then name := quote
  35. else
  36. if (ch = blank) or (ch = chr(tab)) then name := space
  37. else name := otherchar
  38. end
  39. end; { getchar }
  40.  
  41. { Store a character in the current symbol }
  42.  
  43. procedure storenextchar(var length : byte; var value : token);
  44.  
  45. begin
  46. getchar;
  47. if length < maxsymbolsize then
  48. begin length := length + 1; value[length] := currchar.value end;
  49. end; { storenextchar }
  50.  
  51. { Count the spaces between symbols }
  52.  
  53. procedure skipblanks (var spacesbefore,crsbefore : byte);
  54.  
  55. begin
  56. spacesbefore := 0;
  57. crsbefore := 0;
  58. while nextchar.name in [space,endofline] do
  59. begin
  60. getchar;
  61. case currchar.name of
  62. space : spacesbefore := spacesbefore + 1;
  63. endofline : begin
  64. crsbefore := crsbefore + 1;
  65. spacesbefore := 0
  66. end
  67. end
  68. end
  69. end; { skipspaces }
  70.  
  71. { Process comments using either brace or parenthesis notation }
  72.  
  73. procedure getcomment (sym : symbolinfo);
  74.  
  75. begin
  76. sym^.name := opencomment;
  77. while not (((currchar.value = '*') and (nextchar.value = ')'))
  78. or (currchar.value = '}')
  79. or (nextchar.name = endofline)
  80. or (nextchar.name = filemark)) do
  81. storenextchar(sym^.length,sym^.value);
  82. if (currchar.value = '*') and (nextchar.value = ')') 
  83. then
  84. begin
  85. storenextchar(sym^.length,sym^.value); sym^.name := closecomment
  86. end;
  87. if currchar.value = '}' 
  88. then sym^.name := closecomment
  89. end; { getcommment }
  90.