1 {
2 XpresBas
3 ========
4 Por Tito Hinostroza.
5
6 Rutinas básicas del framework
7 Aquí están definidas las rutinas de manejo de error y los contextos de entrada
8 de Xpres.
9 Para ver los cambios en esta versión, revisar el archivo cambios.txt.
10 }
11
12 unit XpresBas;
13 {$mode objfpc}{$H+}
14 //{$define debug_mode}
15 interface
16 uses Classes, SysUtils, fgl,
17 Forms, LCLType, LCLProc, //Para mostrar mensajes con Application.MessageBox()
18 SynEditHighlighter, SynFacilHighlighter, SynFacilBasic;
19
20
21 type
22 //Posición dentro del código fuente
23 {Este tipo sirve para identificar la posicñon de algún elemento dentro del código
24 fuente. Tiene relación con un contexto, pero solo se remite a manejar ubicación.
25 No es lo mismo que TPosCont, que se usa para gaurdar posiciones dentro de un contexto
26 con fines de retomar la exploración.}
27
28 { TSrcPos }
29
30 TSrcPos = object
31 fil: string; //archivo donde se encuentra del elemento
32 row: integer; //número de línea del elemento
33 col: integer; //número de columna del elemento
RowColStringnull34 function RowColString: string;
EqualTonull35 function EqualTo(const target: TSrcPos): boolean;
36 end;
37 TSrcPosArray = array of TSrcPos;
38
39 //Tipos de contextos
40 tTypCon = (
41 TC_ARC, //contexto de tipo archivo
42 TC_TXT); //contexto de tipo texto
43
44 TContext = class;
45
46 {Posición dentro de un contexto. A diferencia de "TContext", es un registro y siempre
47 guardará una copia permanente. No guarda el contenido del contexto, sino una
48 referencia al objeto, que debe ser válida, para poder accederlo. EL objetivo de este
49 campos es poder posicionarse dentro de alguna parte del contexto, para hacer la
50 exploración nuevamente.}
51 TPosCont = record
52 fCon : TContext; //Referencia al Contexto
53 fPos : TFaLexerState; //Posición (estado) en el contexto
54 End;
55
56 { TPError }
57 {Define al objeto TPError, el que se usa para tratar los errores del compilador. Solo se
58 espera que haya uno de estos objetos, por eso se ha declarado como OBJECT}
59 TPError = object
60 private
61 numER : Integer; //codigo de error
62 cadER : String; //cadena de error
63 arcER : String; //nombre de archivo que origino el error
64 fil : Longint; //número de línea del error
65 col : Longint; //número de columna del error
66 public
67 NombPrograma: string; //Usado para poner en el encabezado del mensaje
68 procedure IniError;
69 procedure Clear;
70 procedure GenError(msje: String; archivo: String; nlin: LongInt);
71 procedure Generror(msje: String; ctx: TContext);
TxtErrornull72 function TxtError: string;
TxtErrorRCnull73 function TxtErrorRC: string;
74 procedure Show;
ArcErrornull75 function ArcError: string;
nLinErrornull76 function nLinError: longint;
nColErrornull77 Function nColError: longint;
HayErrornull78 function HayError: boolean;
79 end;
80
81 { TContext }
82 {Estructura que define a un objeto contexto. Un contexto es un objeto que sirve como
83 entrada de datos, en donde se puede cargar un texto, y luego leerlo token por token
84 de forma simple.}
85 TContext = class
86 private
87 fLexerState: TFaLexerState; //almacenamiento temporal
getRownull88 function getRow: integer;
getColnull89 function getCol: integer;
90 public
91 typ : tTypCon; //Tipo de contexto
92 arc : String; //Nombre de archivo. En caso de que el contexto corresponda a uno.
93 nlin : LongInt; //Número de líneas del Contexto
94 intLines : TStringList; {Líneas de texto. Se usa como almacenamiento interno, cuando
95 no se especifica algún TStringList externo. Se crea siempre}
96 curLines : TStrings; //Referencia al StringList actual, el que se explora.
97 lex : TSynFacilSyn; //Analizador léxico
98 retPos : TPosCont; //Posición de retorno, al contexto padre.
99 data : TObject; //Campo para información adiciconal que se desee alamcenar.
100 autoClose: boolean; {Indica que este contexto se debe cerrar automáticamente al
101 llegar al final.}
102 idCtx : integer; //Índice de unicidad del contexto.
103 //Campos para manejo de mensajes de error
104 FixErrPos: boolean; {Indica que los mensajes de error, deben apuntar a una
105 posición fija, y no a la posición en donde se detecta el error.}
106 ErrPosition: TSrcPos; //Posición a usar para el error, cuando se activa FixErrPos.
107 PreErrorMsg: string; {Mensaje previo al mensaje de error, cuando el errror se
108 genere en este contexto.}
109 //Posición del cursor actual
110 property row: integer read getRow;
111 property col: integer read getCol;
Tokennull112 function Token: string; inline; //Token actual
TokenTypenull113 function TokenType: integer; inline; //Tipo de token actual
TokenAttribnull114 function TokenAttrib: TSynHighlighterAttributes; inline; //Atributo del token actual
Blocknull115 function Block: TFaSynBlock;
NestedBlocksnull116 function NestedBlocks: integer;
NextBlocknull117 function NextBlock: boolean;
118 //Métodos de lectura
IniContnull119 Function IniCont:Boolean;
Eofnull120 Function Eof:Boolean;
121 procedure SkipWhites;
122 procedure SkipWhitesNoEOL;
123
Nextnull124 function Next: boolean; //Pasa al siguiente token
CurLinenull125 function CurLine: string; //Retorna la línea actual
ReadSourcenull126 function ReadSource: string; //Lee el contenido del contexto en un string
127 //Control de la posición actual
128 procedure SetStartPos; //Posiciona al inicio del contexto
129 procedure SaveLexerState; //Guarda el estado actual del lexer
130 procedure RestoreLexerState; //Restaura el estado actual del lexer
131 public //Métodos de inicialización
132 procedure DefSyn(lex0: TSynFacilSyn); //Fija la sintaxis del lexer
133 procedure SetSource(txt : string); //Fija el contenido del contexto con cadena
134 procedure SetSource(lins: Tstrings; MakeCopy: boolean = false); //Fija contenido a partir de una lista
135 procedure SetSourceF(file0: string); //Fija el contenido del contexto con archivo
136 constructor Create;
137 destructor Destroy; override;
138 end;
139
140 //Define una lista de Contextos
141 TContextList = specialize TFPGObjectList<TContext>;
142
143
144 { TContexts }
145 //Extructura para manejar diversas fuentes de datos de contexto
146 TContexts = class
147 private
148 lex : TSynFacilSyn; //resaltador - lexer
149 cEnt : TContext; //referencia al contexto de entrada actual
150 ctxList: TContextList; //Lista de contextos de entrada
151 idCount: integer; //Contador para obtener el índice de un contexto
GetPosActnull152 function GetPosAct: TPosCont;
153 procedure SetPosAct(pc: TPosCont);
154 public
155 MsjError : string;
156 tok : string; //token actual
157 tokType : integer; //tipo de token actual
158 OnNewLine: procedure(lin: string) of object;
tokLnull159 function tokL: string; //token actual en minúscula
tokAttribnull160 function tokAttrib: TSynHighlighterAttributes; inline;
161 property curCon: TContext read cEnt;
162 property PosAct: TPosCont read GetPosAct write SetPosAct;
ReadSrcPosnull163 function ReadSrcPos: TSrcPos;
AddContextnull164 function AddContext: TContext;
165 procedure NewContextFromFile(arc0: String);
166 procedure NewContextFromFile(arc0: String; lins: Tstrings);
167 procedure NewContextFromTxt(txt: string; arc0: String);
168 procedure RemoveContext;
169 procedure ClearAll; //elimian todos los contextos
Eofnull170 function Eof: Boolean;
171 procedure SkipWhites;
172 procedure SkipWhitesNoEOL;
173 procedure Next; //Pasa al siguiente token
174 public //Opciones de depuración
175 procedure ShowContexts;
176 procedure ShowCurContInformat;
177 public //Inicialización
178 constructor Create(Lex0: TSynFacilSyn);
179 destructor Destroy; override;
180 end;
181
182 implementation
183
184 { TSrcPos }
RowColStringnull185 function TSrcPos.RowColString: string;
186 begin
187 Result := '[' + IntToStr(Row) + ',' + IntToStr(Col)+']';
188 end;
TSrcPos.EqualTonull189 function TSrcPos.EqualTo(const target: TSrcPos): boolean;
190 begin
191 Result := (UpCase(fil) = UpCase(target.fil)) and
192 (row = target.row) and
193 (col = target.col);
194 end;
195
196 { TContext }
197 constructor TContext.Create;
198 begin
199 inherited; //solo se pone por seguridad, ya que no es necesario.
200 intLines := TStringList.Create; //crea lista de cadenas para almacenar el texto
201 nlin := 0;
202 SetSource(''); //para iniciar con algo en donde leer
203 end;
204 destructor TContext.Destroy;
205 begin
206 // lex.Free; //libera lexer
207 intLines.Free; //libera lista
208 inherited Destroy;
209 end;
TContext.IniContnull210 function TContext.IniCont: Boolean;
211 //Devuelve verdadero si se está al inicio del Contexto (fila 1, columna 1)
212 var
213 p: TPoint;
214 begin
215 p :=lex.GetXY;
216 Result := (p.x = 1) and (p.y = 1);
217 end;
TContext.Eofnull218 function TContext.Eof: Boolean;
219 //Devuelve verdadero si se ha llegado al final del Contexto.
220 begin
221 //Protección a Contexto vacío
222 If nlin = 0 Then begin
223 Result := True;
224 Exit;
225 End;
226 //Verifica
227 Result := (lex.GetY >= nlin) and lex.GetEol;
228 end;
229 procedure TContext.SkipWhitesNoEOL;
230 //Coge los blancos iniciales del contexto de entrada, sin considerar saltos de línea.
231 //Si no encuentra algun blanco al inicio, devuelve falso
232 begin
233 while not Eof and ((lex.GetTokenAttribute = lex.tkSpace) or
234 //los saltos son delimitadores (lex.GetTokenAttribute = lex.tkEol) or
235 (lex.GetTokenAttribute = lex.tkComment)
236 ) do
237 Next;
238 //actualiza estado
239 // tok := lex.GetToken; //lee el token
240 // tokType := lex.GetTokenAttribute; //lee atributo
241 end;
242 procedure TContext.SkipWhites;
243 //Coge los blancos iniciales, saltos de línea y comentarios del contexto de entrada.
244 //Si no encuentra algun blanco al inicio, devuelve falso
245 begin
246 // tok := lex.GetToken; //lee el token
247 while not Eof and ((lex.GetTokenAttribute = lex.tkSpace) or
248 (lex.GetTokenAttribute = lex.tkEol) or
249 (lex.GetTokenAttribute = lex.tkComment)
250 ) do
251 begin
252 Next;
253 //tok := lex.GetToken; //lee el token
254 end;
255 //actualiza estado
256 // tok := lex.GetToken; //lee el token
257 // tokType := lex.GetTokenAttribute; //lee atributo
258 end;
TContext.getRownull259 function TContext.getRow: integer;
260 begin
261 Result:=lex.GetY; //deberías ser equivalente a leer "fFil"
262 end;
TContext.getColnull263 function TContext.getCol: integer;
264 begin
265 Result:=lex.GetX;
266 end;
TContext.Tokennull267 function TContext.Token: string;
268 {Devuelve el token actual}
269 begin
270 Result := lex.GetToken;
271 end;
TokenTypenull272 function TContext.TokenType: integer;
273 {Devuelve el tipo de token actual}
274 begin
275 Result := lex.GetTokenKind;
276 end;
TContext.TokenAttribnull277 function TContext.TokenAttrib: TSynHighlighterAttributes;
278 begin
279 Result := lex.GetTokenAttribute;
280 end;
Blocknull281 function TContext.Block: TFaSynBlock;
282 begin
283 Result := lex.TopCodeFoldBlock;
284 end;
NestedBlocksnull285 function TContext.NestedBlocks: integer;
286 begin
287 Result := lex.NestedBlocks;
288 end;
TContext.NextBlocknull289 function TContext.NextBlock: boolean;
290 {Escanea hasta detectar un cambio de bloque o hasta que se llegue al fin del
291 contexto. Si encuentra fin de archivo, devuelve FALSE}
292 var
293 nblk: Integer;
294 begin
295 nblk := lex.NestedBlocks;
296 while not Eof and (lex.NestedBlocks=nblk) do begin
297 Next; //struct identifier
298 end;
299 Result := not Eof;
300 end;
Nextnull301 function TContext.Next: boolean;
302 //Pasa al siguiente token. Si hay cambio de líne edvuelve TRUE
303 var fFil: integer;
304 begin
305 if nlin = 0 then exit; //protección
306 if lex.GetEol then begin //llegó al fin de línea
307 fFil := lex.GetY; //Pasa a siguiente fila.
308 if fFil <= nlin then begin //se puede leer
309 lex.SetLine(curLines[fFil],fFil); //prepara exploración
310 //actualiza estado
311 // tok := lex.GetToken; //lee el token
312 // tokType := lex.GetTokenAttribute; //lee atributo
313 end;
314 exit(true); //hubo cambio de línea
315 end else begin //está en medio de la línea
316 lex.Next; //pasa al siguiente token
317 //actualiza estado
318 // tok := lex.GetToken; //lee el token
319 // tokType := lex.GetTokenAttribute; //lee atributo
320 exit(false);
321 end;
322 end;
323
TContext.CurLinenull324 function TContext.CurLine: string;
325 {Devuelve la línea actual en que se encuentra el lexer}
326 var
327 fFil: Integer;
328 begin
329 fFil := lex.GetY;
330 if fFil <= nlin then //se puede leer
331 Result := curLines[fFil-1]
332 else
333 Result := '';
334 end;
335 procedure TContext.SetStartPos;
336 //Mueve la posición al inicio del contexto.
337 begin
338 if curLines.Count = 0 then begin
339 //No hay líneas
340 lex.ResetRange; //fRange_= nil y también inicia información de bloques
341 end else begin //hay al menos una línea
342 if lex = nil then begin //No hay lexer. Es posible
343 // tok := '';
344 // tokType := nil;
345 end else begin
346 lex.ResetRange; //fRange_= nil y también inicia información de bloques
347 lex.SetLine(curLines[0],0); //empieza con la primera línea
348 //actualiza estado
349 // tok := lex.GetToken; //lee el token
350 // tokType := lex.GetTokenAttribute; //lee atributo
351 end;
352 end;
353 end;
354 procedure TContext.SaveLexerState;
355 //Guarda el estado actual del lexer en la variable interna "fLexerState".
356 //Este estado incluye las coordenadas actuales de lectura en el Lexer.
357 begin
358 fLexerState := lex.State;
359 end;
360 procedure TContext.RestoreLexerState;
361 //Copia el estado del lexer grabado en "fLexerState". Se debe ejecutar siempre
362 //después de SaveLexerState().
363 begin
364 lex.State := fLexerState;
365 end;
TContext.ReadSourcenull366 function TContext.ReadSource: string;
367 //Devuelve el contenido del contexto en una cadena.
368 begin
369 Result := curLines.text;
370 end;
371 //Métodos de inicialización
372 procedure TContext.DefSyn(lex0: TSynFacilSyn);
373 //Define el lexer a usar en el contexto
374 begin
375 lex := lex0;
376 end;
377 procedure TContext.SetSource(txt: string);
378 //Fija el contenido del contexto con una cadena. Puede ser de varias líneas.
379 begin
380 typ := TC_TXT; //indica que contenido es Texto
381 //guarda en lista interna.
382 if txt='' then begin
383 //cadena vacía, crea una línea vacía
384 intLines.Clear;
385 intLines.Add('');
386 end else begin
387 intLines.Text := txt;
388 end;
389 curLines := intLines; //apunta a almacenamiento interno
390 nlin := curLines.Count; //actualiza número de líneas
391 SetStartPos; //actualiza posición de cursor
392 arc := ''; //No se incluye información de archivo
393 end;
394 procedure TContext.SetSource(lins: Tstrings; MakeCopy: boolean = false);
395 //Fija el contenido del contexto con una lista TStringList. Usa la referencia, no copia.
396 begin
397 typ := TC_TXT; //indica que contenido es Texto
398 if MakeCopy then begin //crea copia
399 intLines.Clear;
400 intLines.AddStrings(lins); //carga líneas, de la lista
401 curLines := intLines; //apunta a almacenamiento interno
402 end else begin
403 curLines := lins; //apunta a la fuente externa. No la copia.
404 end;
405 nlin := curLines.Count; //actualiza número de líneas
406 SetStartPos; //actualiza posición de cursor
407 arc := ''; //No se incluye información de archivo
408 end;
409 procedure TContext.SetSourceF(file0: string);
410 //Fija el contenido del contexto con un archivo
411 begin
412 typ := TC_ARC; //indica que contenido es Texto
413 intLines.LoadFromFile(file0);
414 curLines := intLines; //apunta a almacenamiento interno
415 nlin := curLines.Count; //actualiza número de líneas
416 SetStartPos; //actualiza posición de cursor
417 arc := file0; //Toma nombe de archivo
418 end;
419
420 { TContexts }
TContexts.GetPosActnull421 function TContexts.GetPosAct: TPosCont;
422 //Devuelve Contexto actual y su posición
423 begin
424 Result.fCon := cEnt;
425 if cEnt = nil then begin
426 //Aún no hay Contexto definido
427 end else begin
428 Result.fPos := cEnt.lex.State;
429 // Result.fil := cEnt.row;
430 // Result.col := cEnt.col;
431 // Result.arc := cEnt.arc;
432 // Result.nlin := cEnt.nlin;
433 end;
434 end;
435 procedure TContexts.SetPosAct(pc: TPosCont);
436 //Fija Contexto actual y su posición
437 begin
438 cEnt := pc.fCon;
439 if cEnt = nil then begin
440 //No tiene un Contexto actual
441 end else begin
442 cEnt.lex.State := pc.fPos;
443 // cEnt.row := pc.fil;
444 // cEnt.col := pc.col;
445 // cEnt.arc := pc.arc;
446 // cEnt.nlin := pc.nlin;
447 end;
448 //actualiza token actual
449 tok := lex.GetToken; //lee el token
450 tokType := lex.GetTokenKind; //lee atributo
451 end;
AddContextnull452 function TContexts.AddContext: TContext;
453 {Agrega un contexto a "ctxList" y devuelve la referencia.
454 Punto único para agregar un conetxto}
455 begin
456 Result := TContext.Create; //Crea Contexto
457 Result.DefSyn(Lex); //Asigna el lexer actual
458 Result.retPos := PosAct; //Guarda posicíon de retorno
459 Result.idCtx := idCount; //Pone índice único
460 ctxList.Add(Result); //Registra Contexto
461 inc(idCount);
462 end;
463 procedure TContexts.NewContextFromTxt(txt: string; arc0: String);
464 //Crea un Contexto a partir de una cadena.
465 //Fija el Contexto Actual "cEnt" como el Contexto creado.
466 begin
467 cEnt := AddContext;
468 {$ifdef debug_mode}
469 debugln(' +Nex context from Txt:'+arc0);
470 {$endif}
471 cEnt.SetSource(txt); //Inicia con texto
472 cEnt.arc := arc0; {Se guarda el nombre del archivo actual, solo para poder procesar
473 las funciones $NOM_ACTUAL y $DIR_ACTUAL}
474 //Actualiza token actual
475 tok := lex.GetToken; //lee el token
476 tokType := lex.GetTokenKind; //lee atributo
477 end;
478 procedure TContexts.NewContextFromFile(arc0: String);
479 //Crea un Contexto a partir de un archivo.
480 //Fija el Contexto Actual "cEnt" como el Contexto creado.
481 begin
482 If not FileExists(arc0) Then begin //ve si existe
483 MsjError := 'File no found: ' + arc0;
484 Exit;
485 end;
486 cEnt := AddContext;
487 {$ifdef debug_mode}
488 debugln(' +Nex context from File:'+arc0);
489 {$endif}
490 cEnt.SetSourceF(arc0); //Inicia con archivo
491 //Actualiza token actual
492 tok := lex.GetToken; //lee el token
493 tokType := lex.GetTokenKind; //lee atributo
494 end;
495 procedure TContexts.NewContextFromFile(arc0: String; lins: Tstrings);
496 //Crea un Contexto a partir de un Tstring, como si fuera un archivo.
497 //Fija el Contexto Actual "cEnt" como el Contexto creado.
498 begin
499 cEnt := AddContext;
500 {$ifdef debug_mode}
501 debugln(' +Nex context from File:'+arc0);
502 {$endif}
503 cEnt.SetSource(lins); //Inicia con archivo contenido en TStrings
504 cEnt.arc := arc0; //Guarda nombre de archivo, solo como referencia.
505 //actualiza token actual
506 tok := lex.GetToken; //lee el token
507 tokType := lex.GetTokenKind; //lee atributo
508 end;
509 procedure TContexts.RemoveContext;
510 //Elimina el contexto de entrada actual. Deja apuntando al anterior en la misma posición.
511 var
512 retPos: TPosCont;
513 begin
514 if ctxList.Count = 0 then begin
515 //No hay contextos abiertos
516 cEnt := nil; //por si acaso
517 exit; //no se puede quitar más
518 end;
519 {$ifdef debug_mode}
520 debugln(' -Context deleted:'+ cEnt.arc);
521 {$endif}
522 //Hay al menos un contexto abierto
523 retPos := cEnt.retPos; //guarda dirección de retorno
524 //ctxList.Delete(ctxList.Count-1); //elimina contexto superior
525 ctxList.Remove(cEnt);
526 if ctxList.Count = 0 then begin
527 //No quedan contextos abiertos
528 cEnt := nil;
529 end else begin
530 //Queda al menos un contexto anterior
531 //Recupera posición anterior
532 PosAct := retPos;
533 end;
534 end;
535 procedure TContexts.ClearAll; //Limpia todos los contextos
536 begin
537 ctxList.Clear; //Elimina todos los Contextos de entrada
538 cEnt := nil; //Por si acaso
539 idCount := 0; //Inicia contador
540 end;
TContexts.Eofnull541 function TContexts.Eof: Boolean;
542 begin
543 Result := cEnt.Eof;
544 end;
545 procedure TContexts.SkipWhites;
546 {Salta los blancos incluidos los saltos de línea}
547 begin
548 while cEnt.Eof or //Considera también, para poder auto-cerrar contextos
549 (lex.GetTokenAttribute = lex.tkSpace) or
550 (lex.GetTokenAttribute = lex.tkEol) or
551 (lex.GetTokenAttribute = lex.tkComment) do
552 begin
553 if cEnt.Eof then begin
554 if cEnt.autoClose then begin
555 RemoveContext; //cierra automáticamente
556 end else begin
557 break; //Sale del WHILE
558 end;
559 end;
560 if cEnt.Next then begin //hubo cambio de línea
561 if OnNewLine<>nil then OnNewLine(cEnt.CurLine);
562 end;
563 end;
564 //Actualiza token actual
565 tok := lex.GetToken; //lee el token
566 tokType := lex.GetTokenKind; //lee atributo
567 end;
568 procedure TContexts.SkipWhitesNoEOL;
569 {Salta los blancos sin incluir los saltos de línea}
570 begin
571 while not cEnt.Eof and ((lex.GetTokenAttribute = lex.tkSpace) or
572 (lex.GetTokenAttribute = lex.tkComment) ) do
573 begin
574 if cEnt.Next then begin //hubo cambio de línea
575 if OnNewLine<>nil then OnNewLine(cEnt.CurLine);
576 end;
577 end;
578 //actualiza token actual
579 tok := lex.GetToken; //lee el token
580 tokType := lex.GetTokenKind; //lee atributo
581 end;
582 procedure TContexts.Next;
583 begin
584 if cEnt.Next then begin //hubo cambio de línea
585 if OnNewLine<>nil then OnNewLine(cEnt.CurLine);
586 end;
587 if cEnt.Eof and cEnt.autoClose then begin
588 //Se debe cerrar automáticamente
589 RemoveContext;
590 end;
591 //actualiza token actual
592 tok := lex.GetToken; //lee el token
593 tokType := lex.GetTokenKind; //lee atributo
594 end;
tokLnull595 function TContexts.tokL: string; inline;
596 //Devuelve el token actual, ignorando la caja.
597 begin
598 Result:=lowercase(tok);
599 end;
TContexts.tokAttribnull600 function TContexts.tokAttrib: TSynHighlighterAttributes;
601 begin
602 Result := lex.GetTokenAttribute;
603 end;
ReadSrcPosnull604 function TContexts.ReadSrcPos: TSrcPos;
605 {Devuelve un objeto TSrcPos, en la posición actual.}
606 begin
607 Result.fil := curCon.arc;
608 Result.Row := curCon.row;
609 Result.Col := curCon.col;
610 end;
611 procedure TContexts.ShowContexts;
612 {Función para depuración. Muestra el contenido de los contextos existentes.}
613 var ctx: TContext;
614 begin
615 debugln('=== Openend contexts ===');
616 for ctx in ctxList do begin
617 debugln(' ' + ctx.arc);
618 end;
619 end;
620 procedure TContexts.ShowCurContInformat;
621 var
622 typStr: string;
623 begin
624 case curCon.typ of
625 TC_ARC: typStr := 'TC_ARC';
626 TC_TXT: typStr := 'TC_TXT';
627 end;
628 debugln('===Current Context ===');
629 debugln(' arc=' + curCon.arc);
630 debugln(' typ=%s pos=[%d,%d]', [typStr, curCon.row, curCon.col]);
631 // debugln(' curlines=' + curCon.curLines.Text);
632 end;
633 //Inicialización
634 constructor TContexts.Create(Lex0: TSynFacilSyn);
635 begin
636 Lex := Lex0; //guarda referencia
637 ctxList := TContextList.Create(true); //crea contenedor de Contextos, con control de objetos.
638 cEnt := nil;
639 end;
640 destructor TContexts.Destroy;
641 begin
642 ctxList.Free;
643 inherited Destroy;
644 end;
645
646 { TPError }
647 procedure TPError.IniError;
648 begin
649 numER := 0;
650 cadER := '';
651 arcER := '';
652 fil := 0;
653 end;
654 procedure TPError.Clear;
655 //Limpia rápidamente el error actual
656 begin
657 numEr := 0;
658 end;
659 procedure TPError.GenError(msje: String; archivo: String; nlin: LongInt);
660 //Genera un error
661 begin
662 numER := 1;
663 cadER := msje;
664 arcER := archivo;
665 fil := nlin;
666 end;
667 procedure TPError.Generror(msje: String; ctx: TContext);
668 //Genera un error en la posición actual del contexto indicado.
669 begin
670 numER := 1;
671 cadER := msje;
672 arcER := ctx.arc; //toma nombre de archivo del contexto
673 fil := ctx.row;
674 col := ctx.col;
675 end;
TxtErrornull676 function TPError.TxtError: string;
677 //Devuelve el mensaje de error
678 begin
679 Result := cadER;
680 end;
TPError.TxtErrorRCnull681 function TPError.TxtErrorRC: string;
682 //Devuelve el mensaje de error con información de fila y columna
683 begin
684 // If arcER <> '' Then begin
685 //Hay nombre de archivo de error
686 If fil <> -1 Then //Hay número de línea
687 //Se usa este formato porque incluye información sobre fila-columna.
688 Result := '['+ IntToStr(fil) + ',' + IntToStr(col) + '] ' + cadER
689 Else //No hay número de línea, sólo archivo
690 Result := cadER;
691 // end else
692 // Result :=cadER;
693 end;
694 procedure TPError.Show;
695 //Muestra un mensaje de error
696 begin
697 Application.MessageBox(PChar(TxtError), PChar(NombPrograma), MB_ICONEXCLAMATION);
698 end;
TPError.ArcErrornull699 function TPError.ArcError: string;
700 //Devuelve el nombre del archivo de error
701 begin
702 ArcError := arcER;
703 end;
nLinErrornull704 function TPError.nLinError: longint;
705 //Devuelve el número de línea del error
706 begin
707 nLinError := fil;
708 end;
nColErrornull709 function TPError.nColError: longint;
710 //Devuelve el número de línea del error
711 begin
712 nColError := col;
713 end;
HayErrornull714 function TPError.HayError: boolean;
715 begin
716 Result := numER <> 0;
717 end;
718
719 end.
720
721