home *** CD-ROM | disk | FTP | other *** search
Text File | 1992-03-30 | 76.6 KB | 3,646 lines
unit Macros1; {This unit contains the recursive descent parser/} {interpreter for Image's Pascal-like macro language.} {References:} { "Pascal User Manual and Report", Kathleen Jensen and Niklaus Wirth, Springer-Verlag} { "Building Your Own C Interpreter", Dr. Dobb's Journal, August 1989} interface uses QuickDraw, Palettes, PrintTraps, globals, Utilities, Graphics, edit, Analysis, Camera, file1, file2, functions, macros2, Stacks, Lut; procedure LoadMacros (fname: str255; RefNum: integer); procedure RunMacro (nMacro: integer); procedure RunKeyMacro (ch: char; KeyCode: integer); implementation const DivideByZero = 'Divide by zero'; DoExpected = '"do" expected'; StackOverflow = 'Stack overflow'; RightParenExpected = '")" expected'; MaxArgs = 25; BlankSymbol = ' '; var EndMacros, pcStart, TopOfStack, CurrentX, CurrentY, nSaves: integer; nProcedures, TokenLoc, TokenStackLoc, SavePC, nGlobals: integer; MacroStart: array[1..MaxMacros] of integer; MacroKey: packed array[1..MaxMacros] of char; pc: integer; {"program counter" used by macro interpreter} Token, SaveToken: TokenType; TokenStr: string[100]; TokenSymbol, ProcName: SymbolType; TokenValue: extended; DoOption: boolean; SaveForeground, SaveBackground, SavePicWidth, SavePicHeight: integer; SaveMethod: rsMethodType; SaveCreate, SaveInvertY: boolean; SaveAngle, SaveH, SaveV: real; MacroOpPending: boolean; function GetExpression: extended; forward; procedure DoStatement; forward; procedure DoFor; forward; function LineNumber: integer; var i, n: integer; begin n := 1; with MacrosP^ do for i := pcStart to pc do if macros[i] = cr then n := n + 1; LineNumber := n; end; {$PUSH} {$D-} function PreScan: boolean; {Convert to lowercase and remove comments to speed up parsing.} var inString, inComment: boolean; c: char; i, StartComment: integer; begin with MacrosP^ do begin PreScan := false; inString := false; inComment := false; pcStart := 0; for i := 0 to EndMacros do begin c := macros[i]; if inString and (c = cr) then begin pc := i; PutMessage(concat('The quoted string in line ', long2str(LineNumber), ' is not terminated.')); exit(PreScan); end; if (not InString) and (c = '{') then begin InComment := true; StartComment := i; end; if inComment then begin if (c = '{') and (i <> StartComment) then begin PutMessage('Comments cannot be nested.'); exit(PreScan); end; if c = '}' then inComment := false; macros[i] := ' '; end else begin if c = '''' then inString := not inString; if (c >= 'A') and (c <= 'Z') and not inString then macros[i] := chr(ord(c) + 32); end; end; if inComment then begin pc := StartComment; PutMessage(concat('The comment starting in line ', long2str(LineNumber), ' is not terminated.')) end else PreScan := true; end; {with} end; function match (str: str255): boolean; var i, loc: integer; begin loc := pc - 1; match := false; with MacrosP^ do for i := 1 to length(str) do if macros[loc + i] <> str[i] then exit(match); match := true; end; procedure TrimString (var str: str255); begin if length(str) > 0 then begin while (length(str) > 1) and (str[1] = ' ') do delete(str, 1, 1); while (length(str) > 1) and ((str[length(str)] = ' ') or (str[length(str)] = ';')) do delete(str, length(str), 1); end; end; procedure MacroError (str: str255); var cLine, str2: str255; i, count: integer; begin with MacrosP^ do begin if token = DoneT then exit(MacroError); i := pc - 1; while (i > 0) and (macros[i] <> cr) do {Find start of line} i := i - 1; count := 0; cLine := ''; repeat i := i + 1; count := count + 1; if macros[i] <> cr then cLine := concat(cLine, macros[i]); until (i >= EndMacros) or (macros[i] = cr) or (count > 60); TrimString(cLine); if ProcName <> BlankSymbol then begin {Are we in a procedure?} str2 := ProcName; TrimString(str2); str2 := concat(' of procedure ', str2) end else str2 := ' of macro'; PutMessage(concat(str, ' in line ', long2str(LineNumber), str2, '.', cr, cr, '"', cLine, '"')); Token := DoneT; end; {with} end; procedure LookupIdentifier; {Binary search routine from "Data Structures with Abstract} {Data Types and Pascal" by Stubbs and Webre.} var low, high, mid: integer; begin with MacrosP^ do begin low := 1; high := nSymbols; while low < high do begin mid := (low + high + 1) div 2; if TokenSymbol < SymbolTable[mid].symbol then high := mid - 1 else low := mid; end; with SymbolTable[high] do if (high <> 0) and (TokenSymbol = symbol) then begin token := tType; MacroCommand := cType; TokenLoc := loc; end else token := UnknownIdentifier; end; end; procedure LookupVariable; var VarFound: boolean; i: integer; begin with MacrosP^ do begin VarFound := false; i := TopOfStack + 1; repeat i := i - 1; VarFound := TokenSymbol = Stack[i].symbol until VarFound or (i = 1); if VarFound then with stack[i] do begin token := Variable; TokenValue := value; TokenStackLoc := i; end; end; {with} end; procedure GetToken; var c: char; SymbolLength: integer; begin with MacrosP^ do begin if token = DoneT then exit(GetToken); SavePC := PC; SaveToken := token; while not (macros[pc] in ['a'..'z', '0'..'9', '(', ')', ',', '''', '+', '-', '*', '/', ':', ';', '=', '.', '>', '<', '[', ']']) do begin {skip white space} pc := pc + 1; if pc > EndMacros then begin Token := DoneT; exit(GetToken); end; end; c := macros[pc]; case c of 'a'..'z': begin TokenSymbol := BlankSymbol; SymbolLength := 0; while macros[pc] in ['a'..'z', '0'..'9'] do begin SymbolLength := SymbolLength + 1; if SymbolLength <= SymbolSize then TokenSymbol[SymbolLength] := macros[pc]; pc := pc + 1; if pc > EndMacros then begin Token := DoneT; exit(GetToken); end; end; Token := identifier; LookupIdentifier; if (token = UnknownIdentifier) and (TopOfStack > 0) then LookupVariable; exit(GetToken); end; '0'..'9', '.': begin TokenStr := ''; while macros[pc] in ['0'..'9', '.'] do begin TokenStr := concat(TokenStr, c); pc := pc + 1; c := macros[pc]; if pc > EndMacros then begin Token := DoneT; exit(GetToken); end; end; Token := NumericLiteral; if macros[pc] in ['a'..'z'] then MacroError('Operator expected'); exit(GetToken); end; '(': begin Token := LeftParen; pc := pc + 1; end; ')': begin Token := RightParen; pc := pc + 1; end; '[': begin Token := LeftBracket; pc := pc + 1; end; ']': begin Token := RightBracket; pc := pc + 1; end; ',': begin Token := comma; pc := pc + 1; end; ':': if macros[pc + 1] = '=' then begin Token := AssignOp; pc := pc + 2; end else begin Token := colon; pc := pc + 1; end; ';': begin Token := SemiColon; pc := pc + 1; end; '+': begin Token := PlusOp; pc := pc + 1; end; '-': begin Token := MinusOp; pc := pc + 1; end; '*': begin Token := MulOp; pc := pc + 1; end; '/': begin Token := DivOp; pc := pc + 1; end; '''': begin TokenStr := ''; pc := pc + 1; while macros[pc] <> '''' do begin TokenStr := concat(TokenStr, macros[pc]); pc := pc + 1; if pc > EndMacros then begin Token := DoneT; exit(GetToken); end; end; pc := pc + 1; Token := stringT; end; '=': begin Token := eqOp; pc := pc + 1; end; '<': begin pc := pc + 1; if macros[pc] = '>' then begin token := neOp; pc := pc + 1; end else if macros[pc] = '=' then begin token := leOp; pc := pc + 1; end else token := ltOp; end; '>': begin pc := pc + 1; if macros[pc] = '=' then begin token := geOp; pc := pc + 1; end else token := gtOp; end; otherwise begin token := NullT; beep; end; end; {case} end; {with} end; procedure AddMenuItem; var i, fkey: integer; str: str255; c, key: char; begin with MacrosP^ do begin if pc > 1 then if macros[pc - 1] in ['a'..'z', '0'..'9'] then exit(AddMenuItem); if macros[pc + 5] in ['a'..'z', '0'..'9'] then exit(AddMenuItem); pc := pc + 4; repeat pc := pc + 1; c := macros[pc]; until (c = '''') or (c = cr) or (pc = EndMacros); if (c = cr) or (pc = EndMacros) then begin MacroError('Menu entry for macro not found.'); exit(AddMenuItem); end; pc := pc + 1; str := ''; repeat str := concat(str, macros[pc]); pc := pc + 1; until (macros[pc] = '''') or (pc = EndMacros); if pc = EndMacros then PutMessage('Ending quote('') missing.') else pc := pc + 1; AppendMenu(SpecialMenuH, str); if nMacros < MaxMacros then nMacros := nMacros + 1 else beep; if macros[pc] = ';' then pc := pc + 1; MacroStart[nMacros] := pc; i := pos('[', str); if i > 0 then begin {Assign a key to macro?} i := i + 1; key := str[i]; if (key >= 'A') and (key <= 'Z') then key := chr(ord(key) + 32); MacroKey[nMacros] := key; if (key = 'f') and (str[i + 1] in ['1'..'9']) then begin {Function Key?} fkey := ord(str[i + 1]) - ord('0'); if str[i + 2] in ['0'..'5'] then fkey := fkey * 10 + ord(str[i + 2]) - ord('0'); if (fkey >= 1) and (fkey <= 15) then MacroKey[nMacros] := chr(ord('A') + fkey - 1); end; {Function key?} end; end; {with} end; procedure AddProcedure; begin pc := pc + 9; GetToken; if token <> UnknownIdentifier then begin MacroError('Procedure name missing or previously defined'); exit(AddProcedure); end; if nSymBols >= MaxSymbols then begin MacroError('Too many procedures'); exit(AddProcedure); end; nSymbols := nSymbols + 1; nProcedures := nProcedures + 1; with MacrosP^, MacrosP^.SymbolTable[nSymbols] do begin symbol := TokenSymbol; tType := procedureT; cType := NullC; if macros[pc] = ';' then pc := pc + 1; loc := pc; end; end; procedure CheckForReservedWord; var str: str255; begin if token in [CommandT, FunctionT, endT, VarT, ForT, ToT, DoT, IfT, ThenT, whileT, repeatT, untilT, IntDivOp, modOp, andOp, NotOp, ProcedureT, MacroT, ArrayT] then begin str := TokenSymbol; TrimString(str); MacroError(concat('"', str, '" is a reserved identifier')); end; end; procedure DoDeclaration (global: boolean); var SaveStackLoc, StackLoc: integer; begin SaveStackLoc := TopOfStack; while (token = UnknownIdentifier) or (token = Variable) or (token = comma) do begin TopOfStack := TopOfStack + 1; if global then nGlobals := nGlobals + 1; if TopOfStack > MaxStackSize then begin MacroError(StackOverflow); exit(DoDeclaration); end; with MacrosP^.stack[TopOfStack] do begin Symbol := TokenSymbol; value := 0.0; end; GetToken; if token = comma then GetToken; end; {while} CheckForReservedWord; if token <> colon then MacroError('":" expected'); GetToken; if (token <> IntegerT) and (token <> RealT) and (token <> BooleanT) then MacroError('"integer", "real", or "boolean" expected'); for StackLoc := SaveStackLoc + 1 to TopOfStack do with macrosP^.stack[StackLoc] do case token of IntegerT: vType := IntVar; RealT: vType := RealVar; BooleanT: vType := BooleanVar; otherwise end; GetToken; if Token = SemiColon then GetToken; end; procedure PutTokenBack; begin if token <> DoneT then begin pc := SavePC; token := SaveToken; end; end; procedure DoGlobalDeclarations; begin pc := pc + 3; GetToken; CheckForReservedWord; while (token = UnknownIdentifier) and (Token <> DoneT) do DoDeclaration(true); PutTokenBack; end; procedure PreScan2; var i: integer; inString: boolean; c: char; begin Token := NullT; with MacrosP^ do begin if nMacros > 0 then for i := 1 to nMacros do begin DelMenuItem(SpecialMenuH, FirstMacroItem); MacroKey[i] := chr(0); end; nMacros := 0; nProcedures := 0; nGlobals := 0; TopOfStack := 0; ProcName := BlankSymbol; pc := 0; inString := false; while pc <= (EndMacros - 10) do begin c := macros[pc]; if c = '''' then inString := not inString; if not InString then case c of 'm': if match('macro') then begin AddMenuItem; if token = DoneT then exit(PreScan2); end; 'p': if match('procedure') then begin AddProcedure; if token = DoneT then exit(PreScan2); end; 'v': if (nMacros = 0) and (nProcedures = 0) then if match('var') then begin DoGlobalDeclarations; if token = DoneT then exit(PreScan2); end; otherwise end; pc := pc + 1; end; {while} if nMacros = 0 then PutMessage('No macros found in this file.'); end; {with} end; procedure SortSymbolTable; {Selection sort routine from "Algorithms" by Robert Sedgewick.} var i, j, min: integer; t: SymTabRec; begin with MacrosP^ do for i := 1 to nSymbols do begin min := i; for j := i + 1 to nSymbols do if SymbolTable[j].symbol < SymbolTable[min].symbol then min := j; t := SymbolTable[min]; SymbolTable[min] := SymbolTable[i]; SymbolTable[i] := t; end; end; procedure LoadMacros (fname: str255; RefNum: integer); var err: OSErr; FileSize: LongInt; f: integer; begin err := FSOpen(fname, RefNum, f); err := GetEOF(f, FileSize); if FileSize > MaxMacroSize then begin err := fsclose(f); PutMessage('Macro file is too large.'); exit(LoadMacros); end; err := SetFPos(f, fsFromStart, 0); err := fsRead(f, FileSize, @MacrosP^.macros); EndMacros := FileSize - 1; err := fsclose(f); ShowWatch; if not PreScan then exit(LoadMacros); InitSymbolTable; UnloadSeg(@InitSymbolTable); SortSymbolTable; PreScan2; if nProcedures > 0 then SortSymbolTable; CurrentX := 20; CurrentY := 20; SaveForeground := -1; end; procedure GetLeftParen; begin GetToken; if token <> LeftParen then MacroError('"(" expected'); end; procedure GetRightParen; begin GetToken; if token <> RightParen then MacroError(RightParenExpected); end; procedure GetComma; begin GetToken; if token <> comma then MacroError('"," expected'); end; function GetString: str255; begin GetToken; if token = stringT then GetString := TokenStr else begin MacroError('String expected'); GetString := ''; end; end; function GetInteger: LongInt; var n: LongInt; r: extended; begin r := GetExpression; if token = DoneT then begin GetInteger := 0; exit(GetInteger); end; GetInteger := round(r); end; procedure GetArguments (var str: str255); var width, fwidth: integer; i: LongInt; isExpression, ZeroFill, noArgs: boolean; n: real; str2: str255; begin if MacroCommand = WritelnC then begin {Check for Writeln with no arguments} GetToken; noArgs := token <> LeftParen; PutTokenBack; if NoArgs then begin str := ''; exit(GetArguments); end; end; ZeroFill := not (MacroCommand in [DrawTextC, WriteC, WritelnC, PutMsgC, ShowMsgC]); width := 4; fwidth := 0; str := ''; GetLeftParen; GetToken; repeat isExpression := token in [Variable, NumericLiteral, FunctionT, TrueT, FalseT, ArrayT]; PutTokenBack; if isExpression then n := GetExpression else str2 := GetString; GetToken; if token = colon then begin width := GetInteger; if width < 0 then width := 0; if width > 100 then width := 100; GetToken; if token = colon then begin fwidth := GetInteger; if fwidth < 0 then width := 0; if fwidth > 12 then width := 12; GetToken; end; end; if token = comma then GetToken; if isExpression then begin RealToString(n, width, fwidth, str2); if ZeroFill then for i := 1 to width do if str2[i] = ' ' then str2[i] := '0'; end; str := concat(str, str2); until (token = RightParen) or (token = DoneT); end; procedure CheckBoolean (b: extended); begin if (b <> ord(true)) and (b <> ord(false)) then MacroError('Boolean expression expected'); end; function GetBoolean: boolean; var value: extended; begin value := GetExpression; CheckBoolean(value); GetBoolean := value = ord(true); end; function GetBooleanArg: boolean; begin GetLeftParen; GetBooleanArg := GetBoolean; GetRightParen; end; function GetStringArg: str255; begin GetLeftParen; GetStringArg := GetString; GetRightParen; end; procedure DoConvolve; var err: OSErr; f: integer; FileFound: boolean; fname: str255; begin fname := GetStringArg; err := fsopen(fname, KernelsRefNum, f); FileFound := err = NoErr; err := fsclose(f); if FileFound then convolve(fname, KernelsRefNum) else convolve('', 0); end; function GetNumber: extended; {(prompt:str255; default:extended)} var prompt: str255; default, n: extended; Canceled: boolean; begin GetLeftParen; prompt := GetString; GetComma; default := GetExpression; GetRightParen; n := 0.0; if Token <> DoneT then begin n := GetReal(prompt, default, Canceled); if Canceled then begin n := default; token := DoneT; end; end; GetNumber := n; end; function DoGetPixel: extended; {(hloc,vloc:integer)} var hloc, vloc: integer; begin GetLeftParen; hloc := GetInteger; GetComma; vloc := GetInteger; GetRightParen; if (Token <> DoneT) and (info <> NoInfo) then DoGetPixel := MyGetPixel(hloc, vloc) else DoGetPixel := 0.0; end; function DoFunction (c: CommandType): extended; var n: extended; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; n := GetExpression; GetRightParen; if Token <> DoneT then case SaveCommand of truncC: DoFunction := trunc(n); roundC: DoFunction := round(n); oddC: if odd(trunc(n)) then DoFunction := ord(true) else DoFunction := ord(false); absC: DoFunction := abs(n); sqrtC: if n < 0.0 then MacroError('Sqrt Error') else DoFunction := sqrt(n); sqrC: DoFunction := sqr(n); sinC: DoFunction := sin(n); cosC: DoFunction := cos(n); expC: DoFunction := exp(n); lnC: if n <= 0.0 then MacroError('Log Error') else DoFunction := ln(n); arctanC: DoFunction := arctan(n); end else DoFunction := 0.0; end; procedure RangeCheck (i: LongInt); begin if (i < 0) or (i > 255) then MacroError('Argument is less than 0 or greater than 255'); end; function CalibrateValue: extended; var i: integer; begin GetLeftParen; i := GetInteger; GetRightParen; RangeCheck(i); if Token <> DoneT then begin CalibrateValue := cvalue[i]; end; end; function ExecuteFunction: extended; begin case MacroCommand of TruncC, RoundC, oddC, absC, sqrtC, sqrC, sinC, cosC, expC, lnC, arctanC: ExecuteFunction := DoFunction(MacroCommand); GetNumC: ExecuteFunction := GetNumber; RandomC: ExecuteFunction := (random + 32767.0) / 65534.0; GetPixelC: ExecuteFunction := DoGetPixel; ButtonC: begin ExecuteFunction := ord(Button); FlushEvents(EveryEvent, 0); end; nPicsC: ExecuteFunction := nPics; PicNumC: ExecuteFunction := info^.PicNum; SameSizeC: ExecuteFunction := ord(AllSameSize); cValueC: ExecuteFunction := CalibrateValue; CalibratedC: ExecuteFunction := ord(info^.DensityCalibrated); rCountC: ExecuteFunction := mCount; GetSliceC: with info^ do if StackInfo = nil then ExecuteFunction := 0 else ExecuteFunction := Info^.StackInfo^.CurrentSlice; nSlicesC: with info^ do if StackInfo = nil then ExecuteFunction := 0 else ExecuteFunction := Info^.StackInfo^.nSlices; GetSpacingC: with info^ do if StackInfo = nil then MacroError('No stack') else ExecuteFunction := Info^.StackInfo^.SliceSpacing; GetPlotCountC: ExecuteFunction := PlotCount; end; {case} end; procedure CheckIndex (index: LongInt; min, max: extended); begin if (index < min) or (index > max) then MacroError('Array index out of range'); end; function GetArrayValue: extended; var SaveCommand: CommandType; Index: LongInt; begin SaveCommand := MacroCommand; GetToken; if token <> LeftBracket then MacroError('"[" expected'); Index := GetInteger; GetToken; if token <> RightBracket then MacroError('"]" expected'); case SaveCommand of HistogramC: begin CheckIndex(Index, 0, 255); GetArrayValue := histogram[Index]; end; rAreaC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := mArea^[Index]; end; rMeanC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := mean^[Index]; end; rStdDevC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := sd^[Index]; end; rXC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := xcenter^[Index]; end; rYC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := ycenter^[Index]; end; rLengthC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := pLength^[Index]; end; rMinC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := mMin^[Index]; end; rMaxC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := mMax^[Index]; end; rMajorC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := MajorAxis^[Index]; end; rMinorC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := MinorAxis^[Index]; end; rAngleC: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := orientation^[Index]; end; rUser1C: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := User1^[Index]; end; rUser2C: begin CheckIndex(Index, 1, MaxRegions); GetArrayValue := User2^[Index]; end; RedLutC, GreenLutC, BlueLutC: begin CheckIndex(Index, 0, 255); if Token <> DoneT then with cScreenPort^.portPixMap^^.pmTable^^.ctTable[index].rgb do case SaveCommand of RedLutC: GetArrayValue := band(bsr(red, 8), 255); GreenLutC: GetArrayValue := band(bsr(green, 8), 255); BlueLutC: GetArrayValue := band(bsr(blue, 8), 255); end; {case} end; BufferC: begin CheckIndex(Index, 0, MaxLine - 1); if Token <> DoneT then GetArrayValue := MacrosP^.aLine[index]; end; PlotDataC: begin CheckIndex(Index, 0, MaxLine - 1); if Token <> DoneT then GetArrayValue := PlotData^[index]; end; end; {case} end; function GetValue: extended; begin case token of Variable: GetValue := TokenValue; NumericLiteral: GetValue := StringToReal(TokenStr); FunctionT: GetValue := ExecuteFunction; TrueT: GetValue := ord(true); FalseT: GetValue := ord(false); ArrayT: GetValue := GetArrayValue; otherwise begin MacroError('Number expected'); GetValue := 0.0; exit(GetValue); end; end; {case} end; function GetFactor: extended; var fValue: extended; isUnaryMinus, isNot: boolean; begin GetToken; isUnaryMinus := token = MinusOp; isNot := token = NotOp; if isUnaryMinus or isNot then GetToken; case token of Variable, NumericLiteral, FunctionT, TrueT, FalseT, ArrayT: fValue := GetValue; LeftParen: begin fValue := GetExpression; GetRightParen; end; otherwise begin macroError('Undefined identifier'); fvalue := 0.0 end; end; GetToken; if isUnaryMinus then fValue := -fValue; if isNot then if fValue = ord(true) then fValue := ord(false) else fValue := ord(true); GetFactor := fValue; end; function GetTerm: extended; var tValue, fValue: extended; op: TokenType; begin tValue := GetFactor; while token in [MulOp, IntDivOp, ModOp, DivOp, AndOp] do begin op := token; fValue := GetFactor; case op of MulOp: tValue := tValue * fValue; IntDivOp: if fValue <> 0.0 then tValue := trunc(tValue) div trunc(fValue) else MacroError(DivideByZero); ModOp: if fValue <> 0.0 then tValue := trunc(tValue) mod trunc(fValue) else MacroError(DivideByZero); DivOp: if fValue <> 0.0 then tValue := tValue / fValue else MacroError(DivideByZero); AndOp: begin CheckBoolean(tValue); CheckBoolean(fValue); tValue := ord((tValue = ord(true)) and (fValue = ord(true))); end; end; {case} end; {while} GetTerm := tValue; end; function GetSimpleExpression: extended; var seValue, tValue: extended; op: TokenType; begin seValue := GetTerm; while token in [PlusOp, MinusOp, OrOp] do begin op := token; tValue := GetTerm; case op of PlusOp: seValue := seValue + tValue; MinusOp: seValue := seValue - tValue; orOp: begin CheckBoolean(seValue); CheckBoolean(tValue); seValue := ord((seValue = ord(true)) or (tValue = ord(true))); end; end; end; GetSimpleExpression := seValue; end; function GetExpression: extended; var eValue, seValue: extended; op: TokenType; begin eValue := GetSimpleExpression; while token in [eqOp, ltOp, gtOp, neOp, leOp, geOp] do begin op := token; seValue := GetSimpleExpression; case op of eqOp: eValue := ord(eValue = seValue); ltOp: eValue := ord(eValue < seValue); gtOp: eValue := ord(eValue > seValue); neOp: eValue := ord(eValue <> seValue); leOp: eValue := ord(eValue <= seValue); geOp: eValue := ord(eValue >= seValue); end; end; GetExpression := eValue; PutTokenBack; ; end; procedure DoCapture; begin CaptureAndDisplayQCFrame; if ContinuousHistogram then ShowContinuousHistogram; end; procedure DoWait; var seconds: extended; SaveTicks: LongInt; str: str255; begin GetLeftParen; seconds := GetExpression; GetRightParen; if Token <> DoneT then begin SaveTicks := TickCount + round(seconds * 60.0); repeat if Digitizing then DoCapture; until (TickCount > SaveTicks) or CommandPeriod; end; end; procedure SetDensitySlice; {LowerLevel,UpperLevel:integer} var sStart, sEnd: integer; begin GetLeftParen; sStart := GetInteger; RangeCheck(sStart); GetComma; sEnd := GetInteger; RangeCheck(sEnd); GetRightParen; if Token <> DoneT then begin DisableDensitySlice; if (sEnd < sStart) or ((sStart = 0) and (sEnd = 0)) then exit(SetDensitySlice); if not ((sStart = 255) and (sEnd = 255)) then begin SliceStart := sStart; SliceEnd := sEnd; end; if thresholding then ResetGrayMap; EnableDensitySlice; end; end; procedure SetColor; var index: integer; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; index := GetInteger; GetRightParen; RangeCheck(index); if Token <> DoneT then begin if SaveCommand = SetForeC then SetForegroundColor(index) else SetBackgroundColor(index); end; end; procedure DoConstantArithmetic; var constant: extended; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; constant := GetExpression; GetRightParen; if token <> DoneT then case SaveCommand of AddConstC: DoArithmetic(AddItem, constant); MulConstC: DoArithmetic(MultiplyItem, constant); end; end; procedure GetNextWindow; var n: integer; begin n := info^.PicNum + 1; if n > nPics then n := 1; KillRoi; Info := pointer(WindowPeek(PicWindow[n])^.RefCon); SetPort(info^.wptr); IsInsertionPoint := false; WhatToUndo := NothingToUndo; UndoFromClip := false; end; procedure DoRevert; begin if info^.revertable then begin RevertToSaved; UpdatePicWindow; end else MacroError('Unable to revert'); end; procedure MakeRoi; var Left, Top, Width, Height: integer; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; left := GetInteger; GetComma; top := GetInteger; GetComma; width := GetInteger; GetComma; height := GetInteger; GetRightParen; KillRoi; if token <> DoneT then with Info^ do begin StopDigitizing; if SaveCommand = MakeOvalC then RoiType := OvalRoi else RoiType := RectRoi; SetRect(RoiRect, left, top, left + width, top + height); MakeRegion; SetupUndo; RoiShowing := true; end; end; procedure MoveRoi; var DeltaH, DeltaV: integer; begin GetLeftParen; DeltaH := GetInteger; GetComma; DeltaV := GetInteger; GetRightParen; with info^ do begin if not RoiShowing then begin MacroError('No Selection'); exit(MoveRoi); end; OffsetRgn(roiRgn, DeltaH, DeltaV); RoiRect := roiRgn^^.rgnBBox; RoiUpdateTime := 0; MacroOpPending := true; end; end; procedure InsetRoi; var delta: integer; begin GetLeftParen; delta := GetInteger; GetRightParen; with info^ do begin if not RoiShowing then begin MacroError('No Selection'); exit(InsetRoi); end; InsetRgn(roiRgn, delta, delta); RoiRect := roiRgn^^.rgnBBox; RoiUpdateTime := 0; MacroOpPending := true; end; end; procedure DoMoveTo; {(x,y:integer)} begin GetLeftParen; CurrentX := GetInteger; GetComma; CurrentY := GetInteger; GetRightParen; InsertionPoint.h := CurrentX; InsertionPoint.v := CurrentY + 4; end; procedure DoDrawtext (str: str255; EndOfLine: boolean); begin KillRoi; DrawTextString(str, InsertionPoint, TextJust); if EndOfLine then begin CurrentY := CurrentY + CurrentSize; InsertionPoint.h := CurrentX; InsertionPoint.v := CurrentY + 4; end; end; procedure DrawNumber; var n: extended; str: str255; fwidth: integer; begin GetLeftParen; n := GetExpression; GetRightParen; if token <> DoneT then begin if n = trunc(n) then fwidth := 0 else fwidth := precision; RealToString(n, 1, fwidth, str); DoDrawText(str, true); end; end; procedure MakeLowerCase (var str: str255); var i: integer; c: char; begin for i := 1 to length(str) do begin c := str[i]; if (c >= 'A') and (c <= 'Z') then str[i] := chr(ord(c) + 32); end; end; procedure SetFont; var FontName: str255; id: integer; begin FontName := GetStringArg; if Token <> DoneT then begin GetFNum(FontName, id); if id = 0 then MacroError('Font not available') else CurrentFontID := id; end; end; procedure SetFontSize; var size: integer; begin GetLeftParen; Size := GetInteger; GetRightParen; if Token <> DoneT then CurrentSize := size; end; procedure SetText; var Attributes: str255; begin Attributes := GetStringArg; if Token <> DoneT then begin MakeLowerCase(Attributes); if pos('with', Attributes) <> 0 then TextBack := WithBack; if pos('no', Attributes) <> 0 then TextBack := NoBack; if pos('left', Attributes) <> 0 then TextJust := teJustLeft; if pos('center', Attributes) <> 0 then TextJust := teJustCenter; if pos('right', Attributes) <> 0 then TextJust := teJustRight; CurrentStyle := []; if pos('bold', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Bold]; if pos('italic', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Italic]; if pos('underline', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Underline]; if pos('outline', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Outline]; if pos('shadow', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Shadow]; end; end; procedure DoPutMessage; var str: str255; begin GetArguments(str); if Token <> DoneT then PutMessage(str) end; function GetVar: integer; begin GetVar := 0; GetToken; if token <> Variable then MacroError('Variable expected') else GetVar := TokenStackLoc; end; procedure GetPicSize; {(width,height)} var loc1, loc2: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^ do if info = NoInfo then begin stack[loc1].value := 0.0; stack[loc2].value := 0.0; end else with info^ do begin stack[loc1].value := PixelsPerLine; stack[loc2].value := nLines; end; end; procedure GetRoi; {(hloc,vloc,width,height)} var loc1, loc2, loc3, loc4: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetComma; loc3 := GetVar; GetComma; loc4 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^, Info^ do if RoiShowing then with RoiRect do begin stack[loc1].value := left; stack[loc2].value := top; stack[loc3].value := right - left; stack[loc4].value := bottom - top; end else begin stack[loc1].value := 0.0; stack[loc2].value := 0.0; stack[loc3].value := 0.0; stack[loc4].value := 0.0; end; end; procedure CaptureOneFrame; begin if FrameGrabber <> QuickCapture then MacroError('DT2255 frame grabber not installed') else begin StartDigitizing; CaptureAndDisplayQCFrame; StopDigitizing; end; end; procedure DoMakeNewWindow; {(name:str255)} var name: str255; begin GetArguments(name); if token <> DoneT then if (LongInt(NewPicWidth) * NewPicHeight) > UndoBufSize then MacroError('New window larger than Undo buffer') else if not NewPicWindow(name, NewPicWidth, NewPicHeight) then MacroError('Out of memory'); end; procedure DoSetPalette; var PaletteType: str255; ok: boolean; begin PaletteType := GetStringArg; if token <> DoneT then begin MakeLowerCase(PaletteType); if pos('gray', PaletteType) <> 0 then ResetGrayMap else if pos('pseudo', PaletteType) <> 0 then SwitchColorTables(Pseudo20Item, true) else if pos('system', PaletteType) <> 0 then SwitchColorTables(SystemPaletteItem, true) else if pos('rainbow', PaletteType) <> 0 then SwitchColorTables(RainbowItem, true) else if pos('spectrum', PaletteType) <> 0 then SwitchColorTables(SpectrumItem, true) end; end; procedure DoOpenImage; var err: OSErr; f: integer; FileFound, result: boolean; fname: str255; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetArguments(fname); if token <> DoneT then begin if fname = '' then fname := DefaultFileName; err := fsopen(fname, DefaultRefNum, f); FileFound := err = NoErr; err := fsclose(f); if FileFound then case SaveCommand of OpenC: result := DoOpen(fname, DefaultRefNum); ImportC: result := ImportFile(fname, DefaultRefNum); end else case SaveCommand of OpenC: result := DoOpen('', 0); ImportC: result := ImportFile('', 0); end; if not result then token := DoneT; end; end; procedure SetImportAttributes; var Attributes: str255; begin Attributes := GetStringArg; if Token <> DoneT then begin MakeLowerCase(Attributes); WhatToImport := ImportTIFF; ImportCustomDepth := EightBits; ImportSwapBytes := false; ImportCalibrate := false; ImportAll := false; ImportAutoScale := true; if pos('mcid', Attributes) <> 0 then WhatToImport := ImportMCID; if pos('look', Attributes) <> 0 then WhatToImport := ImportLUT; if pos('palette', Attributes) <> 0 then WhatToImport := ImportLUT; if pos('text', Attributes) <> 0 then WhatToImport := ImportText; if pos('custom', Attributes) <> 0 then WhatToImport := ImportCustom; if (pos('8', Attributes) <> 0) or (pos('eight', Attributes) <> 0) then begin ImportCustomDepth := EightBits; WhatToImport := ImportCustom; end; if (pos('signed', Attributes) <> 0) then begin ImportCustomDepth := SixteenBitsSigned; WhatToImport := ImportCustom; end; if (pos('unsigned', Attributes) <> 0) then begin ImportCustomDepth := SixteenBitsUnsigned; WhatToImport := ImportCustom; end; if (pos('swap', Attributes) <> 0) then ImportSwapBytes := true; if (pos('calibrate', Attributes) <> 0) then ImportCalibrate := true; if (pos('fixed', Attributes) <> 0) then ImportAutoScale := false; if (pos('all', Attributes) <> 0) then ImportAll := true; end; end; procedure SetImportMinMax; {(min,max:integer)} var TempMin, TempMax: extended; begin GetLeftParen; TempMin := GetExpression; GetComma; TempMax := GetExpression; GetRightParen; if Token <> DoneT then begin ImportAutoScale := false; ImportMin := TempMin; ImportMax := TempMax; end; end; procedure SetCustomImport; {(width,height,offset:integer)} var width, height: integer; offset: LongInt; begin GetLeftParen; width := GetInteger; GetComma; height := GetInteger; GetComma; offset := GetInteger; GetRightParen; if (width < 0) or (width > MaxPicSize) or (height < 0) or (offset < 0) then MacroError('Argument out of range'); if Token <> DoneT then begin ImportCustomWidth := width; ImportCustomHeight := height; ImportCustomOffset := offset; WhatToImport := ImportCustom; end; end; procedure SelectPic; {(WindowID:integer)} var WindowID: integer; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; WindowID := GetInteger; if (WindowID < 1) or (WindowID > nPICS) then MacroError('Invalid window ID'); GetRightParen; if Token <> DoneT then begin if SaveCommand = SelectPicC then begin StopDigitizing; SaveRoi; DisableDensitySlice; SelectWindow(PicWindow[WindowID]); Info := pointer(WindowPeek(PicWindow[WindowID])^.RefCon); ActivateWindow; end else Info := pointer(WindowPeek(PicWindow[WindowID])^.RefCon); end; end; procedure SetPicName; {(name:string)} var n, i: LongInt; isInteger: boolean; name: str255; begin GetArguments(name); if Token <> DoneT then begin with info^ do begin title := name; if PictureType <> QuickCaptureType then PictureType := NewPicture; UpdateWindowsMenuItem(ImageSize, title, PicNum); UpdateTitleBar; end; end; end; procedure SetNewSize; {(width,height:integer)} var TempWidth, TempHeight: integer; begin GetLeftParen; TempWidth := GetInteger; GetComma; TempHeight := GetInteger; GetRightParen; if Token <> DoneT then begin NewPicWidth := TempWidth; NewPicHeight := TempHeight; if odd(NewPicWidth) then NewPicWidth := NewPicWidth + 1; if NewPicWidth > MaxPicSize then NewPicWidth := MaxPicSize; if NewPicWidth < 8 then NewPicWidth := 8; if NewPicHeight < 8 then NewPicHeight := 8; if NewPicHeight > MaxPicSize then NewPicHeight := MaxPicSize; end; end; procedure DoSaveAs; var name: str255; RefNum: integer; HasArgs: boolean; begin name := info^.title; if (name = 'Untitled') or (name = 'Camera') then name := ''; GetToken; HasArgs := token = LeftParen; PutTokenBack; if HasArgs then GetArguments(name); if token <> DoneT then begin StopDigitizing; if nSaves = 0 then RefNum := 0 else RefNum := DefaultRefNum; SaveAs(name, RefNum); nSaves := nSaves + 1; end; end; procedure DoExport; var name: str255; RefNum: integer; begin StopDigitizing; name := info^.title; if (name = 'Untitled') or (name = 'Camera') then name := ''; if nSaves = 0 then RefNum := 0 else RefNum := DefaultRefNum; UpdateFileMenu; Export(name, RefNum); nSaves := nSaves + 1; end; procedure DoCopyResults; var IgnoreResult: boolean; begin if mCount < 1 then MacroError('Copy Results failed') else begin CopyResults; IgnoreResult := SystemEdit(3); {Fake Copy needed for MultiFinder} end; end; procedure DisposeAll; var i, ignore: integer; begin StopDigitizing; for i := nPics downto 1 do begin Info := pointer(WindowPeek(PicWindow[i])^.RefCon); ignore := CloseAWindow(info^.wptr); end; end; procedure DoDuplicate; var str: str255; begin GetArguments(str); if token <> DoneT then if not Duplicate(str, false) then token := DoneT else UpdatePicWindow; end; procedure DoLineTo; {(x,y:integer)} var x, y: integer; p1, p2: point; begin GetLeftParen; p2.h := GetInteger; GetComma; p2.v := GetInteger; GetRightParen; if token <> DoneT then begin p1.h := CurrentX; p1.v := CurrentY; CurrentX := p2.h; CurrentY := p2.v; OffscreenToScreen(p1); OffscreenToScreen(p2); DrawObject(LineObj, p1, p2); end; end; procedure DoGetLine; {(var x1,y1,x2,y2:real; LineWidth:integer)} var loc1, loc2, loc3, loc4, loc5: integer; x1, y1, x2, y2: real; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetComma; loc3 := GetVar; GetComma; loc4 := GetVar; GetComma; loc5 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^, info^ do begin GetLoi(x1, y1, x2, y2); if RoiShowing and (RoiType = LineRoi) then stack[loc1].value := x1 else stack[loc1].value := -1; stack[loc2].value := y1; stack[loc3].value := x2; stack[loc4].value := y2; stack[loc5].value := LineWidth; end; end; procedure SetChannel; {(channel:integer)} var channel: integer; begin GetLeftParen; channel := GetInteger; GetRightParen; if (channel < 0) or (channel > 3) then MacroError('Bad channel number') else VideoChannel := channel; end; procedure DoScaleAndRotate; {(hscale,vscale,angle:real)} var SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; rsHScale := GetExpression; GetComma; rsVScale := GetExpression; if SaveCommand <> ScaleSelectionC then begin GetComma; rsAngle := GetExpression; end; GetRightParen; if token <> DoneT then begin if SaveCommand = ScaleSelectionC then begin rsMethod := NearestNeighbor; rsCreateNewWindow := false; rsAngle := 0.0; end; ScaleAndRotate; end; end; procedure SetPlotScale; {(min,max:integer)} var min, max: extended; begin GetLeftParen; min := GetExpression; GetComma; max := GetExpression; GetRightParen; if not info^.DensityCalibrated then begin RangeCheck(trunc(min)); RangeCheck(trunc(max)); end; if token <> DoneT then begin AutoScalePlots := (min = 0.0) and (max = 0.0); ProfilePlotMin := min; ProfilePlotMax := max; end; end; procedure SetPlotDimensions; {(width,height:integer)} var width, height: integer; begin GetLeftParen; width := GetInteger; GetComma; height := GetInteger; GetRightParen; if token <> DoneT then begin FixedSizePlot := not ((width = 0) and (height = 0)); ProfilePlotWidth := width; ProfilePlotHeight := height; end; end; procedure GetResults; {(var n,mean,mode,min,max:real)} var loc1, loc2, loc3, loc4, loc5: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetComma; loc3 := GetVar; GetComma; loc4 := GetVar; GetComma; loc5 := GetVar; GetRightParen; if mCount = 0 then MacroError('No results'); if Token <> DoneT then with MacrosP^, results do begin stack[loc1].value := PixelCount^[mCount]; stack[loc2].value := imean; stack[loc3].value := imode; stack[loc4].value := MinIndex; stack[loc5].value := MaxIndex; end; end; procedure DoPasteOperation; begin if not (OpPending and (CurrentOp = PasteOp)) then begin MacroError('Not pasting'); exit(DoPasteOperation); end; if MacroCommand in [AddC, SubC, MulC, DivC] then begin case MacroCommand of AddC: CurrentOp := AddOp; SubC: CurrentOp := SubtractOp; MulC: CurrentOp := MultiplyOp; DivC: CurrentOp := DivideOp; end; DoMath; exit(DoPasteOperation); end; case MacroCommand of CopyModeC: SetPasteMode(CopyModeItem); AndC: SetPasteMode(AndItem); OrC: SetPasteMode(OrItem); XorC: SetPasteMode(XorItem); ReplaceC: SetPasteMode(ReplaceItem); BlendC: SetPasteMode(BlendItem); end; if OptionKeyWasDown then begin if PasteControl <> nil then DrawPasteControl; end else KillRoi; end; procedure SetLineWidth; {(width:integer)} var width: integer; begin GetLeftParen; width := GetInteger; GetRightParen; if (Token <> DoneT) and (width > 0) then begin LineWidth := width; ShowLIneWidth; end; end; function GetMType (index: integer): MeasurementTypes; begin case index of 0: GetMType := AreaM; 1: GetMType := MeanM; 2: GetMType := StdDevM; 3: GetMType := xyLocM; 4: GetMType := ModeM; 5: GetMType := LengthM; 6: GetMType := MajorAxisM; 7: GetMType := MinorAxisM; 8: GetMType := AngleM; 9: GetMType := IntDenM; 10: GetMType := MinMaxM; 11: GetMType := User1M; 12: GetMType := User2M; end; end; procedure SetMeasurements; var index: integer; mtype: MeasurementTypes; begin index := ord(MacroCommand) - ord(AreaC); mtype := GetMType(index); if GetBooleanArg then measurements := measurements + [mtype] else measurements := measurements - [mtype]; UpdateFitEllipse; end; procedure SetPrecision; {(DigitsRightofDecimalPoint:integer)} var digits: LongInt; begin GetLeftParen; digits := GetInteger; GetRightParen; if (Token <> DoneT) and (digits >= 0) and (digits <= 12) then precision := digits; end; procedure SetParticleSize; {(min,max:LongInt)} var min, max: LongInt; begin GetLeftParen; min := GetInteger; GetComma; max := GetInteger; GetRightParen; if Token <> DoneT then begin MinParticleSize := min; MaxParticleSize := max; end; end; procedure SetThreshold; {(level:integer)} var level: LongInt; begin GetLeftParen; level := GetInteger; GetRightParen; if level = -1 then begin ResetGrayMap; exit(SetThreshold); end; RangeCheck(level); if Token <> DoneT then EnableThresholding(level); end; procedure DoPutPixel; {(hloc,vloc, value:integer)} var hloc, vloc, value: integer; MaskRect: rect; begin GetLeftParen; hloc := GetInteger; GetComma; vloc := GetInteger; GetComma; value := GetInteger; GetRightParen; if (Token <> DoneT) and (info <> NoInfo) then begin PutPixel(hloc, vloc, value); SetRect(MaskRect, hloc, vloc, hloc + 1, vloc + 1); UpdateScreen(MaskRect); end; end; procedure ClosePicWindow; var OldPicNum, NewPicNum, ignore: integer; begin StopDigitizing; SaveRoi; with info^ do begin OldPicNum := PicNum; ignore := CloseAWindow(wptr); end; if nPics >= 1 then begin NewPicNum := OldPicNum - 1; if NewPicNum < 1 then NewPicNum := 1; Info := pointer(WindowPeek(PicWindow[NewPicNum])^.RefCon); end; end; procedure SetScaling; var ScalingOptions: str255; ok: boolean; begin ScalingOptions := GetStringArg; if token <> DoneT then begin MakeLowerCase(ScalingOptions); rsInteractive := false; if pos('bilinear', ScalingOptions) <> 0 then rsMethod := Bilinear; if pos('nearest', ScalingOptions) <> 0 then rsMethod := NearestNeighbor; if pos('new', ScalingOptions) <> 0 then rsCreateNewWindow := true; if pos('same', ScalingOptions) <> 0 then rsCreateNewWindow := false; if pos('interactive', ScalingOptions) <> 0 then rsInteractive := true; end; end; procedure DoChangeValues; {(v1,v2,v3:integer)} var v1, v2, v3: integer; begin GetLeftParen; v1 := GetInteger; GetComma; v2 := GetInteger; GetComma; v3 := GetInteger; GetRightParen; RangeCheck(v1); RangeCheck(v2); RangeCheck(v3); if Token <> DoneT then ChangeValues(v1, v2, v3); end; procedure DoGetMouse; {(var x,y:integer)} var loc1, loc2, sh, sv: integer; loc: point; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^ do begin SetPort(info^.wptr); GetMouse(loc); with loc do begin sh := h; sv := v; ScreenToOffscreen(loc); if sh < 0 then h := sh; if sv < 0 then v := sv; stack[loc1].value := h; stack[loc2].value := v; end; end; end; procedure DoRotate (cmd: CommandType); var NoBoolean, NewWindow: boolean; begin GetToken; noBoolean := token <> LeftParen; PutTokenBack; if NoBoolean then NewWindow := false else NewWindow := GetBooleanArg; if NewWindow then begin case cmd of RotateRC: RotateToNewWindow(RotateRight); RotateLC: RotateToNewWindow(RotateLeft) end; if not macro then MacroError('Rotate failed') end else case cmd of RotateRC: FlipOrRotate(RotateRight); RotateLC: FlipOrRotate(RotateLeft) end; end; procedure DoSelectSlice; {(SliceNumber:integer)} var SliceNumber: LongInt; isRoi: boolean; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; SliceNumber := GetInteger; GetRightParen; with info^, info^.StackInfo^ do begin if (SliceNumber < 1) or (SliceNumber > nSlices) then MacroError('Illegal slice number'); if Token <> DoneT then begin isRoi := RoiShowing; if isRoi then KillRoi; CurrentSlice := SliceNumber; SelectSlice(CurrentSlice); if SaveCommand = SelectSliceC then begin UpdatePicWindow; UpdateTitleBar; end; if isRoi then RestoreRoi; end; end; end; procedure MakeNewStack; {(name:str255)} var name: str255; aok: boolean; begin GetArguments(name); if token <> DoneT then if (LongInt(NewPicWidth) * NewPicHeight) > UndoBufSize then MacroError('Stack too large') else if NewPicWindow(name, NewPicWidth, NewPicHeight) then if not MakeStackFromWindow then MacroError('Out of memory'); end; procedure MakeLineRoi; {(x1,y1,x2,y2:integer)} var x1, y1, x2, y2: LongInt; begin GetLeftParen; x1 := GetInteger; GetComma; y1 := GetInteger; GetComma; x2 := GetInteger; GetComma; y2 := GetInteger; GetRightParen; if token <> DoneT then with Info^ do begin KillRoi; StopDigitizing; LX1 := x1; LY1 := y1; LX2 := x2; LY2 := y2; RoiType := LineRoi; MakeRegion; SetupUndo; RoiShowing := true; end; end; procedure DoGetTime; var date: DateTimeRec; loc1, loc2, loc3, loc4, loc5, loc6, loc7: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetComma; loc3 := GetVar; GetComma; loc4 := GetVar; GetComma; loc5 := GetVar; GetComma; loc6 := GetVar; GetComma; loc7 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^, info^ do begin GetTime(date); with date do begin stack[loc1].value := year; stack[loc2].value := month; stack[loc3].value := day; stack[loc4].value := hour; stack[loc5].value := minute; stack[loc6].value := second; stack[loc7].value := DayOfWeek; end; end; end; procedure DoSetScale; {(scale:real; units:string)} var id: integer; scale: extended; str: str255; begin GetLeftParen; scale := GetExpression; GetComma; str := GetString; GetRightParen; if token <> DoneT then with info^ do begin if str = '' then begin SetScale; exit(DoSetScale); end; if scale < 0.0 then begin MacroError('Scale<0'); exit(DoSetScale); end; MakeLowerCase(str); if pos('nm', str) <> 0 then id := 5 else if pos('â•¡m', str) <> 0 then id := 6 else if pos('mm', str) <> 0 then id := 7 else if pos('cm', str) <> 0 then id := 8 else if pos('me', str) <> 0 then id := 9 else if pos('km', str) <> 0 then id := 10 else if pos('in', str) <> 0 then id := 11 else if pos('ft', str) <> 0 then id := 12 else if pos('mi', str) <> 0 then id := 13 else id := 14; {pixels} RawSpatialScale := scale; xSpatialScale := scale; ySpatialScale := scale; PixelAspectRatio := 1.0; ScaleMagnification := 1.0; SpatiallyCalibrated := xSpatialScale <> 0.0; GetUnits(id); end; end; procedure SaveState; begin SaveForeground := ForegroundIndex; SaveBackground := BackgroundIndex; SavePicWidth := NewPicWidth; SavePicHeight := NewPicHeight; SaveMethod := rsMethod; SaveCreate := rsCreateNewWindow; SaveAngle := rsAngle; SaveH := rsHScale; SaveV := rsVScale; SaveInvertY := InvertYCoordinates; end; procedure RestoreState; begin if SaveForeground = -1 then MacroError('State not saved') else begin SetForegroundColor(SaveForeground); SetBackgroundColor(SaveBackground); NewPicWidth := SavePicWidth; NewPicHeight := SavePicHeight; rsMethod := SaveMethod; rsCreateNewWindow := SaveCreate; rsAngle := SaveAngle; rsHScale := SaveH; rsVScale := SaveV; InvertYCoordinates := SaveInvertY; end; end; procedure DoPrint; begin FindWhatToPrint; if WhatToPrint <> NothingToPrint then Print(false) else MacroError('NothingToPrint'); end; procedure SetCounter; {(n:integer)} var N, i: LongInt; begin GetLeftParen; N := GetInteger; GetRightParen; if (N < 0) or (N > MaxRegions) then MacroError('Argument out of range'); if Token <> DoneT then begin if N = 0 then ResetCounter; for i := mCount + 1 to N do ClearResults(i); mCount := N; UpdateList; ShowValues; end; end; procedure OutputText; var NewLine: boolean; str: str255; i: integer; SaveCommand: CommandType; begin NewLine := MacroCommand <> WriteC; SaveCommand := MacroCommand; GetArguments(str); if token <> DoneT then begin if SaveCommand = ShowMsgC then begin for i := 1 to length(str) do if str[i] = '\' then str[i] := cr; ValuesMessage := str; ShowValues; end else DoDrawText(str, NewLine); end; end; procedure SetErosionDilationCount; {(n:integer)} var n: LongInt; begin GetLeftParen; n := GetInteger; GetRightParen; if (n < 1) or (n > 8) then MacroError('Argument out of range'); if Token <> DoneT then begin BinaryCount := n; BinaryThreshold := BinaryCount * 255; end; end; procedure SetSliceSpacing; {(n:real)} var n: real; begin GetLeftParen; n := GetExpression; GetRightParen; if (n <= 0.0) or (n > 100.0) then MacroError('Spacing must be >0 and <100'); if info^.StackInfo = nil then MacroError('No stack'); if Token <> DoneT then info^.StackInfo^.SliceSpacing := n; end; {$POP} procedure GetOrPutLineOrColumn; {(x,y,count:integer:integer)} var x, y, count, i: integer; MaskRect: rect; aLine2: LineType; begin GetLeftParen; x := GetInteger; GetComma; y := GetInteger; GetComma; count := GetInteger; GetRightParen; if (Token <> DoneT) and (count <= MaxLine) then with MacrosP^ do case MacroCommand of GetRowC: GetLine(x, y, count, aLine); PutRowC: begin PutLine(x, y, count, aLine); SetRect(MaskRect, x, y, x + count, y + 1); UpdateScreen(MaskRect); end; GetColumnC: GetColumn(x, y, count, aLine); PutColumnC: begin PutColumn(x, y, count, aLine); SetRect(MaskRect, x, y, x + 1, y + count); UpdateScreen(MaskRect); end; end; end; procedure CheckVersion; {(RequiredVersion:real)} var RequiredVersion: real; str: str255; begin GetLeftParen; RequiredVersion := GetExpression; GetRightParen; if (Token <> DoneT) then if (RequiredVersion * 100.0) > version then begin RealToString(RequiredVersion, 1, 2, str); PutMessage(concat('This macro requires version ', str, ' or later of Image.')); Token := DoneT; end; end; procedure SetOptions; {(Options:string)} var options: str255; mtype: MeasurementTypes; i, LastOption: integer; SaveMeasurements: set of MeasurementTypes; begin GetLeftParen; Options := GetString; GetRightParen; if (Token <> DoneT) then begin SaveMeasurements := measurements; MakeLowerCase(options); Measurements := []; if pos('area', options) <> 0 then Measurements := Measurements + [AreaM]; if pos('mean', options) <> 0 then Measurements := Measurements + [MeanM]; if pos('st', options) <> 0 then Measurements := Measurements + [StdDevM]; if pos('center', options) <> 0 then Measurements := Measurements + [xyLocM]; if pos('mode', options) <> 0 then Measurements := Measurements + [ModeM]; if (pos('per', options) <> 0) or (pos('length', options) <> 0) then Measurements := Measurements + [LengthM]; if pos('major', options) <> 0 then Measurements := Measurements + [MajorAxisM]; if pos('minor', options) <> 0 then Measurements := Measurements + [MinorAxisM]; if pos('angle', options) <> 0 then Measurements := Measurements + [AngleM]; if pos('int', options) <> 0 then Measurements := Measurements + [IntDenM]; if pos('max', options) <> 0 then Measurements := Measurements + [MinMaxM]; if pos('1', options) <> 0 then Measurements := Measurements + [User1M]; if pos('2', options) <> 0 then Measurements := Measurements + [User2M]; UpdateFitEllipse; if Measurements <> SaveMeasurements then UpdateList; end; end; procedure SetLabel; var SaveCommand: CommandType; str, SaveLabel: str255; begin SaveCommand := MacroCommand; GetArguments(str); case SaveCommand of SetMajorC: begin SaveLabel := MajorLabel; MajorLabel := str; Measurements := Measurements + [MajorAxisM]; end; SetMinorC: begin SaveLabel := MinorLabel; MinorLabel := str; Measurements := Measurements + [MinorAxisM]; end; SetUser1C: begin SaveLabel := User1Label; User1Label := str; Measurements := Measurements + [User1M]; end; SetUser2C: begin SaveLabel := User2Label; User2Label := str; Measurements := Measurements + [User2M]; end; end; {case} ShowValues; if str <> SaveLabel then UpdateList; end; procedure ExecuteCommand; var AutoSelectAll: boolean; t: FateTable; {Needed for MakeSkeleton} str: str255; aok: boolean; begin if (Info = NoInfo) and not (MacroCommand in [StartC, ShowResultsC, GetPicSizeC, PutMsgC, ExitC, CaptureC, MoveToC, BeepC, MakeNewC, SetPaletteC, SetBackC, GetRoiC, OpenC, ImportC, SetImportC, SetMinMaxC, SetCustomC, nPicsC, WaitC, SetSizeC, AreaC, DensityC, StdC, XyC, ModeC, PerimeterC, MajorC, MinorC, AngleC, IntDensityC, TriggerC, AverageFramesC, SaveStateC, RestoreStateC, SetCounterC, MakeStackC, ShowMsgC]) then begin MacroError('No image window active'); exit(ExecuteCommand); end; if DoOption then begin OptionKeyWasDown := true; DoOption := false; end; if OpPending then if not (MacroCommand in [CopyModeC, AndC, OrC, XorC, BlendC, ReplaceC, AddC, SubC, MulC, DivC, SetOptionC]) then KillRoi; {Terminate any pending paste operation.} MacroOpPending := false; case MacroCommand of RotateRC, RotateLC: DoRotate(MacroCommand); FlipVC: FlipOrRotate(FlipVertical); FlipHC: FlipOrRotate(FlipHorizontal); CopyC: begin FindWhatToCopy; if WhatToCopy = NothingToCopy then MacroError('Copy failed') else DoCopy; end; SelectC: begin StopDigitizing; SelectAll(true); end; PasteC: DoPaste; ClearC, FillC, InvertC, FrameC: with info^ do begin AutoSelectAll := not RoiShowing; if AutoSelectAll then SelectAll(true); case MacroCommand of ClearC: DoOperation(EraseOp); FillC: DoOperation(PaintOp); InvertC: DoOperation(InvertOp); FrameC: DoOperation(FrameOp); end; UpdateScreen(RoiRect); if AutoSelectAll then KillRoi else MacroOpPending := true; end; KillC: KillRoi; RestoreC: if NoInfo^.RoiType <> NoRoi then RestoreRoi; AnalyzeC: AnalyzeParticles; ConvolveC: DoConvolve; NextC: GetNextWindow; MarkC: MarkSelection(mCount); MeasureC: Measure; MakeBinC: MakeBinary; DitherC: Filter(Dither, 0, t); SmoothC: if OptionKeyWasDown then Filter(UnweightedAvg, 0, t) else Filter(WeightedAvg, 0, t); SharpenC: Filter(fsharpen, 0, t); ShadowC: Filter(fshadow, 0, t); TraceC: Filter(EdgeDetect, 0, t); ReduceC: Filter(ReduceNoise, 0, t); RedirectC: RedirectSampling := GetBooleanArg; ThresholdC: SetThreshold; ResetgmC: ResetGrayMap; WaitC: DoWait; ResetmC: ResetCounter; SetSliceC: SetDensitySlice; UndoC: DoUndo; SetForeC, SetBackC: SetColor; HistoC: begin DoHistogram; DrawHistogram; end; EnhanceC: EnhanceContrast; EqualizeC: EqualizeHistogram; ErodeC: DoErosion; DilateC: DoDilation; OutlineC: filter(OutlineFilter, 0, t); ThinC: MakeSkeleton; AddConstC, MulConstC: DoConstantArithmetic; RevertC: DoRevert; BeepC: Beep; NopC: ; MakeC, MakeOvalC: MakeRoi; MoveC: MoveRoi; InsetC: InsetRoi; MoveToC: DoMoveTo; DrawTextC, WriteC, WritelnC, ShowMsgC: OutputText; SetFontC: SetFont; SetFontSizeC: SetFontSize; SetTextC: SetText; DrawNumC: DrawNumber; ExitC: token := DoneT; GetPicSizeC: GetPicSize; PutMsgC: DoPutMessage; GetRoiC: GetRoi; MakeNewC: DoMakeNewWindow; DrawScaleC: if info^.RoiShowing then begin DrawScale; UpdatePicWindow end else MacroError('No Selection'); SetPaletteC: DoSetPalette; OpenC, ImportC: DoOpenImage; SetImportC: SetImportAttributes; SetMinMaxC: SetImportMinMax; SetCustomC: SetCustomImport; SelectPicC, ChoosePicC: SelectPic; SetPicNameC: SetPicName; ApplyLutC: ApplyLookupTable; SetSizeC: SetNewSize; SaveC: begin StopDigitizing; with info^ do if (PictureType = TiffFile) or (PictureType = PictFile) then SaveFile else DoSaveAs; end; SaveAllC: SaveAll; SaveAsC: DoSaveAs; CopyResultsC: DoCopyResults; CloseC, DisposeC: ClosePicWindow; DisposeAllC: DisposeAll; DupC: DoDuplicate; GetInfoC: GetInfo; PrintC: DoPrint; LineToC: DoLineTo; GetLineC: DoGetLine; ShowPasteC: if PasteControl = nil then ShowPasteControl else BringToFront(PasteControl); ChannelC: SetChannel; ColumnC, PlotProfileC: begin PlotDensityProfile; if PlotWindow <> nil then UpdatePlotWindow; end; ScaleC, ScaleSelectionC: DoScaleAndRotate; SetOptionC: DoOption := true; SetLabelsC: DrawPlotLabels := GetBooleanArg; SetPlotScaleC: SetPlotScale; SetDimC: SetPlotDimensions; GetResultsC: GetResults; CopyModeC, AndC, OrC, XorC, BlendC, ReplaceC, AddC, SubC, MulC, DivC: DoPasteOperation; ScaleMathC: ScaleArithmetic := GetBooleanArg; InvertYC: InvertYCoordinates := GetBooleanArg; SetWidthC: SetLineWidth; ShowResultsC: begin ShowResults; UpdateList end; StartC: StartDigitizing; StopC: StopDigitizing; CaptureC: CaptureOneFrame; GetRowC, PutRowC, GetColumnC, PutColumnC: GetOrPutLineOrColumn; PlotXYZC: PlotXYZ; IncludeC: IncludeHoles := GetBooleanArg; AutoC: WandAutoMeasure := GetBooleanArg; AreaC, DensityC, StdC, XyC, ModeC, PerimeterC, MajorC, MinorC, AngleC, IntDensityC, MinMaxC: SetMeasurements; LabelC: LabelParticles := GetBooleanArg; OutlineParticlesC: OutlineParticles := GetBooleanArg; IgnoreC: IgnoreParticlesTouchingEdge := GetBooleanArg; AdjustC: WandAdjustAreas := GetBooleanArg; SetParticleSizeC: SetParticleSize; SetPrecisionC: SetPrecision; PutPixelC: DoPutPixel; ScalingOptionsC: SetScaling; ExportC: DoExport; ChangeC: DoChangeValues; UpdateResultsC: begin ShowValues; DeleteLines(mCount, mCount); AppendResults; end; TileC: TileWindows; SetMajorC, SetMinorC, SetUser1C, SetUser2C: SetLabel; GetMouseC: DoGetMouse; SelectSliceC, ChooseSliceC, AddSliceC, DeleteSliceC, ResliceC: begin if info^.StackInfo = nil then MacroError('No stack'); if token <> DoneT then case MacroCommand of SelectSliceC, ChooseSliceC: DoSelectSlice; AddSliceC: aok := AddSlice(true); DeleteSliceC: DeleteSlice; ResliceC: Reslice; end; end; MakeStackC: MakeNewStack; AverageFramesC: AverageFrames; TriggerC: WaitForTrigger; MakeLineC: MakeLineRoi; GetTimeC: DoGetTime; SetScaleC: DoSetScale; SaveStateC: SaveState; RestoreStateC: RestoreState; SetCounterC: SetCounter; UpdateLutC: LoadLUT(info^.ctable); SetCountC: SetErosionDilationCount; PropagateLutC: DoPropagate(1); PropagateSpatialC: DoPropagate(2); PropagateDensityC: DoPropagate(3); SetSpacingC: SetSliceSpacing; RequiresC: CheckVersion; SetOptionsC: SetOptions; end; {case} OptionKeyWasDown := false; end; procedure DoCompoundStatement; begin if token <> BeginT then MacroError('"begin" expected'); GetToken; while (token <> endT) and (token <> DoneT) do begin DoStatement; GetToken; if Token = SemiColon then GetToken; end; end; procedure DoDeclarations; begin if token = SemiColon then GetToken; if token = VarT then begin GetToken; while ((token = UnknownIdentifier) or (token = Variable)) and (Token <> DoneT) do DoDeclaration(false); CheckForReservedWord; end; end; procedure SkipStatement (Statement: TokenType); var count: integer; begin GetToken; if token = beginT then begin count := 1; repeat GetToken; case token of beginT: count := count + 1; endT: count := count - 1; DoneT: begin MacroError('"end" expected'); exit(SkipStatement); end; otherwise end; {case} until count = 0; end else begin while (token <> SemiColon) and (token <> endT) and not ((Statement = IfT) and (token = ElseT)) do begin GetToken; if token = DoneT then begin MacroError('";" or "end" expected'); exit(SkipStatement); end; end; {while} PutTokenBack; end; end; procedure DoFor; var SavePC, StackLoc: integer; StartValue, EndValue, i: LongInt; begin StackLoc := GetVar; GetToken; if token <> AssignOp then begin MacroError('":=" expected'); exit(DoFor); end; StartValue := GetInteger; if token = DoneT then exit(DoFor); GetToken; if token <> ToT then begin MacroError('"to" expected'); exit(DoFor); end; EndValue := GetInteger; if token = DoneT then exit(DoFor); GetToken; if token <> DoT then begin MacroError(DoExpected); exit(DoFor); end; SavePC := pc; if StartValue > EndValue then SkipStatement(ForT) else for i := StartValue to EndValue do with MacrosP^ do begin Stack[StackLoc].value := i; pc := SavePC; GetToken; DoStatement; if Token = DoneT then leave; if Digitizing then DoCapture; end; end; procedure DoAssignment; var SaveStackLoc: integer; begin SaveStackLoc := TokenStackLoc; GetToken; if token <> AssignOp then begin MacroError('":=" expected'); exit(DoAssignment); end; MacrosP^.stack[SaveStackLoc].value := GetExpression; end; procedure DoIf; var isTrue: boolean; begin isTrue := GetBoolean; GetToken; if token <> ThenT then MacroError('"then" expected'); if isTrue then begin GetToken; DoStatement end else SkipStatement(IfT); GetToken; if token = elseT then begin if isTrue then SkipStatement(NullT) else begin GetToken; DoStatement; end; end else PutTokenBack; end; procedure DoWhile; var isTrue: boolean; SavePC: integer; begin SavePC := pc; repeat pc := SavePC; isTrue := GetBoolean; GetToken; if token <> doT then MacroError(DoExpected); if isTrue then begin GetToken; DoStatement end else SkipStatement(WhileT); if Digitizing then DoCapture; until not isTrue or (Token = DoneT); end; procedure DoRepeat; var isTrue: boolean; SavePC: integer; begin SavePC := pc; isTrue := true; repeat pc := SavePC; GetToken; while (token <> untilT) and (token <> DoneT) do begin DoStatement; GetToken; if Token = SemiColon then GetToken; end; if token <> untilT then MacroError('"until" expected'); isTrue := GetBoolean; if Digitizing then DoCapture; until isTrue or (Token = DoneT); end; procedure PushArguments (var nArgs: integer); var arg: array[1..MaxArgs] of extended; i: integer; TempName: SymbolType; begin nArgs := 1; Arg[nArgs] := GetExpression; GetToken; while token = comma do begin if nArgs < MaxArgs then nArgs := nArgs + 1 else MacroError('Too many arguments'); arg[nArgs] := GetExpression; GetToken; end; if token <> RightParen then MacroError(RightParenExpected); for i := 1 to nArgs do begin if TopOfStack < MaxStackSize then TopOfStack := TopOfStack + 1 else MacroError(StackOverflow); with MacrosP^.stack[TopOfStack] do begin vType := RealVar; value := arg[i]; end; end; end; procedure DoProcedure; var SavePC, SavePCStart, SaveStackLoc, nArgs, i: integer; SaveProcName: SymbolType; begin SavePCStart := PCStart; PCStart := TokenLoc; SaveProcName := ProcName; ProcName := TokenSymbol; SaveStackLoc := TopOfStack; GetToken; if token = LeftParen then PushArguments(nArgs) else begin nArgs := 0; PutTokenBack; end; SavePC := pc; pc := pcStart; if nArgs > 0 then begin GetLeftParen; i := 0; GetToken; while token in [UnknownIdentifier, Variable, comma, colon, SemiColon, RealT, IntegerT, BooleanT] do begin if (token = UnknownIdentifier) or (token = Variable) then begin if i < nArgs then i := i + 1 else MacroError('Too many arguments'); MacrosP^.stack[SaveStackLoc + i].symbol := TokenSymbol; end; GetToken; end; if Token = VarT then MacroError('VAR parameters not supported'); if i < nArgs then MacroError('Too few arguments'); if token <> RightParen then MacroError(RightParenExpected); end; GetToken; if (token = LeftParen) and (nArgs = 0) then MacroError('Arguments not expected'); DoDeclarations; DoCompoundStatement; pc := SavePC; TopOfStack := SaveStackLoc; pcStart := SavePCStart; ProcName := SaveProcName; end; procedure DoArrayAssignment; var SaveCommand: CommandType; index, LutValue, PixelValue: LongInt; begin SaveCommand := MacroCommand; GetToken; if token <> LeftBracket then MacroError('"[" expected'); Index := GetInteger; GetToken; if token <> RightBracket then MacroError('"]" expected'); GetToken; if token <> AssignOp then MacroError('":=" expected'); if SaveCommand = BufferC then begin CheckIndex(index, 0, MaxLine - 1); PixelValue := GetInteger; RangeCheck(PixelValue); if token <> DoneT then MacrosP^.aLine[index] := PixelValue; exit(DoArrayAssignment); end; if SaveCommand in [RedLutC, BlueLutC, GreenLutC] then begin CheckIndex(index, 0, 255); LutValue := GetInteger; RangeCheck(LutValue); if token <> DoneT then with info^.cTable[index].rgb do case SaveCommand of RedLutC: red := bsl(LutValue, 8); GreenLutC: green := bsl(LutValue, 8); BlueLutC: blue := bsl(LutValue, 8); end; exit(DoArrayAssignment); end; CheckIndex(index, 1, MaxRegions); if token <> DoneT then case SaveCommand of rAreaC: mArea^[Index] := GetInteger; rMeanC: mean^[Index] := GetExpression; rStdDevC: sd^[Index] := GetExpression; rXC: xcenter^[Index] := GetExpression; rYC: ycenter^[Index] := GetExpression; rLengthC: plength^[Index] := GetExpression; rMinC: mMin^[Index] := GetExpression; rMaxC: mMax^[Index] := GetExpression; rMajorC: MajorAxis^[Index] := GetExpression; rMinorC: MinorAxis^[Index] := GetExpression; rAngleC: orientation^[Index] := GetExpression; rUser1C: User1^[Index] := GetExpression; rUser2C: User2^[Index] := GetExpression; otherwise MacroError('Read-only array'); end; {case} end; procedure DoStatement; begin case token of BeginT: DoCompoundStatement; CommandT: ExecuteCommand; ForT: DoFor; IfT: DoIf; WhileT: DoWhile; RepeatT: DoRepeat; UnknownIdentifier: MacroError('Undefined identifier'); Variable: DoAssignment; ArrayT: DoArrayAssignment; ProcedureT: DoProcedure; ElseT: MacroError('Statement expected'); otherwise end; if CommandPeriod or not macro then begin Token := DoneT; KillRoi; if macro then beep; end; end; procedure RunMacro (nMacro: integer); var count: integer; str: str255; SaveInfo: InfoPtr; begin if nPics > 0 then with info^ do {Activate image window so Copy won't fail.} if FrontWindow <> wptr then if wptr <> nil then SelectWindow(wptr); DefaultFileName := ''; str := ''; nSaves := 0; DefaultRefNum := 0; count := 0; pcStart := MacroStart[nMacro]; pc := pcStart; SavePC := pcStart; token := NullT; macro := true; if OpPending then begin KillRoi; RestoreRoi; end; MacroOpPending := false; DoOption := false; SaveInfo := info; TopOfStack := nGlobals; ProcName := BlankSymbol; GetToken; DoDeclarations; DoCompoundStatement; if (info <> SaveInfo) and (info <> NoInfo) then SelectWindow(info^.wptr); with info^, RoiRect do begin if ((right - left) <= 0) or ((bottom - top) <= 0) then KillRoi; end; if info^.RoiShowing then begin if MacroOpPending then begin KillRoi; RestoreRoi; end else UpdatePicWindow; end; macro := false; end; procedure RunKeyMacro (ch: char; KeyCode: integer); const FunctionKey = 16; var i: integer; begin if (ord(ch) = 0) then exit(RunKeyMacro); if (ch >= 'A') and (ch <= 'Z') then ch := chr(ord(ch) + 32); {Convert to lower case} if ord(ch) = FunctionKey then case KeyCode of 122: ch := 'A'; 120: ch := 'B'; 99: ch := 'C'; 118: ch := 'D'; 96: ch := 'E'; 97: ch := 'F'; 98: ch := 'G'; 100: ch := 'H'; 101: ch := 'I'; 109: ch := 'J'; 103: ch := 'K'; 111: ch := 'L'; 105: ch := 'M'; 107: ch := 'N'; 113: ch := 'O'; otherwise end; for i := 1 to nMacros do if ch = MacroKey[i] then begin RunMacro(i); leave; end; end; end. 
