mirror of
https://github.com/byteworksinc/ORCA-Pascal.git
synced 2024-12-05 10:50:24 +00:00
1106 lines
26 KiB
ObjectPascal
1106 lines
26 KiB
ObjectPascal
{$optimize 15}
|
|
{---------------------------------------------------------------}
|
|
{ }
|
|
{ Scanner }
|
|
{ }
|
|
{---------------------------------------------------------------}
|
|
|
|
unit Scanner;
|
|
|
|
{$segment 'Pascal2'}
|
|
|
|
interface
|
|
|
|
{$libprefix '0/obj/'}
|
|
|
|
uses PCommon, CGI;
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
var
|
|
{misc}
|
|
{----}
|
|
debugType: (stop,breakPoint,autoGo); {kind of debugging for this line}
|
|
doingInterface: boolean; {compiling an interface?}
|
|
partiallist: partialptr; {list of partial compile names}
|
|
partial: boolean; {is this a partial compile?}
|
|
|
|
{returned by InSymbol}
|
|
{--------------------}
|
|
sy: symbol; {last symbol}
|
|
op: operator; {classification of last symbol}
|
|
val: valu; {value of last constant}
|
|
lgth: integer; {length of last string constant}
|
|
id: pString; {last identifier}
|
|
ch: char; {last character}
|
|
eofl: boolean; {end of file flag}
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
procedure InSymbol; extern;
|
|
|
|
{ read the next token from the source stream }
|
|
|
|
|
|
procedure Match (sym: symbol; ern: integer); extern;
|
|
|
|
{ insure that the next symbol is the one requested }
|
|
{ }
|
|
{ parameters: }
|
|
{ sym - symbol expected }
|
|
{ ern - error number; used if the symbol is not correct }
|
|
|
|
|
|
procedure OpenUses;
|
|
|
|
{ copies the contents of a uses file }
|
|
|
|
|
|
procedure Scanner_Init; extern;
|
|
|
|
{ initialize the scanner }
|
|
|
|
|
|
procedure Scanner_Fini;
|
|
|
|
{ shut down the scanner }
|
|
|
|
|
|
procedure Skip (fsys: setofsys);
|
|
|
|
{ skip input string until relavent symbol found }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - symbol kind to skip to }
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
type
|
|
copyFilePtr = ^copyFileRecord; {copied file chain}
|
|
copyFileRecord = record
|
|
fnext: copyFilePtr; {next copied file record}
|
|
fname: gsosOutString; {file name}
|
|
fpos: longint; {disp in file}
|
|
fuses: boolean; {doing uses?}
|
|
flineCount: integer; {line count}
|
|
end;
|
|
|
|
var
|
|
{misc}
|
|
{----}
|
|
didKeep: boolean; {have we found a $keep directive?}
|
|
doingOption: boolean; {compiling an option?}
|
|
eofDisable: boolean; {disable end of file error check?}
|
|
eol: boolean; {end of line flag}
|
|
fHeadGS: copyFilePtr; {copied file chain}
|
|
langNum: integer; {language number}
|
|
listFixed: boolean; {was the list option specified on the cl?}
|
|
lString: pString; {last string}
|
|
usesLength: longint; {# bytes in current uses buffer}
|
|
usesPtr: ptr; {ptr to next byte in uses buffer}
|
|
|
|
{- Private subroutines -----------------------------------------}
|
|
|
|
procedure EndOfLine; extern;
|
|
|
|
{ Read in the next source line }
|
|
|
|
|
|
procedure FakeInsymbol; extern;
|
|
|
|
{ install the uses file InSymbol patch }
|
|
|
|
|
|
procedure GetPartialNames;
|
|
|
|
{ Form a linked list of partial compile names }
|
|
|
|
|
|
function GetName: boolean;
|
|
|
|
{ Read a name from subsGS }
|
|
{ }
|
|
{ Returns: false if there are no more names, else true }
|
|
|
|
var
|
|
i: unsigned; {loop/index variable}
|
|
pn: partialptr; {new partial compile entry}
|
|
pname: pStringPtr; {work string}
|
|
|
|
|
|
function GetCh: char;
|
|
|
|
{ Get a character }
|
|
{ }
|
|
{ returns: next character from subsGS }
|
|
|
|
var
|
|
ch: char; {work character}
|
|
|
|
begin {GetCh}
|
|
if subsGS.theString.size = 0 then
|
|
GetCh := chr(0)
|
|
else begin
|
|
ch := subsGS.theString.theString[1];
|
|
if ch in ['a'..'z'] then
|
|
ch := chr(ord(ch)-ord('a')+ord('A'));
|
|
GetCh := ch;
|
|
end; {else}
|
|
end; {GetCh}
|
|
|
|
|
|
procedure NextCh;
|
|
|
|
{ Remove the next character from subsGS }
|
|
|
|
var
|
|
i: unsigned; {loop/index variable}
|
|
|
|
begin {NextCh}
|
|
with subsGS.theString do
|
|
if size <> 0 then begin
|
|
for i := 2 to size do
|
|
theString[i-1] := theString[i];
|
|
size := size-1;
|
|
end; {with}
|
|
end; {NextCh}
|
|
|
|
|
|
begin {GetName}
|
|
while GetCh = ' ' do
|
|
NextCh;
|
|
if subsGS.theString.size = 0 then
|
|
GetName := false
|
|
else begin
|
|
GetName := true;
|
|
i := 0;
|
|
new(pn);
|
|
new(pname);
|
|
pn^.pname := pname;
|
|
while not (GetCh in [' ', chr(0)]) do begin
|
|
i := i+1;
|
|
pname^[i] := GetCh;
|
|
NextCh;
|
|
end; {while}
|
|
pname^[0] := chr(i);
|
|
pn^.next := partialList;
|
|
partialList := pn;
|
|
end; {else}
|
|
end; {GetName}
|
|
|
|
|
|
begin {GetPartialNames}
|
|
partialList := nil; {assume no list}
|
|
partial := false;
|
|
if subsGS.theString.size <> 0 then begin
|
|
repeat until not GetName;
|
|
partial := true;
|
|
end; {if}
|
|
end; {GetPartialNames}
|
|
|
|
|
|
procedure InitFile;
|
|
|
|
{ get the command line and GetLInfo information }
|
|
|
|
const
|
|
{bit masks for GetLInfo flags}
|
|
{----------------------------}
|
|
flag_d = $10000000; {generate debug code?}
|
|
flag_e = $08000000; {abort to editor on terminal error?}
|
|
flag_l = $00100000; {list source lines?}
|
|
flag_m = $00080000; {memory based compile?}
|
|
flag_o = $00020000; {optimize?}
|
|
flag_p = $00010000; {print progress info?}
|
|
flag_s = $00002000; {list symbol tables?}
|
|
flag_t = $00001000; {treat all errors as terminal?}
|
|
flag_w = $00000200; {wait when an error is found?}
|
|
|
|
var
|
|
i: unsigned; {loop/index variable}
|
|
|
|
begin {InitFile}
|
|
fNameGS.maxSize := maxPath+4;
|
|
fNameGS.theString.size := 0;
|
|
for i := 1 to maxPath do
|
|
fNameGS.theString.theString[i] := chr(0);
|
|
kNameGS := fNameGS;
|
|
subsGS := fNameGS;
|
|
ldInfoGS := fNameGS;
|
|
with liDCBGS do begin
|
|
pCount := 11;
|
|
sFile := @fNameGS;
|
|
dFile := @kNameGS;
|
|
namesList := @subsGS;
|
|
iString := @ldInfoGS;
|
|
end; {with}
|
|
GetLInfoGS(liDCBGS);
|
|
with liDCBGS do begin
|
|
if pFlags & flag_l <> 0 then begin {set up source listing flags}
|
|
list := true;
|
|
listFixed := true;
|
|
end
|
|
else if mFlags & flag_l <> 0 then
|
|
listFixed := true
|
|
else
|
|
listFixed := false;
|
|
wait := pFlags & flag_w <> 0; {wait when an error is found?}
|
|
allTerm := pFlags & flag_t <> 0; {all errors terminal?}
|
|
gotoEditor := pFlags & flag_e <> 0; {enter editor on terminal errors?}
|
|
debugFlag := pFlags & flag_d <> 0; {generate debug code?}
|
|
profileFlag := debugFlag; {generate profile code?}
|
|
memoryFlag := pflags & flag_m <> 0; {memory based compile?}
|
|
progress := mflags & flag_p = 0; {write progress info?}
|
|
printSymbols := pflags & flag_s <> 0; {print the symbol table?}
|
|
cLineOptimize := pFlags & flag_o <> 0; {turn optimizations on?}
|
|
end; {liDCB}
|
|
if list then {we don't need both...}
|
|
progress := false;
|
|
keepFlag := liDCBGS.kFlag; {set up the code generator}
|
|
codeGeneration := keepFlag <> 0;
|
|
end; {InitFile}
|
|
|
|
|
|
procedure ListLine; extern;
|
|
|
|
{ List the current line and any errors found }
|
|
|
|
|
|
procedure NextCh; extern;
|
|
|
|
{ Fetch the next source character }
|
|
|
|
|
|
procedure OpenGS;
|
|
|
|
{ Open a source file }
|
|
|
|
var
|
|
ffDCBGS: fastFileDCBGS; {for FastFile load}
|
|
erRec: errorDCBGS; {for reporting shell error}
|
|
|
|
begin {OpenGS}
|
|
with ffDCBGS do begin {read the source file}
|
|
pCount := 14;
|
|
action := 0;
|
|
flags := $C000;
|
|
pathName := @fNameGS.theString;
|
|
option := nil;
|
|
end; {with}
|
|
FastFileGS(ffDCBGS);
|
|
if ToolError <> 0 then begin
|
|
erRec.pcount := 1;
|
|
erRec.error := ToolError;
|
|
ErrorGS(erRec);
|
|
TermError(4, nil);
|
|
end; {if}
|
|
if langNum <> 0 then begin {check the language number}
|
|
if ffDCBGS.auxType <> langNum then
|
|
TermError(2, nil);
|
|
end {if}
|
|
else
|
|
langNum := long(ffDCBGS.auxType).lsw;
|
|
filePtr := ffDCBGS.fileHandle^; {set beginning of file pointer}
|
|
chEndPtr := pointer(ord4(filePtr)+ffDCBGS.fileLength);;
|
|
chPtr := pointer(ord4(chEndPtr)-1); {make sure the file ends with a CR}
|
|
if chPtr^ <> 13 then
|
|
TermError(11, nil);
|
|
chPtr := filePtr; {set the character pointer}
|
|
end; {OpenGS}
|
|
|
|
|
|
procedure OpenUses;
|
|
|
|
{ Open a file for the uses statement }
|
|
|
|
var
|
|
exRec: ExpandDevicesDCBGS; {ExpandDevices record}
|
|
ffRec: FastFileDCBGS; {FastFile record}
|
|
i: unsigned; {loop/index variable}
|
|
lNameGS: gsosOutString; {work string for forming path name}
|
|
separator: char; {separator character}
|
|
|
|
begin {OpenUses}
|
|
if intPrefixGS.theString.size = 0 then begin
|
|
lNameGS.theString.theString := concat('13:ORCAPascalDefs:', id, '.int');
|
|
lNameGS.theString.size := length(lNameGS.theString.theString);
|
|
if GetFileType(lNameGS) = -1 then
|
|
lNameGS.theString.theString := concat('8:', id, '.int');
|
|
end {if}
|
|
else begin
|
|
i := 0;
|
|
separator := ' ';
|
|
while (i < intPrefixGS.theString.size) and (separator = ' ') do begin
|
|
if intPrefixGS.theString.theString[i] in [':', '/'] then
|
|
separator := intPrefixGS.theString.theString[i];
|
|
i := i+1;
|
|
end; {while}
|
|
if separator = ' ' then
|
|
separator := ':';
|
|
lNameGS.theString := intPrefixGS.theString;
|
|
if intPrefixGS.theString.size < maxPath then
|
|
lNameGS.theString.theString[intPrefixGS.theString.size] := chr(0);
|
|
if intPrefixGS.theString.theString[intPrefixGS.theString.size-1] <> separator
|
|
then
|
|
lNameGS.theString.theString :=
|
|
concat(lNameGS.theString.theString, separator);
|
|
lNameGS.theString.theString := concat(lNameGS.theString.theString, id);
|
|
lNameGS.theString.theString := concat(lNameGS.theString.theString, '.int');
|
|
end; {else}
|
|
lNameGS.theString.size := length(lNameGS.theString.theString);
|
|
exRec.pcount := 2; {expand devices}
|
|
exRec.inName := @lNameGS.theString;
|
|
exRec.outName := @usesFileNameGS;
|
|
usesFileNameGS.maxSize := maxPath+4;
|
|
ExpandDevicesGS(exRec);
|
|
if ToolError <> 0 then
|
|
usesFileNameGS := lNameGS;
|
|
ffRec.pcount := 14; {read the file}
|
|
ffRec.action := 0;
|
|
ffRec.flags := $C000;
|
|
ffRec.pathName := @usesFileNameGS.theString;
|
|
ffRec.option := nil;
|
|
FastFileGS(ffRec);
|
|
if ToolError <> 0 then
|
|
TermError(6, nil);
|
|
usesPtr := ffRec.fileHandle^; {save the file pointer}
|
|
usesLength := ffRec.fileLength; {save the file length}
|
|
if ffRec.fileType = DVU then begin {skip the version number}
|
|
usesPtr := pointer(ord4(usesPtr)+1);
|
|
usesLength := usesLength-1;
|
|
end; {if}
|
|
FakeInsymbol; {set up the InSymbol patch}
|
|
end; {OpenUses}
|
|
|
|
|
|
procedure SkipComment;
|
|
|
|
{ Skip to the end of a comment }
|
|
|
|
begin {SkipComment}
|
|
repeat
|
|
while not ((ch = '*') or (ch = '}')) and not eofl do
|
|
NextCh;
|
|
if ch = '*' then
|
|
NextCh;
|
|
until (ch = ')') or (ch = '}') or eofl;
|
|
NextCh;
|
|
end; {SkipComment}
|
|
|
|
|
|
function Options: boolean;
|
|
|
|
{ Compile compiler directives }
|
|
{ }
|
|
{ Returns: True if the parser should continue to scan for an }
|
|
{ end of comment, else false }
|
|
|
|
const
|
|
nameLen = 12; {max length of a directive name}
|
|
|
|
var
|
|
dName: string[nameLen]; {directive name}
|
|
|
|
|
|
function IsAlpha (ch: char): boolean;
|
|
|
|
{ See if a character is alphabetic }
|
|
{ }
|
|
{ parameters: }
|
|
{ ch - character to check }
|
|
{ }
|
|
{ Returns: True for an alphabetic character, else false }
|
|
|
|
begin {IsAlpha}
|
|
IsAlpha := ch in ['a'..'z', 'A'..'Z'];
|
|
end; {IsAlpha}
|
|
|
|
|
|
procedure SkipBlanks;
|
|
|
|
{ skip to the next non-blank character }
|
|
|
|
const
|
|
tab = 9; {tab key code}
|
|
|
|
begin {SkipBlanks}
|
|
while (ch in [' ', chr(tab), chr($CA)]) and (not eofl) do
|
|
NextCh;
|
|
end; {SkipBlanks}
|
|
|
|
|
|
function ToUpper (ch: char): char;
|
|
|
|
{ Return an uppercase character }
|
|
{ }
|
|
{ parameters: }
|
|
{ ch - character to check }
|
|
{ }
|
|
{ Returns: Uppercase equivalent of ch }
|
|
|
|
begin {ToUpper}
|
|
if ch in ['a'..'z'] then
|
|
ch := chr(ord(ch)-ord('a')+ord('A'));
|
|
ToUpper := ch;
|
|
end; {ToUpper}
|
|
|
|
|
|
procedure Expand (var name: pString);
|
|
|
|
{ Expands a name to a full pathname }
|
|
{ }
|
|
{ parameters: }
|
|
{ name - file name to expand }
|
|
|
|
var
|
|
exRec: expandDevicesDCBGS; {expand devices}
|
|
|
|
begin {Expand}
|
|
exRec.pcount := 2;
|
|
new(exRec.inName);
|
|
exRec.inName^.theString := name;
|
|
exRec.inName^.size := length(name);
|
|
new(exRec.outName);
|
|
exRec.outName^.maxSize := maxPath+4;
|
|
ExpandDevicesGS(exRec);
|
|
if toolerror = 0 then
|
|
with exRec.outName^.theString do begin
|
|
if size < maxPath then
|
|
theString[size+1] := chr(0);
|
|
name := theString;
|
|
end; {with}
|
|
dispose(exRec.inName);
|
|
dispose(exRec.outName);
|
|
end; {Expand}
|
|
|
|
|
|
function GetIdent: pStringPtr;
|
|
|
|
{ Read an identifier }
|
|
{ }
|
|
{ Returns: pointer to the identifier, or nil }
|
|
|
|
var
|
|
disp: integer; {characters in the string}
|
|
sPtr: pStringPtr; {dynamic string pointer}
|
|
str: pString; {work buffer}
|
|
|
|
begin {GetIdent}
|
|
SkipBlanks;
|
|
sPtr := nil;
|
|
disp := 0;
|
|
if IsAlpha(ch) then begin
|
|
while ch in ['a'..'z', 'A'..'Z', '0'..'9', '_'] do begin
|
|
if disp < maxLine then
|
|
disp := disp+1;
|
|
str[disp] := ch;
|
|
NextCh;
|
|
end; {while}
|
|
str[0] := chr(disp);
|
|
sPtr := pStringPtr(Malloc(length(str)+1));
|
|
sPtr^ := str;
|
|
end; {if}
|
|
GetIdent := sPtr;
|
|
end; {GetIdent}
|
|
|
|
|
|
function GetInteger: integer;
|
|
|
|
{ Read an (possibly signed) integer value }
|
|
{ }
|
|
{ Returns: Value read }
|
|
|
|
var
|
|
sign: boolean; {is the value negative?}
|
|
temp: integer; {temp val.ival}
|
|
|
|
begin {GetInteger}
|
|
temp := val.ival;
|
|
SkipBlanks;
|
|
sign := false;
|
|
if ch = '-' then begin
|
|
NextCh;
|
|
sign := true;
|
|
end; {if}
|
|
InSymbol;
|
|
if sy = longintconst then
|
|
if val.valp^.lval >> 16 = 0 then begin
|
|
val.ival := ord(val.valp^.lval);
|
|
sy := intconst;
|
|
end; {if}
|
|
if sy <> intconst then
|
|
Error(15);
|
|
if sign then
|
|
val.ival := -val.ival;
|
|
GetInteger := val.ival;
|
|
val.ival := temp;
|
|
end; {GetInteger}
|
|
|
|
|
|
function GetString: boolean;
|
|
|
|
{ read a string }
|
|
{ }
|
|
{ Returns: True if a string was found, else false }
|
|
{ }
|
|
{ Notes: }
|
|
{ 1. If a string is found, it is placed in lString }
|
|
{ 2. If a string is not found, no error is reported }
|
|
|
|
begin {GetString}
|
|
SkipBlanks;
|
|
GetString := ch = '''';
|
|
if ch = '''' then
|
|
InSymbol
|
|
else
|
|
Error(6);
|
|
end; {GetString}
|
|
|
|
|
|
function SetOption: boolean;
|
|
|
|
{ Check for a +/- options flag }
|
|
{ }
|
|
{ Returns: True for +, false for - }
|
|
|
|
begin {SetOption}
|
|
SetOption := true;
|
|
if ch in ['+','-'] then begin
|
|
SetOption := ch = '+';
|
|
NextCh;
|
|
end {if}
|
|
else
|
|
Error(6);
|
|
end; {SetOption}
|
|
|
|
|
|
procedure DoAppend;
|
|
|
|
{ Append }
|
|
|
|
var
|
|
ffRec: FastFileDCBGS; {FastFile record}
|
|
|
|
begin {DoAppend}
|
|
if GetString then begin {get the source name}
|
|
EndOfLine; {read the next source line}
|
|
PurgeSource; {purge the current source file}
|
|
eol := false; {don't reprint the line}
|
|
Expand(lString); {set the new path name}
|
|
fNameGS.theString.theString := lString;
|
|
fNameGS.theString.size := length(lString);
|
|
if not eofDisable then begin
|
|
OpenGS; {open the file}
|
|
lineCount := 1;
|
|
end; {if}
|
|
end {if}
|
|
else begin
|
|
eofl := true;
|
|
Error(37);
|
|
end; {else}
|
|
Options := false; {we won't scan for end of comment}
|
|
doingOption := false;
|
|
end; {DoAppend}
|
|
|
|
|
|
procedure DoCDev;
|
|
|
|
{ CDev }
|
|
|
|
begin {DoCDev}
|
|
if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
|
|
or isNBA then
|
|
Error(100);
|
|
isCDev := true;
|
|
openName := GetIdent;
|
|
end; {DoCDev}
|
|
|
|
|
|
procedure DoClassicDesk;
|
|
|
|
{ ClassicDesk }
|
|
|
|
begin {DoClassicDesk}
|
|
if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
|
|
or isNBA then
|
|
Error(100);
|
|
isClassicDeskAcc := true;
|
|
if GetString then
|
|
menuLine := lString
|
|
else
|
|
Error(131);
|
|
openName := GetIdent;
|
|
closeName := GetIdent;
|
|
end; {DoClassicDesk}
|
|
|
|
|
|
procedure DoCopy;
|
|
|
|
{ Copy }
|
|
|
|
var
|
|
ffRec: FastFileDCBGS; {FastFile record}
|
|
fRec: copyFilePtr; {copy file record}
|
|
|
|
begin {DoCopy}
|
|
new(fRec); {create a copy record}
|
|
fRec^.fnext := fHeadGS;
|
|
fHeadGS := fRec;
|
|
fRec^.fName := fNameGS; {fill in the current file name}
|
|
if GetString then begin {get the source name}
|
|
SkipComment; {skip to the end of the directive}
|
|
{save the file position}
|
|
fRec^.fpos := ord4(chPtr) + chCnt - ord4(filePtr);
|
|
fRec^.fuses := false; {not doing a uses}
|
|
fRec^.flineCount := lineCount+1; {save the new line count}
|
|
EndOfLine; {read the next source line}
|
|
PurgeSource; {purge the current source file}
|
|
eol := false; {don't reprint the line}
|
|
Expand(lString); {set the new path name}
|
|
fNameGS.theString.theString := lString;
|
|
fNameGS.theString.size := length(lString);
|
|
OpenGS; {open the file}
|
|
lineCount := 1;
|
|
end {if}
|
|
else begin
|
|
eofl := true;
|
|
Error(37);
|
|
end; {else}
|
|
Options := false; {we won't scan for end of comment}
|
|
doingOption := false;
|
|
end; {DoCopy}
|
|
|
|
|
|
procedure DoDataBank;
|
|
|
|
{ DataBank }
|
|
|
|
begin {DoDataBank}
|
|
dataBank := SetOption;
|
|
end; {DoDataBank}
|
|
|
|
|
|
procedure DoDebug;
|
|
|
|
{ Debug }
|
|
|
|
var
|
|
val: unsigned; {debug flag word}
|
|
|
|
begin {DoDebug}
|
|
val := GetInteger;
|
|
debugFlag := odd(val);
|
|
profileFlag := (val & $0002) <> 0;
|
|
profileFlag := profileFlag or debugFlag;
|
|
debugStrFlag := (val & $8000) <> 0;
|
|
end; {DoDebug}
|
|
|
|
|
|
procedure DoEject;
|
|
|
|
{ Eject }
|
|
|
|
begin {DoEject}
|
|
if printer then
|
|
if list then begin
|
|
write(chr(12));
|
|
lCnt := 0;
|
|
if length(title) <> 0 then begin
|
|
write(title);
|
|
LineFeed;
|
|
LineFeed;
|
|
end; {if}
|
|
end; {if}
|
|
end; {DoEject}
|
|
|
|
|
|
procedure DoFloat;
|
|
|
|
{ Float }
|
|
|
|
begin {DoFloat}
|
|
floatCard := GetInteger;
|
|
end; {DoFloat}
|
|
|
|
|
|
procedure DoISO;
|
|
|
|
{ ISO }
|
|
|
|
begin {DoISO}
|
|
iso := SetOption;
|
|
if iso then
|
|
debug := true;
|
|
end; {DoISO}
|
|
|
|
|
|
procedure DoKeep;
|
|
|
|
{ Keep }
|
|
|
|
begin {DoKeep}
|
|
if progFound or didKeep then
|
|
Error(100)
|
|
else if GetString then begin
|
|
codeGeneration := true;
|
|
Expand(lString);
|
|
kNameGS.theString.theString := lString;
|
|
kNameGS.theString.size := length(lString);
|
|
keepFlag := 1;
|
|
didKeep := true;
|
|
end; {else if}
|
|
end; {DoKeep}
|
|
|
|
|
|
procedure DoLibPrefix;
|
|
|
|
{ LibPrefix }
|
|
|
|
var
|
|
i: unsigned; {loop/index variable}
|
|
len: unsigned; {length(lString)}
|
|
separator: char; {path separaotr character}
|
|
|
|
begin {DoLibPrefix}
|
|
if GetString then begin
|
|
len := length(lString);
|
|
if len = 0 then
|
|
intPrefixGS.theString.size := 0
|
|
else begin
|
|
separator := ' ';
|
|
i := 1;
|
|
while i < len do
|
|
if lString[i] in [':','/'] then begin
|
|
separator := lString[i];
|
|
i := maxint;
|
|
end {if}
|
|
else
|
|
i := i+1;
|
|
if separator = ' ' then
|
|
separator := ':';
|
|
if lString[len] <> separator then
|
|
lString := concat(lString, separator);
|
|
intPrefixGS.theString.theString := lString;
|
|
intPrefixGS.theString.size := length(lString);
|
|
end; {else}
|
|
end {if}
|
|
else
|
|
Error(37);
|
|
end; {DoLibPrefix}
|
|
|
|
|
|
procedure DoList;
|
|
|
|
{ List }
|
|
|
|
var
|
|
llist: boolean; {local list}
|
|
|
|
begin {DoList}
|
|
llist := SetOption;
|
|
if not listFixed then
|
|
list := llist;
|
|
end; {DoList}
|
|
|
|
|
|
procedure DoMemoryModel;
|
|
|
|
{ MemoryModel }
|
|
|
|
begin {DoMemoryModel}
|
|
if progFound then
|
|
Error(100);
|
|
smallMemoryModel := GetInteger = 0;
|
|
end; {DoMemoryModel}
|
|
|
|
|
|
procedure DoNames;
|
|
|
|
{ Names }
|
|
|
|
begin {DoNames}
|
|
traceBack := SetOption;
|
|
end; {DoNames}
|
|
|
|
|
|
procedure DoNBA;
|
|
|
|
{ NBA }
|
|
|
|
begin {DoNBA}
|
|
if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
|
|
or isNBA then
|
|
Error(100);
|
|
isNBA := true;
|
|
openName := GetIdent;
|
|
end; {DoNBA}
|
|
|
|
|
|
procedure DoNewDeskAcc;
|
|
|
|
{ NewDeskAcc }
|
|
|
|
begin {DoNewDeskAcc}
|
|
if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
|
|
or isNBA then
|
|
Error(100);
|
|
isNewDeskAcc := true;
|
|
openName := GetIdent;
|
|
closeName := GetIdent;
|
|
actionName := GetIdent;
|
|
initName := GetIdent;
|
|
refreshPeriod := GetInteger;
|
|
eventMask := GetInteger;
|
|
if GetString then
|
|
menuLine := lString
|
|
else
|
|
Error(131);
|
|
end; {DoNewDeskAcc}
|
|
|
|
|
|
procedure DoOptimize;
|
|
|
|
{ Optimize }
|
|
|
|
var
|
|
val: unsigned; {optimize flag word}
|
|
|
|
begin {DoOptimize}
|
|
val := GetInteger;
|
|
peepHole := odd(val);
|
|
nPeepHole := (val & $0002) <> 0;
|
|
registers := (val & $0004) <> 0;
|
|
commonSubexpression := (val & $0008) <> 0;
|
|
loopOptimizations := (val & $0010) <> 0;
|
|
jslOptimizations := (val & $0020) <> 0;
|
|
end; {DoOptimize}
|
|
|
|
|
|
procedure DoRangeCheck;
|
|
|
|
{ RangeCheck }
|
|
|
|
begin {DoRangeCheck}
|
|
debug := SetOption;
|
|
rangeCheck := debug;
|
|
end; {DoRangeCheck}
|
|
|
|
|
|
procedure DoRTL;
|
|
|
|
{ RTL }
|
|
|
|
begin {DoRTL}
|
|
if isNewDeskAcc or isClassicDeskAcc or isCDev or rtl then
|
|
Error(100);
|
|
rtl := true;
|
|
end; {DoRTL}
|
|
|
|
|
|
procedure DoSegment;
|
|
|
|
{ Segment }
|
|
|
|
var
|
|
i: unsigned; {loop/index variable}
|
|
seg: segNameType; {segment name}
|
|
|
|
begin {DoSegment}
|
|
if GetString then begin
|
|
seg := lString;
|
|
for i := length(seg)+1 to 10 do
|
|
seg[i] := ' ';
|
|
DefaultSegName(seg);
|
|
isDynamic := false;
|
|
end {if}
|
|
else
|
|
Error(6);
|
|
end; {DoSegment}
|
|
|
|
|
|
procedure DoDynamic;
|
|
|
|
{ Dynamic }
|
|
|
|
begin {DoDynamic}
|
|
DoSegment;
|
|
isDynamic := true;
|
|
end; {DoDynamic}
|
|
|
|
|
|
procedure DoStackSize;
|
|
|
|
{ StackSize }
|
|
|
|
begin {DoStackSize}
|
|
if progFound then
|
|
Error(100);
|
|
stackSize := GetInteger;
|
|
end; {DoStackSize}
|
|
|
|
|
|
procedure DoToolParms;
|
|
|
|
{ ToolParms }
|
|
|
|
begin {DoToolParms}
|
|
toolParms := SetOption;
|
|
end; {DoToolParms}
|
|
|
|
|
|
procedure DoTitle;
|
|
|
|
{ Title }
|
|
|
|
begin {DoTitle}
|
|
if GetString then
|
|
title := lString
|
|
else
|
|
title := '';
|
|
end; {DoTitle}
|
|
|
|
|
|
procedure DoXCMD;
|
|
|
|
{ XCMD }
|
|
|
|
begin {DoXCMD}
|
|
if progFound or isNewDeskAcc or isClassicDeskAcc or isCDev or rtl or isXCMD
|
|
or isNBA then
|
|
Error(100);
|
|
isXCMD := true;
|
|
openName := GetIdent;
|
|
end; {DoXCMD}
|
|
|
|
|
|
begin {Options}
|
|
Options := true; {assume we will scan for end of comment}
|
|
doingOption := true; {processing an option}
|
|
repeat
|
|
NextCh;
|
|
if (ch <> '*') and (ch <> '}') then begin
|
|
dName[0] := chr(0); {get a directive name}
|
|
SkipBlanks;
|
|
while IsAlpha(ch) and (ord(dName[0]) < nameLen) do begin
|
|
dName[0] := succ(dName[0]);
|
|
dName[ord(dName[0])] := ToUpper(ch);
|
|
NextCh;
|
|
end; {while}
|
|
{call the correct handler}
|
|
if dName = 'MEMORYMODEL' then DoMemoryModel
|
|
else if dName = 'APPEND' then DoAppend
|
|
else if dName = 'COPY' then DoCopy
|
|
else if dName = 'DEBUG' then DoDebug
|
|
else if dName = 'EJECT' then DoEject
|
|
else if dName = 'FLOAT' then DoFloat
|
|
else if dName = 'ISO' then DoISO
|
|
else if dName = 'KEEP' then DoKeep
|
|
else if dName = 'LIST' then DoList
|
|
else if dName = 'NAMES' then DoNames
|
|
else if dName = 'RANGECHECK' then DoRangeCheck
|
|
else if dName = 'STACKSIZE' then DoStackSize
|
|
else if dName = 'TITLE' then DoTitle
|
|
else if dName = 'RTL' then DoRTL
|
|
else if dName = 'NEWDESKACC' then DoNewDeskAcc
|
|
else if dName = 'OPTIMIZE' then DoOptimize
|
|
else if dName = 'SEGMENT' then DoSegment
|
|
else if dName = 'DYNAMIC' then DoDynamic
|
|
else if dName = 'TOOLPARMS' then DoToolParms
|
|
else if dName = 'DATABANK' then DoDataBank
|
|
else if dName = 'LIBPREFIX' then DoLibPrefix
|
|
else if dName = 'CLASSICDESK' then DoClassicDesk
|
|
else if dName = 'CDEV' then DoCDev
|
|
else if dName = 'XCMD' then DoXCMD
|
|
else if dName = 'NBA' then DoNBA
|
|
else doingOption := false;
|
|
end {if}
|
|
else
|
|
doingOption := false;
|
|
if doingOption then begin {check for another one}
|
|
SkipBlanks;
|
|
doingOption := ch = ',';
|
|
end; {if}
|
|
until not doingOption;
|
|
end; {Options}
|
|
|
|
{- Public subroutines ------------------------------------------}
|
|
|
|
procedure Scanner_Fini;
|
|
|
|
{ Shut down the scanner }
|
|
|
|
var
|
|
i: unsigned; {loop/index variable}
|
|
tp: partialPtr; {work pointer}
|
|
|
|
begin {Scanner_Fini}
|
|
PurgeSource; {purge the last source file}
|
|
fNameGS.theString.size := 0; {handle a trailing append}
|
|
eofDisable := true;
|
|
InSymbol;
|
|
if fNameGS.theString.size <> 0 then begin
|
|
liDCBGS.sFile := @fNameGS;
|
|
liDCBGS.namesList := @subsGS;
|
|
subsGS.theString.size := 0;
|
|
while partialList <> nil do begin
|
|
tp := partialList;
|
|
partialList := tp^.next;
|
|
for i := 1 to length(tp^.pname^) do begin
|
|
subsGS.theString.size := subsGS.theString.size+1;
|
|
subsGS.theString.theString[subsGS.theString.size] := tp^.pname^[i];
|
|
end; {for}
|
|
dispose(tp);
|
|
if partialList <> nil then begin
|
|
subsGS.theString.size := subsGS.theString.size+1;
|
|
subsGS.theString.theString[subsGS.theString.size] := ' ';
|
|
end; {if}
|
|
end; {while}
|
|
if keepFlag <> 0 then
|
|
liDCBGS.kFlag := 3;
|
|
end {if}
|
|
else begin {no append; the compile is over}
|
|
liDCBGS.lOps := liDCBGS.lOps & $FFFE;
|
|
if keepFlag <> 0 then
|
|
liDCBGS.kFlag := 3
|
|
else
|
|
liDCBGS.lOps := 0;
|
|
liDCBGS.sFile := @kNameGS;
|
|
end; {else}
|
|
with liDCBGS do begin {pass info back to the shell}
|
|
sFile := pointer(ord4(sFile)+2);
|
|
dFile := pointer(ord4(dFile)+2);
|
|
namesList := pointer(ord4(namesList)+2);
|
|
iString := pointer(ord4(iString)+2);
|
|
end; {with}
|
|
SetLInfoGS(liDCBGS);
|
|
StopSpin; {stop the spinner}
|
|
ListLine; {finish the listing}
|
|
if list or progress then begin
|
|
LineFeed;
|
|
writeln(errorOutput, numErr:1, ' errors found');
|
|
end; {if}
|
|
end; {Scanner_Fini}
|
|
|
|
|
|
procedure Skip {fsys: setofsys};
|
|
|
|
{ skip input string until relavent symbol found }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - symbol kind to skip to }
|
|
|
|
begin {Skip}
|
|
if not eofl then begin
|
|
while not (sy in fsys) and (not eofl) do
|
|
InSymbol;
|
|
if not (sy in fsys) then
|
|
InSymbol;
|
|
end; {if}
|
|
end; {Skip}
|
|
|
|
end.
|
|
|
|
{$append 'scanner.asm'}
|