source: branches/Z80/Compiler.dpr

Last change on this file was 2, checked in by george, 15 years ago
  • Přidáno: Třída pro obsluhu čísel s dynamickou velikostí.
  • Přidáno: Struktury pro vytváření specifikace assembleru a strojových kódů.
File size: 53.8 KB
Line 
1PROGRAM Compiler;
2
3{$APPTYPE CONSOLE}
4
5
6{R-}
7{ $M 16384,0,655360 }
8
9CONST
10 maxSymLen = 16;
11 maxOpcdLen = 4;
12
13 alphaNumeric = '1234567890$ABCDEFGHIJKLMNOPQRSTUVWXYZ_';
14 numeric = '1234567890';
15 hex = '0123456789ABCDEF';
16 white = #9' '; { A tab plus a space }
17
18 o_Illegal = 0; { Opcode not found in FindOpcode }
19 o_None = 1; { No operands }
20 o_LD = 2; { Generic LD opcode }
21 o_EX = 3; { Generic EX opcode }
22 o_ADD = 4; { Generic ADD opcode }
23 o_ADC_SBC = 5; { Generic ADC and SBC opcodes }
24 o_INC_DEC = 6; { Generic INC and DEC opcodes }
25 o_JP_CALL = 7; { Generic JP and CALL opcodes }
26 o_JR = 8; { Generic JR opcode }
27 o_RET = 9; { Generic RET opcode }
28 o_IN = 10; { Generic IN opcode }
29 o_OUT = 11; { Generic OUT opcode }
30
31 o_PushPop = 12; { PUSH and POP instructions }
32 o_Arith = 13; { Arithmetic instructions }
33 o_Rotate = 14; { Z-80 rotate instructions }
34 o_Bit = 15; { BIT, RES, and SET instructions }
35 o_IM = 16; { IM instruction }
36 o_DJNZ = 17; { DJNZ instruction }
37 o_RST = 18; { RST instruction }
38
39 o_DB = 19; { DB pseudo-op }
40 o_DW = 20; { DW pseudo-op }
41 o_DS = 21; { DS pseudo-op }
42 o_EQU = -22; { EQU and SET pseudo-ops }
43 o_ORG = -23; { ORG pseudo-op }
44 o_END = 24; { END pseudo-op }
45 o_LIST = -25; { LIST pseudo-op }
46 o_OPT = -26; { OPT pseudo-op }
47
48 regs = ' B C D E H L A I R BC DE HL SP IX IY AF ( ';
49 regVals = ' 0 1 2 3 4 5 7 8 9 10 11 12 13 14 15 16 17 ';
50
51 reg_None = -1;
52 reg_B = 0;
53 reg_C = 1;
54 reg_D = 2;
55 reg_E = 3;
56 reg_H = 4;
57 reg_L = 5;
58 reg_M = 6;
59 reg_A = 7;
60{ reg_Byte = [reg_B..reg_A]; }
61 reg_I = 8;
62 reg_R = 9;
63 reg_BC = 10;
64 reg_DE = 11;
65 reg_HL = 12;
66 reg_SP = 13;
67{ reg_Word = [reg_BC..reg_SP]; }
68 reg_IX = 14;
69 reg_IY = 15;
70 reg_AF = 16;
71 reg_Paren = 17;
72
73 conds = ' NZ Z NC C PO PE P M ';
74 condVals = ' 0 1 2 3 4 5 6 7 ';
75
76TYPE
77 SymStr = String[maxSymLen];
78
79 SymPtr = ^SymRec;
80 SymRec = RECORD
81 name: SymStr; { Symbol name }
82 value: Integer; { Symbol value }
83 next: SymPtr; { Pointer to next symtab entry }
84 defined: Boolean; { TRUE if defined }
85 multiDef: Boolean; { TRUE if multiply defined }
86 isSet: Boolean; { TRUE if defined with SET pseudo }
87 equ: Boolean; { TRUE if defined with EQU pseudo }
88 END;
89
90 OpcdStr = String[maxOpcdLen];
91
92 OpcdPtr = ^OpcdRec;
93 OpcdRec = RECORD
94 name: OpcdStr; { Opcode name }
95 typ: Integer; { Opcode type }
96 parm: Integer; { Opcode parameter }
97 next: OpcdPtr; { Pointer to next opcode entry }
98 END;
99 { TP 3.0 does not know any length-less string variable }
100 string_tp = String[128];
101 { TP 3.0 does not know any machine dependant variable like 'word' }
102 word = integer;
103
104VAR
105 symTab: SymPtr; { Pointer to first entry in symtab }
106 opcdTab: OpcdPtr; { Opcode table }
107
108 locPtr: Integer; { Current program address }
109 newLoc: Integer; { New program address }
110 updLoc: Boolean; { TRUE if newLoc needs to be written to file }
111 pass: Integer; { Current assembler pass }
112 errFlag: Boolean; { TRUE if error occurred this line }
113 errCount: Integer; { Total number of errors }
114
115 line: string_tp; { Current line from input file }
116 listLine: string_tp; { Current listing line }
117 listFlag: Boolean; { FALSE to suppress listing source }
118 listThisLine: Boolean; { TRUE to force listing this line }
119 sourceEnd: Boolean; { TRUE when END pseudo encountered }
120
121 instr: ARRAY[1..5] OF Integer; { Current instruction word }
122 instrLen: Integer; { Current instruction length }
123
124 bytStr: string_tp; { Buffer for long DB statements }
125 showAddr: Boolean; { TRUE to show LocPtr on listing }
126 xferAddr: Integer; { Transfer address from END pseudo }
127 xferFound: Boolean; { TRUE if xfer addr defined w/ END }
128
129 { Command line parameters }
130 cl_SrcName: string_tp; { Source file name }
131 cl_ListName: string_tp; { Listing file name }
132 cl_ObjName: string_tp; { objectt file name }
133 cl_Err: Boolean; { TRUE for errors to screen }
134
135
136 source: Text;
137 objectt: Text;
138 listing: Text;
139
140
141FUNCTION Deblank(s: string_tp): string_tp;
142
143VAR
144 i: Integer;
145
146BEGIN
147 i := Length(s);
148 WHILE (i>0) AND (s[i] IN [#9,' ']) DO
149 i:=i-1;
150
151 s[0] := CHR(i);
152
153 i := 1;
154 WHILE (i<=Length(s)) AND (s[i] IN [#9,' ']) DO
155 i:=i+1;
156 Delete(s,1,i-1);
157
158 Deblank := s;
159END;
160
161
162FUNCTION UprCase(s: string_tp): string_tp;
163
164VAR
165 i: Integer;
166
167BEGIN
168 FOR i := 1 TO Length(s) DO
169 IF s[i] IN ['a'..'z'] THEN
170 s[i] := UpCase(s[i]);
171
172 UprCase := s;
173END;
174
175
176FUNCTION Hex2(i: Integer): string_tp;
177
178BEGIN
179 i := i AND 255;
180 Hex2 := Copy(hex,(i SHR 4)+1,1) + Copy(hex,(i AND 15)+1,1);
181END;
182
183
184FUNCTION Hex4(i: Integer): string_tp;
185
186BEGIN
187 Hex4 := Hex2(i SHR 8) + Hex2(i AND 255);
188END;
189
190
191PROCEDURE Error(message: string_tp);
192
193BEGIN
194 errFlag := TRUE;
195 errCount:=errCount+1;
196
197 IF pass<>1 THEN BEGIN
198 listThisLine := TRUE;
199 WriteLn(listing,'*** Error: ',Message,' ***');
200 IF cl_Err THEN WriteLn('*** Error: ',Message,' ***');
201 END;
202END;
203
204
205PROCEDURE IllegalOperand;
206
207BEGIN
208 Error('Illegal operand');
209 line := '';
210END;
211
212
213PROCEDURE AddOpcode(name: OpcdStr; typ: Integer; parm: Word);
214VAR
215 p: OpcdPtr;
216BEGIN
217 New(p);
218
219 p^.name := name;
220 p^.typ := typ;
221 p^.parm := parm;
222 p^.next := opcdTab;
223
224 opcdTab := p;
225END;
226
227
228PROCEDURE FindOpcode(name: OpcdStr; VAR typ,parm: Integer);
229VAR
230 p: OpcdPtr;
231 found: Boolean;
232
233BEGIN
234 found := FALSE;
235 p := opcdTab;
236
237 WHILE (p<>NIL) AND NOT found DO BEGIN
238 found := (p^.name = name);
239 IF NOT found THEN
240 p := p^.next;
241 END;
242
243 IF NOT found THEN BEGIN
244 typ := o_Illegal;
245 parm := 0;
246 END
247 ELSE BEGIN
248 typ := p^.typ;
249 parm := p^.parm;
250 END;
251END;
252
253
254PROCEDURE InitOpcodes;
255
256BEGIN
257 opcdTab := NIL;
258
259 AddOpcode('EXX', o_None, $D9);
260 AddOpcode('LDI', o_None, $EDA0);
261 AddOpcode('LDIR', o_None, $EDB0);
262 AddOpcode('LDD', o_None, $EDA8);
263 AddOpcode('LDDR', o_None, $EDB8);
264 AddOpcode('CPI',o_None,$EDA1);
265 AddOpcode('CPIR',o_None,$EDB1);
266 AddOpcode('CPD' ,o_None,$EDA9);
267 AddOpcode('CPDR',o_None,$EDB9);
268 AddOpcode('DAA' ,o_None,$27);
269 AddOpcode('CPL' ,o_None,$2F);
270 AddOpcode('NEG' ,o_None,$ED44);
271 AddOpcode('CCF' ,o_None,$3F);
272 AddOpcode('SCF' ,o_None,$37);
273 AddOpcode('NOP' ,o_None,$00);
274 AddOpcode('HALT',o_None,$76);
275 AddOpcode('DI' ,o_None,$F3);
276 AddOpcode('EI' ,o_None,$FB);
277 AddOpcode('RLCA',o_None,$07);
278 AddOpcode('RLA' ,o_None,$17);
279 AddOpcode('RRCA',o_None,$0F);
280 AddOpcode('RRA' ,o_None,$1F);
281 AddOpcode('RLD' ,o_None,$ED6F);
282 AddOpcode('RRD' ,o_None,$ED67);
283 AddOpcode('RET' ,o_None,$C9);
284 AddOpcode('RETI',o_None,$ED4D);
285 AddOpcode('RETN',o_None,$ED45);
286 AddOpcode('INI' ,o_None,$EDA2);
287 AddOpcode('INIR',o_None,$EDB2);
288 AddOpcode('IND' ,o_None,$EDAA);
289 AddOpcode('INDR',o_None,$EDBA);
290 AddOpcode('OUTI',o_None,$EDA3);
291 AddOpcode('OTIR',o_None,$EDB3);
292 AddOpcode('OUTD',o_None,$EDAB);
293 AddOpcode('OTDR',o_None,$EDBB);
294
295 AddOpcode('LD' ,o_LD,0);
296 AddOpcode('EX' ,o_EX,0);
297 AddOpcode('ADD' ,o_ADD,0);
298 AddOpcode('ADC' ,o_ADC_SBC,0);
299 AddOpcode('SBC' ,o_ADC_SBC,1);
300 AddOpcode('INC' ,o_INC_DEC,0);
301 AddOpcode('DEC' ,o_INC_DEC,1);
302 AddOpcode('JP' ,o_JP_CALL,$C3C2);
303 AddOpcode('CALL',o_JP_CALL,$CDC4);
304 AddOpcode('JR' ,o_JR,0);
305 AddOpcode('RET' ,o_RET,0);
306
307 AddOpcode('PUSH',o_PushPop,$C5);
308 AddOpcode('POP' ,o_PushPop,$C1);
309
310 AddOpcode('SUB' ,o_Arith,$D690);
311 AddOpcode('AND' ,o_Arith,$E6A0);
312 AddOpcode('XOR' ,o_Arith,$EEA8);
313 AddOpcode('OR' ,o_Arith,$F6B0);
314 AddOpcode('CP' ,o_Arith,$FEB8);
315
316 AddOpcode('RLC' ,o_Rotate,$00);
317 AddOpcode('RRC' ,o_Rotate,$08);
318 AddOpcode('RL' ,o_Rotate,$10);
319 AddOpcode('RR' ,o_Rotate,$18);
320 AddOpcode('SLA' ,o_Rotate,$20);
321 AddOpcode('SRA' ,o_Rotate,$28);
322 AddOpcode('SRL' ,o_Rotate,$38);
323
324 AddOpcode('BIT' ,o_Bit,$40);
325 AddOpcode('RES' ,o_Bit,$80);
326 AddOpcode('SET' ,o_Bit,$C0);
327
328 AddOpcode('IM' ,o_IM,0);
329
330 AddOpcode('DJNZ',o_DJNZ,0);
331
332 AddOpcode('IN' ,o_IN,0);
333
334 AddOpcode('OUT' ,o_OUT,0);
335
336 AddOpcode('RST' ,o_RST,0);
337
338 AddOpcode('DB' ,o_DB,0);
339 AddOpcode('DW' ,o_DW,0);
340 AddOpcode('DS' ,o_DS,0);
341
342 AddOpcode('=' ,o_EQU,0);
343 AddOpcode('EQU' ,o_EQU,0);
344 {AddOpcode('SET' ,o_EQU,1);}
345 AddOpcode('DEFL',o_EQU,1);
346
347 AddOpcode('ORG' ,o_ORG,0);
348 AddOpcode('END' ,o_END,0);
349 AddOpcode('LIST',o_LIST,0);
350 AddOpcode('OPT' ,o_OPT,0);
351END;
352
353
354FUNCTION FindSym(symName: SymStr): SymPtr;
355
356VAR
357 p: SymPtr;
358 found: Boolean;
359
360BEGIN
361 found := FALSE;
362 p := SymTab;
363 WHILE (p<>NIL) AND NOT Found DO BEGIN
364 found := (p^.name = symName);
365 IF NOT found THEN
366 p := p^.next;
367 END;
368
369 FindSym := p;
370END;
371
372
373FUNCTION AddSym(symName: SymStr): SymPtr;
374VAR
375 p: SymPtr;
376BEGIN
377 New(p);
378
379 WITH p^ DO BEGIN
380 name := SymName;
381 value := 0;
382 next := SymTab;
383 defined := FALSE;
384 multiDef := FALSE;
385 isSet := FALSE;
386 equ := FALSE;
387 END;
388
389 symTab := p;
390 AddSym := p;
391END;
392
393FUNCTION RefSym(symName: SymStr): Integer;
394VAR
395 p: SymPtr;
396BEGIN
397 p := FindSym(symName);
398 IF p=NIL THEN p := AddSym(symName);
399
400 IF NOT p^.defined THEN
401 Error('Symbol "' + symName + '" undefined');
402
403 RefSym := p^.value;
404END;
405
406
407PROCEDURE DefSym(symName: SymStr; val: Integer; setSym,equSym: Boolean);
408
409VAR
410 p: SymPtr;
411
412BEGIN
413 IF Length(symName)<>0 THEN BEGIN
414
415 p := FindSym(symName);
416 IF p=NIL THEN p := AddSym(symName);
417
418 IF (NOT p^.defined) OR (p^.isSet AND setSym) THEN BEGIN
419 p^.value := val;
420 p^.defined := TRUE;
421 p^.isSet := setSym;
422 p^.equ := equSym;
423 END
424 ELSE IF p^.value <> val THEN BEGIN
425 p^.multiDef := TRUE;
426 Error('Symbol "' + symName + '" multiply defined');
427 END;
428 END;
429END;
430
431
432FUNCTION GetWord: string_tp;
433
434VAR
435 word: string_tp;
436 done: Boolean;
437
438BEGIN
439 line := Deblank(line);
440 word := '';
441
442 IF Length(line)>0 THEN
443 IF (line[1]=#12) OR (line[1]=';') THEN
444 line := '';
445
446 IF Length(line)>0 THEN BEGIN
447 IF Pos(Upcase(line[1]),alphaNumeric)=0 THEN BEGIN
448 word := Copy(Line,1,1);
449 Delete(line,1,1);
450 END
451 ELSE BEGIN
452 done := FALSE;
453 WHILE (Length(line)>0) AND NOT done DO BEGIN
454 word := word + Upcase(line[1]);
455 Delete(line,1,1);
456 IF Length(line)>0 THEN
457 done := Pos(Upcase(line[1]),AlphaNumeric)=0;
458 END;
459 END;
460 END;
461
462 GetWord := word;
463END;
464
465
466PROCEDURE Expect(expected: string_tp);
467
468BEGIN
469 IF GetWord<>expected THEN
470 Error('"' + expected + '" expected');
471END;
472
473
474PROCEDURE Comma;
475
476BEGIN
477 Expect(',');
478END;
479
480
481PROCEDURE RParen;
482
483BEGIN
484 Expect(')');
485END;
486
487
488FUNCTION EvalOct(octStr: string_tp): Integer;
489
490VAR
491 octVal: Integer;
492 evalErr: Boolean;
493 i,n: Integer;
494
495BEGIN
496 evalErr := FALSE;
497 octVal := 0;
498
499 FOR i := 1 TO Length(octStr) DO BEGIN
500 n := Pos(octStr[i],'01234567');
501 IF n=0 THEN evalErr := TRUE
502 ELSE octVal := octVal*8 + n-1;
503 END;
504
505 IF evalErr THEN BEGIN
506 octVal := 0;
507 Error('Invalid octal number');
508 END;
509
510 EvalOct := octVal;
511END;
512
513
514FUNCTION EvalDec(decStr: string_tp): Integer;
515VAR
516 decVal: Integer;
517 evalErr: Boolean;
518 i, n: Integer;
519BEGIN
520 evalErr := FALSE;
521 decVal := 0;
522
523 FOR i := 1 TO Length(decStr) DO BEGIN
524 n := Pos(decStr[i], '0123456789');
525 IF n = 0 THEN evalErr := TRUE
526 ELSE decVal := decVal*10 + n - 1;
527 END;
528
529 IF evalErr THEN BEGIN
530 decVal := 0;
531 Error('Invalid decimal number');
532 END;
533
534 EvalDec := decVal;
535END;
536
537
538FUNCTION EvalHex(hexStr: string_tp): Integer;
539
540VAR
541 hexVal: Integer;
542 evalErr: Boolean;
543 i,n: Integer;
544
545BEGIN
546 evalErr := FALSE;
547 hexVal := 0;
548
549 FOR i := 1 TO Length(hexStr) DO BEGIN
550 n := Pos(Upcase(hexStr[i]),'0123456789ABCDEF');
551 IF n=0 THEN evalErr := TRUE
552 ELSE hexVal := hexVal*16 + n-1;
553 END;
554
555 IF evalErr THEN BEGIN
556 hexVal := 0;
557 Error('Invalid hexadecimal number');
558 END;
559
560 EvalHex := hexVal;
561END;
562
563FUNCTION Factor: Integer; FORWARD;
564
565FUNCTION Term: Integer;
566
567VAR
568 word: string_tp;
569 val: Integer;
570 oldLine: string_tp;
571
572BEGIN
573 val := Factor;
574
575{ oldLine := line;
576 word := GetWord;
577 WHILE ( word = '*' ) OR ( word = '/' ) OR ( word = '%' ) DO
578 BEGIN
579 CASE word[1] OF
580 '*': val := val * Factor;
581 '/': val := val DIV Factor;
582 '%': val := val MOD Factor;
583 END;
584 oldLine := line;
585 word := GetWord;
586 END;
587 line := oldLine;
588}
589 Term := val;
590END;
591
592FUNCTION Eval: Integer;
593
594VAR
595 word: string_tp;
596 val: Integer;
597 oldLine: string_tp;
598
599BEGIN
600 val := Term;
601
602 oldLine := line;
603 word := GetWord;
604 WHILE (word='+') OR (word='-') {OR (word='*') OR (word='/')} DO BEGIN
605 CASE word[1] OF
606 '+': val := val + Term;
607 '-': val := val - Term;
608 END;
609 oldLine := line;
610 word := GetWord;
611 END;
612 line := oldLine;
613
614 Eval := val;
615END;
616
617
618FUNCTION Factor;
619
620VAR
621 word: string_tp;
622 val: Integer;
623
624BEGIN
625 word := GetWord;
626 val := 0;
627 IF Length(word)=0 THEN Error('Missing operand')
628 ELSE IF (word='.') OR (word='*') THEN val := locPtr
629 ELSE IF word='$' THEN val := locPtr
630 ELSE IF word='-' THEN val := -Factor
631 ELSE IF word='+' THEN val := Factor
632 ELSE IF word='~' THEN val := -Factor-1
633 ELSE IF word='(' THEN BEGIN
634 val := Eval;
635 RParen;
636 END
637 ELSE IF word='''' THEN BEGIN
638 IF Length(line)=0 THEN
639 Error('Missing operand')
640 ELSE BEGIN
641 val := Ord(line[1]);
642 Delete(line,1,1);
643 Expect('''');
644 END;
645 END
646 ELSE IF Pos(word[1],numeric)>0 THEN BEGIN
647 CASE word[Length(word)] OF
648 'O': val := EvalOct(Copy(word,1,Length(word)-1));
649 'D': val := EvalDec(Copy(word,1,Length(word)-1));
650 'H': val := EvalHex(Copy(word,1,Length(word)-1));
651 ELSE val := EvalDec(word);
652 END;
653 END
654 ELSE val := RefSym(word);
655
656 Factor := val;
657END;
658
659
660FUNCTION EvalByte: Integer;
661
662VAR
663 val: Integer;
664
665BEGIN
666 val := Eval;
667
668 IF (val<-128) OR (val>255) THEN
669 Error('Byte out of range');
670
671 EvalByte := val AND 255;
672END;
673
674
675FUNCTION FindReg(regName,regList,valList: string_tp): Integer;
676
677VAR
678 p: Integer;
679 reg: Integer;
680 code: Integer;
681
682BEGIN
683 p := Pos(' ' + Deblank(regName) + ' ',regList);
684
685 IF p=0 THEN reg := -1
686 ELSE IF valList[p+2]=' ' THEN Val(Copy(valList,p+1,1),reg,code)
687 ELSE Val(Copy(valList,p+1,2),reg,code);
688
689 FindReg := reg;
690END;
691
692
693PROCEDURE CodeOut(byte: Integer);
694
695BEGIN
696 IF (pass=2) AND updLoc THEN BEGIN
697 WriteLn(objectt,':',Hex4(newLoc));
698 updLoc := FALSE;
699 END;
700
701 IF pass=2 THEN
702 WriteLn(objectt,Hex2(byte));
703END;
704
705
706PROCEDURE CodeOrg(addr: Integer);
707
708BEGIN
709 locPtr := addr;
710 newLoc := locPtr;
711 updLoc := TRUE;
712END;
713
714
715PROCEDURE CodeFlush;
716
717BEGIN
718 { objectt file format does not use buffering; no flush needed }
719END;
720
721
722PROCEDURE CodeEnd;
723
724BEGIN
725 CodeFlush;
726
727 IF (pass=2) AND xferFound THEN BEGIN
728 WriteLn(objectt,'$',Hex4(xferAddr));
729 END;
730END;
731
732
733PROCEDURE CodeXfer(addr: Integer);
734
735BEGIN
736 xferAddr := addr;
737 xferFound := TRUE;
738END;
739
740
741PROCEDURE Instr1(b: Byte);
742
743BEGIN
744 instr[1] := b;
745 instrLen := 1;
746END;
747
748
749PROCEDURE Instr2(b1,b2: Byte);
750
751BEGIN
752 instr[1] := b1;
753 instr[2] := b2;
754 instrLen := 2;
755END;
756
757
758PROCEDURE Instr3(b1,b2,b3: Byte);
759
760BEGIN
761 instr[1] := b1;
762 instr[2] := b2;
763 instr[3] := b3;
764 instrLen := 3;
765END;
766
767
768PROCEDURE Instr3W(b: Byte; w: Word);
769
770BEGIN
771 Instr3(b,w AND 255,w SHR 8);
772END;
773
774
775PROCEDURE Instr4(b1,b2,b3,b4: Byte);
776
777BEGIN
778 instr[1] := b1;
779 instr[2] := b2;
780 instr[3] := b3;
781 instr[4] := b4;
782 instrLen := 4;
783END;
784
785
786PROCEDURE Instr4W(b1,b2: Byte; w: Word);
787
788BEGIN
789 Instr4(b1,b2,w AND 255,w SHR 8);
790END;
791
792
793PROCEDURE DoOpcode(typ: Integer; parm: Word);
794
795VAR
796 val: Integer;
797 reg1: Integer;
798 reg2: Integer;
799 word: string_tp;
800 oldLine: string_tp;
801
802 PROCEDURE IXOffset;
803 BEGIN
804 word := GetWord;
805 IF word=')' THEN val := 0
806 ELSE IF (word='+') OR (word='-') THEN BEGIN
807 val := Eval;
808 IF word='-' THEN val := -val;
809 RParen;
810 END;
811 END;
812
813 PROCEDURE DoArith(imm,reg: Integer);
814 BEGIN
815 oldLine := line;
816 reg2 := FindReg(GetWord,regs,regVals);
817 CASE reg2 OF
818 reg_None: { ADD A,nn }
819 BEGIN
820 line := oldLine;
821 val := Eval;
822 Instr2(imm,val);
823 END;
824
825 reg_B,
826 reg_C,
827 reg_D,
828 reg_E,
829 reg_H,
830 reg_L,
831 reg_A: { ADD A,r }
832 Instr1(reg + reg2);
833
834 reg_Paren:
835 BEGIN
836 reg2 := FindReg(GetWord,regs,regVals);
837 CASE reg2 OF
838 reg_HL:
839 BEGIN
840 RParen;
841 Instr1(reg+reg_M);
842 END;
843
844 reg_IX,
845 reg_IY:
846 BEGIN
847 IXOffset;
848 IF reg2=reg_IX
849 THEN Instr3($DD,reg+reg_M,val)
850 ELSE Instr3($FD,reg+reg_M,val);
851 END;
852
853 ELSE IllegalOperand;
854 END;
855 END;
856
857 ELSE IllegalOperand;
858 END;
859 END;
860
861BEGIN
862 CASE typ OF
863 o_None:
864 IF parm>255 THEN Instr2(parm SHR 8,parm AND 255)
865 ELSE Instr1(parm);
866
867 o_LD:
868 BEGIN
869 word := GetWord;
870 reg1 := FindReg(word,regs,regVals);
871
872 CASE reg1 OF
873 reg_None: { LD nnnn,? }
874 IllegalOperand;
875
876 reg_B,
877 reg_C,
878 reg_D,
879 reg_E,
880 reg_H,
881 reg_L,
882 reg_A: { LD r,? }
883 BEGIN
884 Comma;
885 oldLine := line;
886 reg2 := FindReg(GetWord,regs,regVals);
887
888 CASE reg2 OF
889 reg_B,
890 reg_C,
891 reg_D,
892 reg_E,
893 reg_H,
894 reg_L,
895 reg_A: { LD r,r }
896 Instr1($40 + reg1*8 + reg2);
897
898 reg_I: { LD A,I }
899 Instr2($ED,$57);
900
901 reg_R: { LD A,R }
902 Instr2($ED,$5F);
903
904 reg_Paren: { LD r,(?) }
905 BEGIN
906 oldLine := line;
907 reg2 := FindReg(GetWord,regs,regVals);
908
909 CASE reg2 OF
910 reg_BC, { LD A,(BC) }
911 reg_DE: { LD A,(DE) }
912 IF reg1<>reg_A THEN IllegalOperand
913 ELSE BEGIN
914 RParen;
915 Instr1($0A + (reg2-reg_BC)*16);
916 END;
917
918 reg_HL: { LD r,(HL) }
919 BEGIN
920 RParen;
921 Instr1($40 + reg1*8 + reg_M);
922 END;
923
924 reg_IX, { LD r,(IX+d) }
925 reg_IY: { LD r,(IY+d) }
926 BEGIN
927 IXOffset;
928 IF reg2=reg_IX
929 THEN Instr3($DD,$46 + reg1*8,val)
930 ELSE Instr3($FD,$46 + reg1*8,val);
931 END;
932
933 reg_None: { LD A,(nnnn) }
934 IF reg1<>reg_A THEN IllegalOperand
935 ELSE BEGIN
936 line := oldLine;
937 val := Eval;
938 RParen;
939 Instr3W($3A,val);
940 END;
941
942 ELSE IllegalOperand;
943 END;
944 END;
945
946 reg_None: { LD r,nn }
947 BEGIN
948 line := oldLine;
949 Instr2($06 + reg1*8,Eval);
950 END;
951
952 ELSE IllegalOperand;
953 END; { CASE reg2 }
954 END; { reg_Byte }
955
956 reg_I:
957 BEGIN { LD I,A }
958 Comma;
959 Expect('A');
960 Instr2($ED,$47);
961 END;
962
963 reg_R:
964 BEGIN { LD R,A }
965 Comma;
966 Expect('A');
967 Instr2($ED,$4F);
968 END;
969
970 reg_BC,
971 reg_DE,
972 reg_HL,
973 reg_SP:
974 BEGIN { LD rr,? }
975 Comma;
976 oldLine := line;
977 reg2 := FindReg(GetWord,regs,regVals);
978
979 IF (reg1=reg_SP) AND { LD SP,HL }
980 (reg2 IN [reg_HL,reg_IX,reg_IY]) THEN BEGIN
981 CASE reg2 OF
982 reg_HL: Instr1($F9);
983 reg_IX: Instr2($DD,$F9);
984 reg_IY: Instr2($FD,$F9);
985 END;
986 END
987
988 ELSE IF (reg1=reg_HL) AND (reg2=reg_Paren) THEN BEGIN
989 val := Eval; { LD HL,(nnnn) }
990 RParen;
991 Instr3W($2A,val);
992 END
993
994 ELSE IF reg2=reg_Paren THEN BEGIN
995 val := Eval; { LD BC,(nnnn) }
996 RParen;
997 Instr4W($ED,$4B + (reg1-reg_BC)*16,val);
998 END
999
1000 ELSE IF reg2=reg_None THEN BEGIN { LD rr,nnnn }
1001 line := oldLine;
1002 val := Eval;
1003 Instr3W($01 + (reg1-reg_BC)*16,val);
1004 END
1005
1006 ELSE IllegalOperand;
1007 END;
1008
1009 reg_IX, { LD IX,? }
1010 reg_IY: { LD IY,? }
1011 BEGIN
1012 Comma;
1013 oldLine := line;
1014 reg2 := FindReg(GetWord,regs,regVals);
1015
1016 CASE reg2 OF
1017 reg_None: { LD IX,nnnn }
1018 BEGIN
1019 line := oldLine;
1020 val := Eval;
1021 IF reg1=reg_IX THEN Instr4W($DD,$21,val)
1022 ELSE Instr4W($FD,$21,val);
1023 END;
1024
1025 reg_Paren: { LD IX,(nnnn) }
1026 BEGIN
1027 val := Eval;
1028 RParen;
1029 IF reg1=reg_IX THEN Instr4W($DD,$2A,val)
1030 ELSE Instr4W($FD,$2A,val);
1031 END;
1032
1033 ELSE IllegalOperand;
1034 END;
1035 END;
1036
1037 reg_Paren: { LD (?),? }
1038 BEGIN
1039 oldLine := line;
1040 reg1 := FindReg(GetWord,regs,regVals);
1041
1042 CASE reg1 OF
1043 reg_None: { LD (nnnn),? }
1044 BEGIN
1045 line := oldLine;
1046 val := Eval;
1047 RParen;
1048 Comma;
1049 reg2 := FindReg(GetWord,regs,regVals);
1050
1051 CASE reg2 OF
1052 reg_A: Instr3W($32,val);
1053 reg_HL: Instr3W($22,val);
1054 reg_BC,
1055 reg_DE,
1056 reg_SP: Instr4W($ED,$43+(reg2-reg_BC)*16,val);
1057 reg_IX: Instr4W($DD,$22,val);
1058 reg_IY: Instr4W($FD,$22,val);
1059 ELSE IllegalOperand;
1060 END; { CASE reg2 }
1061 END;
1062
1063 reg_BC,
1064 reg_DE:
1065 BEGIN
1066 RParen;
1067 Comma;
1068 Expect('A');
1069 Instr1($02+(reg1-reg_BC)*16);
1070 END;
1071
1072 reg_HL: { LD (HL),? }
1073 BEGIN
1074 RParen;
1075 Comma;
1076 oldLine := line;
1077 reg2 := FindReg(GetWord,regs,regVals);
1078 IF reg2=reg_None THEN BEGIN
1079 line := oldLine;
1080 val := Eval;
1081 Instr2($36,val);
1082 END
1083 ELSE IF reg2 IN [ 0..7 ] THEN
1084 Instr1($70 + reg2)
1085 ELSE IllegalOperand;
1086 END;
1087
1088 reg_IX,
1089 reg_IY: { LD (IX),? }
1090 BEGIN
1091 IXOffset;
1092 Comma;
1093 oldLine := line;
1094 reg2 := FindReg(GetWord,regs,regVals);
1095 IF reg2=reg_None THEN BEGIN
1096 line := oldLine;
1097 reg2 := Eval;
1098 IF reg1=reg_IX
1099 THEN Instr4($DD,$36,val,reg2)
1100 ELSE Instr4($FD,$36,val,reg2);
1101 END
1102 ELSE IF reg2 IN [ 0..7 ] THEN
1103 IF reg1=reg_IX
1104 THEN Instr3($DD,$70 + reg2,val)
1105 ELSE Instr3($FD,$70 + reg2,val)
1106 ELSE IllegalOperand;
1107 END;
1108 END; { CASE reg1 }
1109 END; { reg_Paren }
1110
1111 ELSE IllegalOperand;
1112
1113 END; { CASE reg1 }
1114 END; { o_LD }
1115
1116 o_EX:
1117 BEGIN
1118 reg1 := FindReg(GetWord,regs,regVals);
1119 CASE reg1 OF
1120 reg_DE: { EX DE,HL }
1121 BEGIN
1122 Comma;
1123 Expect('HL');
1124 Instr1($EB);
1125 END;
1126
1127 reg_AF: { EX AF,AF' }
1128 BEGIN
1129 Comma;
1130 Expect('AF');
1131 Expect('''');
1132 Instr1($08);
1133 END;
1134
1135 reg_Paren: { EX (SP),? }
1136 BEGIN
1137 Expect('SP');
1138 RParen;
1139 Comma;
1140 reg2 := FindReg(GetWord,regs,regVals);
1141 CASE reg2 OF
1142 reg_HL: Instr1($E3);
1143 reg_IX: Instr2($DD,$E3);
1144 reg_IY: Instr2($FD,$E3);
1145 ELSE IllegalOperand;
1146 END;
1147 END;
1148
1149 ELSE IllegalOperand;
1150 END; { CASE reg1 }
1151 END; { o_EX }
1152
1153 o_ADD:
1154 BEGIN
1155 reg1 := FindReg(GetWord,regs,regVals);
1156 CASE reg1 OF
1157 reg_A:
1158 BEGIN
1159 Comma;
1160 DoArith($C6,$80);
1161 END;
1162
1163 reg_HL,
1164 reg_IX,
1165 reg_IY:
1166 BEGIN
1167 Comma;
1168 reg2 := FindReg(GetWord,regs,regVals);
1169 IF reg2=reg1 THEN reg2 := reg_HL;
1170 IF reg2 IN [ 10..13 ] THEN BEGIN
1171 CASE reg1 OF
1172 reg_HL: Instr1($09 + (reg2-reg_BC)*16);
1173 reg_IX: Instr2($DD,$09 + (reg2-reg_BC)*16);
1174 reg_IY: Instr2($FD,$09 + (reg2-reg_BC)*16);
1175 END;
1176 END
1177 ELSE IllegalOperand;
1178 END;
1179 ELSE IllegalOperand;
1180 END; { CASE reg1 }
1181 END; { o_ADD }
1182
1183 o_ADC_SBC:
1184 BEGIN
1185 reg1 := FindReg(GetWord,regs,regVals);
1186 CASE reg1 OF
1187 reg_A:
1188 BEGIN
1189 Comma;
1190 DoArith($CE+parm*16,$88+parm*16);
1191 END;
1192
1193 reg_HL:
1194 BEGIN
1195 Comma;
1196 reg2 := FindReg(GetWord,regs,regVals);
1197 IF reg2 IN [ 10..13 ]
1198 THEN Instr2($ED,$4A + (reg2-reg_BC)*16 - parm*8)
1199 ELSE IllegalOperand;
1200 END;
1201
1202 ELSE IllegalOperand;
1203 END; { CASE reg1 }
1204 END; { o_ADC_SBC }
1205
1206 o_INC_DEC:
1207 BEGIN
1208 reg1 := FindReg(GetWord,regs,regVals);
1209 CASE reg1 OF
1210 reg_B,
1211 reg_C,
1212 reg_D,
1213 reg_E,
1214 reg_H,
1215 reg_L,
1216 reg_A: { INC r }
1217 Instr1($04 + reg1*8 + parm);
1218
1219 reg_BC,
1220 reg_DE,
1221 reg_HL,
1222 reg_SP: { INC rr }
1223 Instr1($03 + (reg1-reg_BC)*16 + parm*8);
1224
1225 reg_IX: Instr2($DD,$23 + parm*8);
1226 reg_IY: Instr2($FD,$23 + parm*8);
1227
1228 reg_Paren: { INC (HL) }
1229 BEGIN
1230 reg1 := FindReg(GetWord,regs,regVals);
1231 CASE reg1 OF
1232 reg_HL:
1233 BEGIN
1234 RParen;
1235 Instr1($34 + parm);
1236 END;
1237
1238 reg_IX,
1239 reg_IY:
1240 BEGIN
1241 IXOffset;
1242 IF reg1=reg_IX
1243 THEN Instr3($DD,$34 + parm,val)
1244 ELSE Instr3($FD,$34 + parm,val);
1245 END;
1246
1247 ELSE IllegalOperand;
1248 END;
1249 END;
1250 END;
1251 END; { o_INC_DEC }
1252
1253 o_JP_CALL:
1254 BEGIN
1255 oldLine := line;
1256 word := GetWord;
1257 IF word='(' THEN BEGIN
1258 reg1 := FindReg(GetWord,regs,regVals);
1259 RParen;
1260 CASE reg1 OF
1261 reg_HL: Instr1($E9);
1262 reg_IX: Instr2($DD,$E9);
1263 reg_IY: Instr2($FD,$E9);
1264 ELSE IllegalOperand;
1265 END;
1266 END
1267 ELSE BEGIN
1268 reg1 := FindReg(word,conds,condVals);
1269 IF reg1=reg_None THEN BEGIN
1270 line := oldLine;
1271 val := Eval;
1272 Instr3W(parm SHR 8,val);
1273 END
1274 ELSE BEGIN
1275 Comma;
1276 val := Eval;
1277 Instr3W((parm AND 255) + reg1*8,val);
1278 END;
1279 END;
1280 END; { o_JP_CALL }
1281
1282 o_JR:
1283 BEGIN
1284 oldLine := line;
1285 reg1 := FindReg(GetWord,conds,condVals);
1286 IF reg1=reg_None THEN BEGIN
1287 line := oldLine;
1288 val := Eval;
1289 val := val - locPtr - 2;
1290 IF (val<-128) OR (val>127) THEN
1291 Error('Branch out of range');
1292 Instr2($18,val);
1293 END
1294 ELSE IF reg1>=4 THEN
1295 IllegalOperand
1296 ELSE BEGIN
1297 Comma;
1298 val := Eval;
1299 val := val - locPtr - 2;
1300 IF (val<-128) OR (val>127) THEN
1301 Error('Branch out of range');
1302 Instr2($20 + reg1*8,val);
1303 END;
1304 END; { o_JR }
1305
1306 o_RET:
1307 BEGIN
1308 reg1 := FindReg(GetWord,conds,condVals);
1309 IF reg1=reg_None THEN Instr1($C9)
1310 ELSE Instr1($C0 + reg1*8);
1311 END; { o_RET }
1312
1313 o_IN:
1314 BEGIN
1315 reg1 := FindReg(GetWord,regs,regVals);
1316 IF NOT (reg1 IN [reg_B..reg_A]) THEN
1317 IllegalOperand
1318 ELSE BEGIN
1319 Comma;
1320 Expect('(');
1321 oldLine := line;
1322 reg2 := FindReg(GetWord,regs,regVals);
1323
1324 IF (reg1=reg_A) AND (reg2=reg_none) THEN BEGIN
1325 line := oldLine;
1326 val := Eval;
1327 RParen;
1328 Instr2($DB,val);
1329 END
1330 ELSE IF reg2=reg_C THEN BEGIN
1331 RParen;
1332 Instr2($ED,$40 + reg1*8)
1333 END
1334 ELSE IllegalOperand;
1335 END;
1336 END; { o_IN }
1337
1338 o_OUT:
1339 BEGIN
1340 Expect('(');
1341 oldLine := line;
1342 reg1 := FindReg(GetWord,regs,regVals);
1343
1344 IF reg1=reg_None THEN BEGIN
1345 line := oldLine;
1346 val := Eval;
1347 RParen;
1348 Comma;
1349 Expect('A');
1350 Instr2($D3,val);
1351 END
1352 ELSE IF reg1=reg_C THEN BEGIN
1353 RParen;
1354 Comma;
1355 reg2 := FindReg(GetWord,regs,regVals);
1356 IF reg2 IN [reg_B..reg_A] THEN BEGIN
1357 Instr2($ED,$41 + reg2*8);
1358 END
1359 ELSE IllegalOperand;
1360 END
1361 ELSE IllegalOperand;
1362 END; { o_OUT }
1363
1364 o_PushPop:
1365 BEGIN
1366 reg1 := FindReg(GetWord,regs,regVals);
1367 CASE reg1 OF
1368 reg_BC,
1369 reg_DE,
1370 reg_HL: Instr1(parm + (reg1-reg_BC)*16);
1371 reg_AF: Instr1(parm + $30);
1372 reg_IX: Instr2($DD,parm + $20);
1373 reg_IY: Instr2($FD,parm + $20);
1374 ELSE IllegalOperand;
1375 END;
1376 END;
1377
1378 o_Arith:
1379 DoArith(parm SHR 8,parm AND 255);
1380
1381 o_Rotate:
1382 BEGIN
1383 reg1 := FindReg(GetWord,regs,regVals);
1384 CASE reg1 OF
1385 reg_B,
1386 reg_C,
1387 reg_D,
1388 reg_E,
1389 reg_H,
1390 reg_L,
1391 reg_A: { RLC r }
1392 Instr2($CB,parm+reg1);
1393
1394 reg_Paren:
1395 BEGIN
1396 reg1 := FindReg(GetWord,regs,regVals);
1397 CASE reg1 OF
1398 reg_HL:
1399 BEGIN
1400 RParen;
1401 Instr2($CB,parm+reg_M);
1402 END;
1403
1404 reg_IX,
1405 reg_IY:
1406 BEGIN
1407 IXOffset;
1408 IF reg1=reg_IX
1409 THEN Instr4($DD,$CB,val,parm+reg_M)
1410 ELSE Instr4($FD,$CB,val,parm+reg_M);
1411 END;
1412
1413 ELSE IllegalOperand;
1414 END;
1415 END;
1416
1417 ELSE IllegalOperand;
1418 END; { CASE reg1 }
1419 END; { o_Rotate }
1420
1421 o_Bit:
1422 BEGIN
1423 reg1 := Eval;
1424 Comma;
1425 reg2 := FindReg(GetWord,regs,regVals);
1426 CASE reg2 OF
1427 reg_B,
1428 reg_C,
1429 reg_D,
1430 reg_E,
1431 reg_H,
1432 reg_L,
1433 reg_A: { BIT n,r }
1434 Instr2($CB,parm + reg1*8 + reg2);
1435
1436 reg_Paren: { BIT n,(HL) }
1437 BEGIN
1438 reg2 := FindReg(GetWord,regs,regVals);
1439 CASE reg2 OF
1440 reg_HL:
1441 BEGIN
1442 RParen;
1443 Instr2($CB,parm + reg1*8 + reg_M);
1444 END;
1445
1446 reg_IX,
1447 reg_IY:
1448 BEGIN
1449 IXOffset;
1450 IF reg1=reg_IX
1451 THEN Instr4($DD,$CB,val,parm + reg1*8 + reg_M)
1452 ELSE Instr4($FD,$CB,val,parm + reg1*8 + reg_M);
1453 END;
1454
1455 ELSE IllegalOperand;
1456 END;
1457 END;
1458 END; { CASE reg2 }
1459 END; { o_Bit }
1460
1461 o_IM:
1462 BEGIN
1463 word := GetWord;
1464 IF word='0' THEN Instr2($ED,$46)
1465 ELSE IF word='1' THEN Instr2($ED,$56)
1466 ELSE IF word='2' THEN Instr2($ED,$5E)
1467 ELSE IllegalOperand;
1468 END;
1469
1470 o_DJNZ:
1471 BEGIN
1472 val := Eval;
1473 val := val - locPtr - 2;
1474 IF (val < -128) OR (val > 127) THEN
1475 Error('Branch out of range');
1476 Instr2($10, val);
1477 END;
1478
1479 o_RST:
1480 BEGIN
1481 val := Eval;
1482 IF val IN [0..7] THEN
1483 Instr1($C7 + val*8)
1484 ELSE IF val IN [$08,$10,$18,$20,$28,$30,$38] THEN
1485 Instr1($C7 + val)
1486 ELSE IllegalOperand;
1487 END;
1488
1489 o_DB:
1490 BEGIN
1491 bytStr := '';
1492
1493 oldLine := line;
1494 word := GetWord;
1495
1496 IF (word='') OR (word=';') THEN
1497 Error('Missing operand');
1498
1499 WHILE (word<>'') AND (word<>';') DO BEGIN
1500 IF word='''' THEN
1501 WHILE word='''' DO BEGIN
1502 val := Pos('''',line);
1503 IF val=0 THEN BEGIN
1504 bytStr := bytStr + line;
1505 line := '';
1506 word := '';
1507 END
1508 ELSE BEGIN
1509 bytStr := bytStr + Copy(line,1,val-1);
1510 Delete(line,1,val);
1511 word := GetWord;
1512 IF word='''' THEN bytStr := bytStr + '''';
1513 END;
1514 END
1515
1516 ELSE BEGIN
1517 line := oldLine;
1518 bytStr := bytStr + CHR(EvalByte);
1519 END;
1520
1521 word := GetWord;
1522 oldLine := line;
1523
1524 IF word=',' THEN BEGIN
1525 word := GetWord;
1526 IF (word='') OR (word=';') THEN
1527 Error('Missing operand');
1528 END;
1529 END;
1530 instrLen := -Length(bytStr);
1531 END;
1532
1533 o_DW:
1534 BEGIN
1535 bytStr := '';
1536
1537 oldLine := line;
1538 word := GetWord;
1539
1540 IF (word='') OR (word=';') THEN
1541 Error('Missing operand');
1542
1543 WHILE (word<>'') AND (word<>';') DO BEGIN
1544 line := oldLine;
1545 val := Eval;
1546 bytStr := bytStr + CHR(val AND 255) + CHR(val SHR 8);
1547
1548 word := GetWord;
1549 oldLine := line;
1550
1551 IF word=',' THEN BEGIN
1552 word := GetWord;
1553 IF (word='') OR (word=';') THEN
1554 Error('Missing operand');
1555 END;
1556 END;
1557 instrLen := -Length(bytStr);
1558 END;
1559
1560 o_DS: BEGIN
1561 val := Eval;
1562
1563 IF pass=2 THEN BEGIN
1564 showAddr := FALSE;
1565 Delete(listLine,1,12);
1566 listLine := Hex4(locPtr) + ' (' + Hex4(val) + ')'
1567 + listLine;
1568 END;
1569
1570 val := val + locPtr;
1571 CodeOrg(val);
1572 END;
1573
1574 o_END: BEGIN
1575 oldLine := line;
1576
1577 IF Length(GetWord)<>0 THEN BEGIN
1578 line := oldLine;
1579 val := Eval;
1580 CodeXfer(val);
1581 line := Copy(line,1,6) + '(' + Hex4(val) + ')' +
1582 Copy(line,13,255);
1583 END;
1584
1585 sourceEnd := TRUE;
1586 END;
1587
1588 ELSE Error('Unknown opcode');
1589 END;
1590END;
1591
1592
1593PROCEDURE DoLabelOp(typ,parm: Integer; labl: SymStr);
1594
1595VAR
1596 val: Integer;
1597 word: string_tp;
1598
1599BEGIN
1600 CASE typ OF
1601 o_EQU: BEGIN
1602 IF Length(labl)=0 THEN
1603 Error('Missing label')
1604 ELSE BEGIN
1605 val := Eval;
1606
1607 listLine := Copy(listLine,1,5) + '= ' + Hex4(val) +
1608 Copy(listLine,12,255);
1609
1610 DefSym(labl,val,parm=1,parm=0);
1611 END;
1612 END;
1613
1614
1615 o_ORG: BEGIN
1616 CodeOrg(Eval);
1617 DefSym(labl,locPtr,FALSE,FALSE);
1618 showAddr := TRUE;
1619 END;
1620
1621 o_LIST: BEGIN
1622 listThisLine := TRUE;
1623
1624 IF Length(labl)<>0 THEN
1625 Error('Label not allowed');
1626
1627 word := GetWord;
1628 IF word='ON' THEN listFlag := TRUE
1629 ELSE IF word='OFF' THEN listFlag := FALSE
1630 ELSE IllegalOperand;
1631 END;
1632
1633 o_OPT: BEGIN
1634 listThisLine := TRUE;
1635
1636 IF Length(labl)<>0 THEN
1637 Error('Label not allowed');
1638
1639 word := GetWord;
1640 IF word='LIST' THEN listFlag := TRUE
1641 ELSE IF word='NOLIST' THEN listFlag := FALSE
1642 ELSE Error('Illegal option');
1643 END;
1644
1645 ELSE Error('Unknown opcode');
1646 END;
1647END;
1648
1649
1650PROCEDURE ListOut;
1651
1652VAR
1653 i: Integer;
1654
1655BEGIN
1656 IF Deblank(listLine) = #12 THEN
1657 WriteLn(listing,#12)
1658
1659 ELSE IF Deblank(listLine)='' THEN
1660 WriteLn(listing)
1661
1662 ELSE BEGIN
1663 i := Length(listLine);
1664 WHILE (i>0) AND (listLine[i]=' ') DO
1665 i:=i-1;
1666 listLine[0] := CHR(i);
1667
1668 WriteLn(listing,listLine);
1669 IF errFlag AND cl_Err THEN
1670 WriteLn(listLine);
1671 END;
1672END;
1673
1674
1675PROCEDURE DoPass;
1676
1677VAR
1678 labl: SymStr;
1679 opcode: OpcdStr;
1680 typ: Integer;
1681 parm: Integer;
1682 i: Integer;
1683 word: string_tp;
1684
1685BEGIN
1686 Assign(source, cl_SrcName);
1687 Reset(source);
1688 sourceEnd := FALSE;
1689
1690 WriteLn('Pass ',pass);
1691
1692 CodeOrg(0);
1693 errCount := 0;
1694 listFlag := TRUE;
1695
1696 WHILE (NOT Eof(source)) AND (NOT SourceEnd) DO BEGIN
1697 ReadLn(source,line);
1698
1699 errFlag := FALSE;
1700 instrLen := 0;
1701 showAddr := FALSE;
1702 listThisLine := ListFlag;
1703 listLine := ' '; { 16 blanks }
1704
1705 IF Pass=2 THEN listLine := Copy(listLine, 1, 16) + line;
1706
1707 labl := '';
1708
1709 IF Length(line) > 0 THEN
1710 IF Pos(line[1], white) = 0 THEN BEGIN
1711 labl := GetWord;
1712 showAddr := (Length(labl) <> 0);
1713
1714 IF Length(line) > 0 THEN
1715 IF line[1] = ':' THEN
1716 Delete(line, 1, 1);
1717
1718 END;
1719
1720 opcode := GetWord;
1721 IF Length(opcode) = 0 THEN BEGIN
1722 typ := 0;
1723 DefSym(labl, locPtr, FALSE, FALSE);
1724 END
1725 ELSE BEGIN
1726 FindOpcode(opcode, typ, parm);
1727
1728 IF typ = o_Illegal THEN Error('Illegal opcode "' +
1729 Deblank(opcode) + '"')
1730 ELSE IF typ < 0 THEN BEGIN
1731 showAddr := FALSE;
1732 DoLabelOp(typ, parm, labl);
1733 END
1734 ELSE BEGIN
1735 showAddr := TRUE;
1736 DefSym(labl, locPtr, FALSE, FALSE);
1737 DoOpcode(typ, parm);
1738 END;
1739
1740 IF typ <> o_Illegal THEN
1741 IF Length(GetWord) > 0 THEN
1742 Error('Too many operands');
1743 END;
1744
1745 IF Pass = 2 THEN BEGIN
1746 IF ShowAddr THEN
1747 listLine := Hex4(locPtr) + Copy(listLine, 5, 255);
1748
1749 IF instrLen > 0 THEN
1750 FOR i := 1 TO instrLen DO BEGIN
1751 word := Hex2(instr[i]);
1752 listLine[i * 2 + 4] := word[1];
1753 listLine[i * 2 + 5] := word[2];
1754 CodeOut(instr[I]);
1755 END
1756 ELSE FOR i := 1 TO -instrLen DO BEGIN
1757 IF I <= 5 THEN BEGIN
1758 word := Hex2(ORD(bytStr[i]));
1759 listLine[i * 2 + 4] := word[1];
1760 listLine[i * 2 + 5] := word[2];
1761 END;
1762 CodeOut(ORD(bytStr[i]));
1763 END;
1764
1765 IF listThisLine THEN ListOut;
1766 END;
1767
1768 locPtr := locPtr + ABS(instrLen);
1769 END;
1770
1771 IF Pass=2 THEN CodeEnd;
1772
1773 { Put the lines after the END statement into the listing file }
1774 { while still checking for listing control statements. Ignore }
1775 { any lines which have invalid syntax, etc., because whatever }
1776 { is found after an END statement should esentially be ignored. }
1777
1778 IF Pass = 2 THEN
1779 WHILE NOT Eof(source) DO BEGIN
1780 listThisLine := listFlag;
1781 listLine := ' ' + line; { 16 blanks }
1782
1783 IF Length(line)>0 THEN
1784 IF Pos(line[1],white)<>0 THEN BEGIN
1785 word := GetWord;
1786 IF Length(word)<>0 THEN BEGIN
1787 IF word='LIST' THEN
1788 BEGIN
1789 listThisLine := TRUE;
1790 word := GetWord;
1791
1792 IF word='ON' THEN listFlag := TRUE
1793 ELSE IF word='OFF' THEN listFlag := FALSE
1794 ELSE listThisLine := listFlag;
1795 END
1796
1797 ELSE IF word='OPT' THEN
1798 BEGIN
1799 listThisLine := TRUE;
1800 word := GetWord;
1801
1802 IF word='LIST' THEN listFlag := TRUE
1803 ELSE IF word='NOLIST' THEN listFlag := FALSE
1804 ELSE listThisLine := listFlag;
1805 END;
1806 END;
1807 END;
1808
1809 IF listThisLine THEN ListOut;
1810 END;
1811
1812 Close(source);
1813END;
1814
1815
1816PROCEDURE SortSymTab;
1817
1818VAR
1819 i,j,t: SymPtr;
1820 sorted: Boolean;
1821 temp: SymRec;
1822
1823BEGIN
1824 IF symTab <> NIL THEN BEGIN
1825
1826 i := symTab;
1827 j := i^.next;
1828 WHILE (j<>NIL) DO BEGIN
1829 sorted := TRUE;
1830
1831 WHILE (j<>NIL) DO BEGIN
1832 IF j^.name < i^.name THEN BEGIN
1833 temp := i^;
1834 i^ := j^;
1835 j^ := temp;
1836
1837 t := i^.next;
1838 i^.next := j^.next;
1839 j^.next := t;
1840
1841 sorted := FALSE;
1842 END;
1843 j := j^.next;
1844 END;
1845 i := i^.next;
1846 j := i^.next;
1847 END;
1848 END;
1849END;
1850
1851
1852PROCEDURE DumpSym(p: SymPtr);
1853
1854BEGIN
1855 Write(listing,p^.name:maxSymLen,' ',Hex4(p^.value));
1856
1857 IF NOT p^.defined THEN Write(listing,' U');
1858 IF p^.multiDef THEN Write(listing,' M');
1859 IF p^.isSet THEN Write(listing,' S');
1860 IF p^.equ THEN Write(listing,' E');
1861
1862 WriteLn(listing);
1863END;
1864
1865
1866PROCEDURE DumpSymTab;
1867
1868VAR
1869 p: SymPtr;
1870
1871BEGIN
1872 SortSymTab;
1873
1874 p := symTab;
1875 WHILE (p<>NIL) DO BEGIN
1876 DumpSym(p);
1877 p := p^.next;
1878 END;
1879END;
1880
1881
1882PROCEDURE ShowOptions;
1883
1884BEGIN
1885 WriteLn;
1886 WriteLn(' Command line syntax:');
1887 WriteLn;
1888 WriteLn(' ASM8080 [options] src [options]');
1889 WriteLn;
1890 WriteLn(' Valid options:');
1891 WriteLn;
1892 WriteLn(' -E Show errors to screen');
1893 WriteLn(' -L Make a listing file to src.LIS');
1894 WriteLn(' -L=name');
1895 WriteLn(' -O Make an objectt file to src.OBJ');
1896 WriteLn(' -O=name');
1897 WriteLn;
1898END;
1899
1900
1901FUNCTION GetOption(VAR optStr: String_tp): String_tp;
1902
1903VAR
1904 option: String[80];
1905 p: Integer;
1906
1907BEGIN
1908 optStr := Deblank(optStr);
1909
1910 p := Pos(' ',optStr);
1911
1912 IF p=0 THEN BEGIN
1913 option := optStr;
1914 optStr := '';
1915 END
1916 ELSE BEGIN
1917 option := Copy(optStr,1,p-1);
1918 optStr := Copy(optStr,p+1,255);
1919 END;
1920
1921 optStr := UprCase(Deblank(optStr));
1922
1923 GetOption := option;
1924END;
1925
1926
1927FUNCTION GetOptions(VAR cl_SrcName, cl_ListName,cl_ObjName: String_tp;
1928 VAR cl_Err: Boolean): Boolean;
1929
1930VAR
1931 s: String_tp;
1932 len: Integer;
1933 optStr: String_tp;
1934 option: String_tp;
1935 optParm: String_tp;
1936 prefix: String_tp;
1937 p: Integer;
1938 err: Integer;
1939 optErr: Boolean;
1940 i: Integer;
1941
1942BEGIN
1943 cl_SrcName := '';
1944 cl_ListName := 'NUL';
1945 cl_ObjName := 'NUL';
1946 cl_Err := FALSE;
1947
1948 optErr := FALSE;
1949 optStr := ParamStr(1);
1950 FOR i := 2 TO ParamCount DO
1951 optStr := optStr + ' ' + ParamStr(i);
1952
1953 option := GetOption(optStr);
1954 WHILE Length(option)<>0 DO BEGIN
1955 optParm := '';
1956
1957 p := Pos('=',option);
1958 IF p>0 THEN BEGIN
1959 optParm := Copy(option,p+1,255);
1960 option := Copy(option,1,p-1);
1961 END;
1962
1963 IF option = '-L' THEN cl_ListName := optParm
1964 ELSE IF option = '-O' THEN cl_ObjName := optParm
1965 ELSE IF option = '-E' THEN cl_Err := TRUE
1966 ELSE IF option = '?' THEN optErr := TRUE
1967 ELSE BEGIN
1968 IF (Copy(option,1,1)='-') OR (Length(cl_SrcName)<>0) OR
1969 (Length(optParm)<>0) THEN BEGIN
1970 optErr := TRUE;
1971 WriteLn('Illegal command line option: ',option);
1972 END
1973 ELSE BEGIN
1974 cl_SrcName := option;
1975 IF Pos('.',cl_SrcName)=0 THEN
1976 IF p=0 THEN cl_SrcName := cl_SrcName + '.ASM';
1977
1978 p := Pos('.',option);
1979 IF p=0 THEN prefix := option
1980 ELSE prefix := Copy(option,1,p-1);
1981 END;
1982 END;
1983
1984 option := GetOption(optStr);
1985 END;
1986
1987 IF cl_SrcName = '' THEN BEGIN
1988 optErr := TRUE;
1989 WriteLn('Source file not specified')
1990 END;
1991
1992 IF cl_ListName = '' THEN cl_ListName := prefix + '.LIS';
1993 IF cl_ObjName = '' THEN cl_ObjName := prefix + '.DAT';
1994 IF Copy(cl_ListName,1,1)='.' THEN cl_ListName := prefix + cl_ListName;
1995 IF Copy(cl_ObjName ,1,1)='.' THEN cl_ObjName := prefix + cl_ObjName;
1996
1997 GetOptions := optErr;
1998END;
1999
2000
2001BEGIN
2002 IF GetOptions(cl_SrcName,cl_ListName,cl_ObjName,cl_Err) THEN BEGIN
2003 ShowOptions;
2004 ReadLn;
2005 Halt;
2006 END;
2007
2008 Assign(listing,cl_ListName);
2009 Rewrite(listing);
2010 Assign(objectt,cl_ObjName);
2011 Rewrite(objectt);
2012
2013 symTab := NIL;
2014 xferAddr := 0;
2015 xferFound := FALSE;
2016 InitOpcodes;
2017
2018 pass := 1;
2019 DoPass;
2020
2021 pass := 2;
2022 DoPass;
2023
2024 WriteLn(listing);
2025 WriteLn(listing,errCount:5,' Total Error(s)');
2026 WriteLn(listing);
2027
2028 IF cl_Err THEN BEGIN
2029 WriteLn;
2030 WriteLn(errCount:5,' Total Error(s)');
2031 END;
2032
2033 DumpSymTab;
2034
2035 Close(listing);
2036 Close(objectt);
2037 ReadLn;
2038END.
Note: See TracBrowser for help on using the repository browser.