--- /dev/null
+(*----------------------------------------------------------------------------*)\r
+(* Mad-Assembler v1.9.0 by Tomasz Biela (aka Tebe/Madteam) *)\r
+(* *)\r
+(* support 6502, 65816, Sparta DOS X, virtual banks *)\r
+(* .LOCAL, .MACRO, .PROC, .STRUCT, .ARRAY, .REPT, .PAGES, .ENUM *)\r
+(* #WHILE, #IF, #ELSE *)\r
+(* *)\r
+(* last changes: 04.08.2009 *)\r
+(*----------------------------------------------------------------------------*)\r
+\r
+// Free Pascal Compiler, http://www.freepascal.org/\r
+// Compile: fpc -Mdelphi -vh -O3 mads.pas\r
+\r
+program MADS;\r
+\r
+{$APPTYPE CONSOLE}\r
+{$I-}\r
+\r
+//uses SysUtils;\r
+\r
+type\r
+\r
+ _typStrREG = string [4];\r
+ _typStrSMB = string [8];\r
+ _typStrINT = string [32];\r
+\r
+ _argArray = array [0..31] of byte;\r
+\r
+ _strArray = array of string;\r
+ _intArray = array of integer;\r
+ _carArray = array of cardinal;\r
+ _bolArray = array of Boolean;\r
+\r
+ labels = record\r
+ nam: cardinal; // identyfikator etykiety (CRC32)\r
+ adr: cardinal; // wartosc etykiety\r
+ ofs: integer; // wartosc etykiety przed zmiana adresu asemblacji\r
+ len: integer; // dlugosc etykiety w bajtach <1..65535>\r
+ blk: integer; // blok przypisany etykiecie\r
+ lln: integer; // dlugosc bloku .LOCAL\r
+ lid: Boolean; // identyfikator etykiety .LOCAL\r
+ bnk: integer; // licznik wirtualnych bankow przypisany do etykiety <0..$FF>, na potrzeby MADS-a jest on typu WORD\r
+ sts: Boolean; // czy definicja etykiety powiodla sie\r
+ rel: Boolean; // czy relokowac\r
+ pas: byte; // numer przebiegu dla danej etykiety\r
+ typ: char; // typ etykiety (V-ARIABLE, P-ROCEDURE, C-ONSTANT)\r
+ use: Boolean; // czy etykieta jest u¿ywana\r
+ end;\r
+\r
+ wywolyw = record\r
+ zm: string; // wiersz listingu\r
+ pl: string; // nazwa pliku ktorego zawartosc asemblujemy\r
+ nr: integer; // numer linii listingu\r
+ end;\r
+\r
+ stosife = record\r
+ _if_test: Boolean; // stan IF_TEST\r
+ _else: Boolean; // czy wystapilo .ELSE\r
+ _okelse: integer; // numer aktualnego poziomu .IF\r
+ old_iftest: Boolean; // stan IF_TEST przed wykonaniem nowego .IF\r
+ end;\r
+\r
+ relocLab = record\r
+ adr: integer; // adres relokowalny\r
+ idx: integer; // indeks do T_SMB lub T_SIZ\r
+ blk: integer; // numer segmentu\r
+ blo: integer; // numer bloku\r
+ bnk: integer; // bank\r
+ end;\r
+\r
+ relocSmb = record\r
+ smb: _typStrSMB; // 8 znakowy symbol SMB dla systemu SDX\r
+ use: Boolean; // czy w programie nastapilo odwolanie do symbolu\r
+ end;\r
+\r
+ extLabel = record\r
+ adr: cardinal; // adres pod ktorym wystapila etykieta external\r
+ bnk: integer; // bank w ktorym wystapila etykieta external\r
+ idx: integer; // index do T_EXT\r
+ typ: char; // typ operacji ' ', '<', '>', '^'\r
+ lsb: byte;\r
+ end;\r
+\r
+ usingLab = record\r
+ lok: integer; // numer obszaru lokalnego\r
+ nam: string; // nazwa obszaru w ktorym wystapilo .USING\r
+ lab: string; // etykieta\r
+ end;\r
+\r
+ pubTab = record\r
+ nam: string; // nazwa etykiety publicznej\r
+ typ: Boolean; // aktualny adres asemblacji\r
+ end;\r
+\r
+ mesTab = record\r
+ pas: byte; // numer przebiegu\r
+ mes: string; // tresc komunikatu bledu\r
+ end;\r
+\r
+ locTab = record\r
+ nam: string; // nazwa bloku .LOCAL\r
+ adr: integer; // aktualny adres asemblacji\r
+ idx: integer; // indeks do tablicy T_LAB\r
+ ofs: integer; // poprzedni adres asemblacji\r
+ end;\r
+\r
+ arrayTab = record\r
+ adr: cardinal; // adres tablicy\r
+ bnk: integer; // bank przypisany tablicy\r
+ idx: integer; // okreslony indeks tablicy [0..IDX]\r
+ def: Boolean; // czy zostal okreslony indeks tablicy\r
+ siz: byte; // wielkosc pola tablicy B-YTE, W-ORD, L-ONG, D-WORD\r
+ len: integer; // dlugosc tablicy w bajtach\r
+ ofs: integer;\r
+ end;\r
+\r
+ varTab = record\r
+ lok: integer; // nr poziomu lokalnego\r
+ nam: string; // nazwa zmiennej\r
+ siz: integer; // rozmiar zmiennej\r
+ cnt: integer; // wielokrotnosc rozmiaru zmiennej\r
+ war: cardinal; // wartosc poczatkowa zmiennej\r
+ adr: integer; // adres zmiennych jesli zostal okreslony\r
+ typ: char; // typ zmiennej V-AR, S-TRUCT, E-NUM\r
+ idx: integer; // indeks do struktury tworzacej zmienna\r
+ str: string; // nazwa struktury tworzacej zmienna\r
+ id: integer; // identyfikator grupy etykiet deklarowanych przez .VAR w tym samym bloku\r
+ zpv: Boolean; // ZPV = TRUE dla zmiennych deklarowanych przez .ZPVAR \r
+ end;\r
+\r
+ stctTab = record\r
+ id: integer; // numer struktury (identyfikator)\r
+ no: integer; // numer pozycji w strukturze (-1 gdy nie sa to pola struktury)\r
+ adr: cardinal; // adres struktury\r
+ bnk: integer; // bank przypisany strukturze\r
+ idx: integer; // index do dodatkowej struktury\r
+ ofs: integer; // ofset od poczatku struktury\r
+ siz: integer; // rozmiar danych definiowanych przez pole struktury 1..4 (B-YTE..D-WORD)\r
+ // lub calkowita dlugosc danych definiowanych przez strukture\r
+ rpt: integer; // liczba powtorzen typu SIZ (SIZ*RPT = rozmiar calkowity pola)\r
+ lab: string; // etykieta wystepujaca w .STRUCT\r
+ end;\r
+\r
+ procTab = record\r
+ nam: string; // nazwa procedury .PROC\r
+ str: integer; // indeks do T_MAC z nazwami parametrow\r
+ adr: cardinal; // adres procedury\r
+ ofs: integer;\r
+ bnk: integer; // bank przypisany procedurze\r
+ par: integer; // liczba parametrow procedury\r
+ ile: integer; // liczba bajtow zajmowana przez parametry procedury\r
+ typ: char; // typ procedury __pDef, __pReg, __pVar\r
+ reg: byte; // kolejnosc rejestrow CPU\r
+ use: Boolean; // czy procedura zostala uzyta w programie, czy pominac ja podczas asemblacji\r
+ len: cardinal; // dlugosc procedury w bajtach\r
+ pnr: integer; // proc_nr\r
+ prc: Boolean; // proc = [TRUE, FALSE]\r
+ oof: integer; // org_ofset\r
+ pnm: string; // proc_name\r
+ end;\r
+\r
+ pageTab = record\r
+ adr: integer; // poczatkowa strona pamieci\r
+ cnt: integer; // liczba stron pamieci\r
+ end;\r
+\r
+ rSizTab = record\r
+ siz: char;\r
+ lsb: byte;\r
+ end;\r
+\r
+ endTab = record\r
+ kod: byte; // kod konca bloku .END??\r
+ adr: integer;\r
+ old: integer;\r
+ sem: Boolean; // czy wystapil znak {\r
+ end;\r
+\r
+ extName = record\r
+ nam: string; // nazwa etykiety external\r
+ siz: char; // zadeklarowany rozmiar etykiety od 1..4 bajtow\r
+ prc: Boolean; // czy etykieta external jest deklaracja procedury\r
+ end;\r
+\r
+ heaMad = record\r
+ nam: string; // nazwa etykiety\r
+ adr: cardinal; // adres przypisany etykiecie\r
+ bnk: byte; // bank przypissany etykiecie\r
+ typ: char; // typ etykiety (P-procedure, V-ariable, C-onstans)\r
+ idx: integer; // index do tablicy T_PRC gdy etykiecie external przypisano procedure\r
+ end;\r
+\r
+ int5 = record // nowy typ dla OBLICZ_MNEMONIK\r
+ l: byte; // liczba bajtow skladajaca sie na rozkaz CPU\r
+ h: _argArray; // argumenty rozkazu\r
+ i: integer; // ofset do tablic\r
+ tmp: byte; // bajt pomocniczy\r
+ end;\r
+\r
+ relVal = record\r
+ use: Boolean;\r
+ cnt: integer;\r
+ end;\r
+\r
+ \r
+ _bckAdr = array [0..1] of integer;\r
+\r
+ c64kb = array [0..$FFFF] of cardinal;\r
+ m64kb = array [0..$FFFF] of byte;\r
+ m4kb = array [0..4095] of byte;\r
+ t256i = array [0..255] of integer;\r
+ t256c = array [0..255] of cardinal;\r
+ t256b = array [0..255] of Boolean;\r
+\r
+var lst, lab, hhh, mmm: textfile;\r
+ dst: file;\r
+\r
+ label_type: char = 'V';\r
+\r
+ pass, status, memType, optDefault: byte;\r
+ opt : byte = 3; // OPT default value\r
+\r
+ bank: integer;\r
+\r
+ __link_stack_pointer_old, __link_stack_address_old, __link_proc_vars_adr_old: cardinal;\r
+ __link_stack_pointer, __link_stack_address, __link_proc_vars_adr: cardinal;\r
+\r
+ blok, proc_lokal, fill, proc_idx: integer;\r
+ whi_idx, while_nr, ora_nr, test_nr, test_idx, sym_idx, org_ofset: integer;\r
+ hea_i, rel_ofs, wyw_idx, array_idx, buf_i: integer;\r
+ proc_nr, lc_nr, lokal_nr, rel_idx, smb_idx, var_id, usi_idx: integer;\r
+ line, line_err, line_all, line_add, ___rept_ile, ext_idx, extn_idx: integer;\r
+ pag_idx, end_idx, pub_idx, var_idx, ifelse, ds_empty: integer;\r
+ siz_idx : integer = 1;\r
+ adres : integer = -$FFFF;\r
+ zpvar : integer = $80;\r
+\r
+ nul : int5;\r
+\r
+ while_name, test_name: string;\r
+ path, name, t, global_name, proc_name, def_label, str_blad: string;\r
+ end_string, plik_h, plik_hm, plik_lst, plik_obj, warning_mes: string;\r
+ plik_lab, plik_mac, plik_asm, macro_nr, lokal_name, warning_old: string;\r
+\r
+ \r
+ regOpty : record\r
+ blk: Boolean;\r
+ use: Boolean;\r
+ reg: array [0..2] of integer;\r
+ end;\r
+\r
+ struct : record\r
+ use, drelocUSE, drelocSDX: Boolean;\r
+ idx, id, adres, cnt: integer;\r
+ end = (use: false; drelocUSE: false; drelocSDX: false; idx: 0; id: 0; adres: 0; cnt: -1);\r
+\r
+ struct_used : record\r
+ use: Boolean; // czy powstala struktura danych\r
+ idx: integer; // index do struktury zalozyciela\r
+ cnt: integer; // licznik pozycji struktury\r
+ end;\r
+\r
+ array_used : record\r
+ idx: integer;\r
+ max: integer; // maksylany indeks na podstawie wprowadzonych danych\r
+ typ: char;\r
+ end;\r
+\r
+ ext_used : record\r
+ use: Boolean;\r
+ idx: integer;\r
+ siz: char;\r
+ end;\r
+\r
+ dreloc : record\r
+ use: Boolean; // czy wystapila dyrektywa .RELOC\r
+ sdx: Boolean; // czy wystapil pseudo rozkaz BLK SPARTA\r
+ siz: char; // rozmiar etykiety\r
+ end;\r
+\r
+ dlink : record\r
+ use: Boolean; // czy linkujemy blok z adresem ladowania $0000\r
+ stc: Boolean; // czy sprawdzalismy adresy stosu\r
+ len: integer; // dlugosc bloku linkowanego\r
+ emp: integer; // dlugosc pustego bloku\r
+ end;\r
+\r
+ skip : record\r
+ use: Boolean; // czy zostal wywolany pseudorozkaz skoku\r
+ xsm: Boolean; // czy wystapilo laczenie mnemonikow w stylu XASM-a\r
+ hlt: Boolean; // blokada TEST_SKIPA jesli przetwarzamy makra rozdzielone znakiem ':'\r
+ idx: integer; // indeks do tablicy T_SKP\r
+ cnt: byte; // liczba odlozonych adresow w przod\r
+ end;\r
+\r
+ blkupd : record\r
+ adr: Boolean; // czy wystapilo BLK UPDATE ADDRESS\r
+ ext: Boolean; // czy wystapilo BLK UPDATE EXTERNAL\r
+ pub: Boolean; // czy wystapilo BLK UPDATE PUBLIC\r
+ sym: Boolean; // czy wystapilo BLK UPDATE SYMBOL\r
+ new: Boolean; // czy wystapilo BLK UPDATE NEW SYMBOL\r
+ end;\r
+\r
+ binary_file : record\r
+ use: Boolean;\r
+ adr: integer;\r
+ end;\r
+\r
+ raw : record\r
+ use: Boolean;\r
+ old: integer;\r
+ end;\r
+\r
+ hea_ofs : record\r
+ adr: integer;\r
+ old: integer;\r
+ end;\r
+\r
+ enum : record\r
+ use, drelocUSE, drelocSDX: Boolean;\r
+ val, max: integer;\r
+ end;\r
+\r
+\r
+ VerifyProc : Boolean = false;\r
+ exProcTest : Boolean = false; // wymagany w celu wyeliminowania 'Unreferenced procedures'\r
+ new_local : Boolean = false;\r
+ NoAllocVar : Boolean = false; // wstrzymaj siê z alokacj¹ zmiennych .VAR\r
+ code6502 : Boolean = false;\r
+ unused_label: Boolean = false;\r
+ regAXY_opty : Boolean = false; // OPT R+- registry optymisation MW?,MV?\r
+ mae_labels : Boolean = false; // OPT ?+- MAE ?labels\r
+ undeclared : Boolean = false;\r
+ variable : Boolean = false;\r
+ klamra_used : Boolean = false;\r
+ noWarning : Boolean = false;\r
+ lst_off : Boolean = false;\r
+ macro : Boolean = false;\r
+ labFirstCol : Boolean = false;\r
+ test_symbols: Boolean = false;\r
+ overflow : Boolean = false;\r
+ blokuj_zapis: Boolean = false;\r
+ FOX_ripit : Boolean = false;\r
+ blocked : Boolean = false;\r
+ rel_used : Boolean = false;\r
+ put_used : Boolean = false;\r
+ exclude_proc: Boolean = false;\r
+ mne_used : Boolean = false;\r
+ data_out : Boolean = false;\r
+ aray : Boolean = false;\r
+ dta_used : Boolean = false;\r
+ pisz : Boolean = false;\r
+ rept : Boolean = false;\r
+ rept_run : Boolean = false;\r
+ empty : Boolean = false;\r
+ reloc : Boolean = false;\r
+ branch : Boolean = false;\r
+ vector : Boolean = false;\r
+ silent : Boolean = false;\r
+ bez_lst : Boolean = false;\r
+ icl_used : Boolean = false;\r
+ komentarz : Boolean = false;\r
+ case_used : Boolean = false;\r
+ full_name : Boolean = false;\r
+ proc : Boolean = false;\r
+ run_macro : Boolean = false;\r
+ loop_used : Boolean = false;\r
+ org : Boolean = false;\r
+ over : Boolean = false;\r
+ open_ok : Boolean = false;\r
+ list_lab : Boolean = false;\r
+ list_hhh : Boolean = false;\r
+ list_mmm : Boolean = false;\r
+ list_mac : Boolean = false;\r
+ next_pass : Boolean = false;\r
+\r
+ regA : Boolean = true; // rozmiar rejestrow dla OPT T+ (track sep rep)\r
+ regX : Boolean = true; // true = 8bit, false = 16bit\r
+ regY : Boolean = true;\r
+\r
+ first_org : Boolean = true;\r
+ if_test : Boolean = true;\r
+ hea : Boolean = true;\r
+\r
+ TestWhileOpt: Boolean = true;\r
+\r
+\r
+ ___search_comment_block : procedure (var i:integer; var zm,txt:string);\r
+\r
+ analizuj_plik__ : procedure (var a:string; var old_str:string);\r
+ analizuj_mem__ : procedure (const start,koniec:integer; var old,a,old_str:string; licz:integer; const p_max:integer; const rp:Boolean);\r
+\r
+ oblicz_mnemonik__ : function (var i:integer; var a,old:string): int5;\r
+ ___wartosc_noSPC : function (var zm,old:string; var i:integer; const sep,typ:Char): Int64;\r
+\r
+\r
+ imes: t256i;\r
+ tCRC16: t256i;\r
+ tCRC32: t256c;\r
+\r
+\r
+ reptPar: _strArray; // globalna tablica dla parametrów przekazywanych do .REPT\r
+\r
+ \r
+ // zmienna przechowujaca 2 adresy wstecz\r
+ t_bck: _bckAdr;\r
+\r
+ // hashowane mnemoniki i tryby adresowania\r
+ hash: m64kb;\r
+\r
+ // bufor dla dyrektywy .GET i .PUT\r
+ t_get: m64kb;\r
+\r
+ // bufor dla dyrektywy .LINK\r
+ t_lnk: m64kb;\r
+\r
+ // bufor dla wpisywanych danych do .ARRAY\r
+ t_tmp: c64kb;\r
+\r
+ // bufor dla odczytu plikow przez INS, maksymalna dlugosc pliku to 64KB\r
+ t_ins: m64kb;\r
+\r
+ // bufor pamieci dla zapisu\r
+ t_buf: m4kb;\r
+\r
+ // 256 znaczników dla zmiennych odkladanych na stronie zerowej\r
+ t_zpv: t256b;\r
+\r
+ // T_HEA zapamieta dlugosc bloku\r
+ t_hea: _intArray;\r
+\r
+ // tablica przechowujaca adres naprzod\r
+ t_skp: _intArray;\r
+\r
+ // T_LIN przechowuje polaczone znakiem '\' linie listingu (rozbite na wiersze)\r
+ t_lin: _strArray;\r
+\r
+ // T_MAC zapamieta linie z makrami, procedurami, petlami .REPT\r
+ t_mac: _strArray;\r
+\r
+ // T_PAR zapamieta nazwy parametrow procedur .PROC\r
+ t_par: _strArray;\r
+\r
+ // T_PTH zapamieta sciezki poszukiwan dla INS i ICL\r
+ t_pth: _strArray;\r
+\r
+ // T_SYM zapamieta nowe symbole dla SDX (blk update new i_settd 'i_settd')\r
+ t_sym: _strArray;\r
+\r
+ // T_ELS zapamieta wystapienia #ELSE w blokach #IF\r
+ t_els: _bolArray;\r
+\r
+ // T_LOC zapamieta nazwy obszarow .LOCAL\r
+ t_loc: array of locTab;\r
+\r
+ // MESSAGES - komunikaty o bledach i ostrzezeniach\r
+ messages: array of mesTab;\r
+\r
+ // T_PUB zapamieta nazwy etykiet .PUBLIC\r
+ t_pub: array of pubTab;\r
+\r
+ // T_VAR zapamieta nazwy etykiet .VAR\r
+ t_var: array of varTab;\r
+\r
+ // T_END zapamieta kolejnosci wywolywania dyrektyw .MACRO, .PROC, .LOCAL, .STRUCT, .ARRAY itd.\r
+ t_end: array of endTab;\r
+\r
+ // T_SIZ zapamieta rozmiary argumentow\r
+ t_siz: array of rSizTab;\r
+\r
+ // T_MAD zapamieta etykiety dla pliku naglowkowego *.HEA (-hm)\r
+ t_mad: array of heaMad;\r
+\r
+ // T_PAG zapamieta paremetry dla dyrektywy .PAGE\r
+ t_pag: array of pageTab;\r
+\r
+ // T_USI zapamieta paremetry dla dyrektywy .USE [.USING]\r
+ t_usi: array of usingLab;\r
+\r
+ // T_EXT zapamieta adresy wystapienia etykiet external\r
+ // T_EXTN zapamieta deklaracje etykiet external\r
+ t_ext: array of extLabel;\r
+ t_extn: array of extName;\r
+\r
+ // T_ARR zapamieta parametry tablic .ARRAY\r
+ t_arr: array of arrayTab;\r
+\r
+ // T_REL zapamieta relokowalne adresy etykiet SDX\r
+ t_rel: array of relocLab;\r
+\r
+ // T_SMB zapamieta relokowalne adresy symboli SDX\r
+ t_smb: array of relocSmb;\r
+\r
+ // T_PRC zapamieta parametry procedury .PROC\r
+ t_prc: array of procTab;\r
+\r
+ // T_LAB zapamieta etykiety\r
+ t_lab: array of labels;\r
+\r
+ // T_WYW zapamieta linie z wywolywanymi makrami, pomocne przy wyswietlaniu linii z bledem\r
+ t_wyw: array of wywolyw;\r
+\r
+ // T_STR zapamieta nazwy struktur .STRUCT\r
+ t_str: array of stctTab;\r
+\r
+ // stos dla operacji .IF .ELSE .ENDIF\r
+ if_stos: array of stosife;\r
+ \r
+\r
+ pass_end : byte = 2; // pass = <0..2>\r
+\r
+\r
+// komunikaty\r
+ mes: array [0..2911] of char=(\r
+{0} chr(ord('V') + $80),'a','l','u','e',' ','o','u','t',' ','o','f',' ','r','a','n','g','e',\r
+{1} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','I','F',\r
+{2} chr(ord(' ') + $80),'d','e','c','l','a','r','e','d',' ','t','w','i','c','e',\r
+{3} chr(ord('S') + $80),'t','r','i','n','g',' ','e','r','r','o','r',\r
+{4} chr(ord('E') + $80),'x','t','r','a',' ','c','h','a','r','a','c','t','e','r','s',' ','o','n',' ','l','i','n','e',\r
+{5} chr(ord('U') + $80),'n','d','e','c','l','a','r','e','d',' ','l','a','b','e','l',' ',\r
+{6} chr(ord('N') + $80),'o',' ','m','a','t','c','h','i','n','g',' ','b','r','a','c','k','e','t',\r
+{7} chr(ord('N') + $80),'e','e','d',' ','p','a','r','e','n','t','h','e','s','i','s',\r
+{8} chr(ord('I') + $80),'l','l','e','g','a','l',' ','c','h','a','r','a','c','t','e','r',':',' ',\r
+{9} chr(ord('R') + $80),'e','s','e','r','v','e','d',' ','w','o','r','d',' ',\r
+{10} chr(ord('N') + $80),'o',' ','O','R','G',' ','s','p','e','c','i','f','i','e','d',\r
+{11} chr(ord('C') + $80),'P','U',' ','d','o','e','s','n','''','t',' ','h','a','v','e',' ','s','o',' ','m','a','n','y',' ','r','e','g','i','s','t','e','r','s',\r
+{12} chr(ord('I') + $80),'l','l','e','g','a','l',' ','i','n','s','t','r','u','c','t','i','o','n',' ',\r
+{13} chr(ord('V') + $80),'a','l','u','e',' ','o','u','t',' ','o','f',' ','r','a','n','g','e',\r
+{14} chr(ord('I') + $80),'l','l','e','g','a','l',' ','a','d','d','r','e','s','s','i','n','g',' ','m','o','d','e',' ','(','C','P','U',' ','6','5',\r
+{15} chr(ord('L') + $80),'a','b','e','l',' ','n','a','m','e',' ','r','e','q','u','i','r','e','d',\r
+{16} chr(ord('I') + $80),'n','v','a','l','i','d',' ','o','p','t','i','o','n',\r
+{17} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D',\r
+{18} chr(ord('C') + $80),'a','n','n','o','t',' ','o','p','e','n',' ','o','r',' ','c','r','e','a','t','e',' ','f','i','l','e',\r
+{19} chr(ord('N') + $80),'e','s','t','e','d',' ','o','p','-','c','o','d','e','s',' ','n','o','t',' ','s','u','p','p','o','r','t','e','d',\r
+{20} chr(ord('M') + $80),'i','s','s','i','n','g',' ','''','}','''',\r
+{21} chr(ord('B') + $80),'r','a','n','c','h',' ','o','u','t',' ','o','f',' ','r','a','n','g','e',' ','b','y',' ','$',\r
+{22} chr(ord(' ') + $80),'b','y','t','e','s',\r
+{23} chr(ord('U') + $80),'n','e','x','p','e','c','t','e','d',' ','e','n','d',' ','o','f',' ','l','i','n','e',\r
+{24} chr(ord('F') + $80),'i','l','e',' ','i','s',' ','t','o','o',' ','s','h','o','r','t',\r
+{25} chr(ord('F') + $80),'i','l','e',' ','i','s',' ','t','o','o',' ','l','o','n','g',\r
+{26} chr(ord('D') + $80),'i','v','i','d','e',' ','b','y',' ','z','e','r','o',\r
+{27} chr(ord('^') + $80),' ','n','o','t',' ','r','e','l','o','c','a','t','a','b','l','e',\r
+{28} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','L','O','C','A','L',\r
+{29} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','L',\r
+{30} chr(ord('U') + $80),'s','e','r',' ','e','r','r','o','r',\r
+{31} chr(ord('O') + $80),'p','e','r','a','n','d',' ','o','v','e','r','f','l','o','w',\r
+{32} chr(ord('B') + $80),'a','d',' ','s','i','z','e',' ','s','p','e','c','i','f','i','e','r',\r
+{33} chr(ord('S') + $80),'i','z','e',' ','s','p','e','c','i','f','i','e','r',' ','n','o','t',' ','r','e','q','u','i','r','e','d',\r
+{34} chr(ord(' ') + $80), // !!! zarezerwowane !!! USER ERROR\r
+{35} chr(ord('U') + $80),'n','d','e','c','l','a','r','e','d',' ','m','a','c','r','o',' ',\r
+{36} chr(ord('C') + $80),'a','n','''','t',' ','r','e','p','e','a','t',' ','t','h','i','s',' ','d','i','r','e','c','t','i','v','e',\r
+{37} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','I','F',\r
+{38} chr(ord('L') + $80),'a','b','e','l',' ','n','o','t',' ','r','e','q','u','i','r','e','d',\r
+{39} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','P','R','O','C',\r
+{40} chr(ord('I') + $80),'m','p','r','o','p','e','r',' ','n','u','m','b','e','r',' ','o','f',' ','a','c','t','u','a','l',' ','p','a','r','a','m','e','t','e','r','s',\r
+{41} chr(ord('I') + $80),'n','c','o','m','p','a','t','i','b','l','e',' ','t','y','p','e','s',' ',\r
+{42} chr(ord('.') + $80),'E','N','D','I','F',' ','e','x','p','e','c','t','e','d',\r
+{43} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','R',\r
+{44} chr(ord('S') + $80),'M','B',' ','l','a','b','e','l',' ','t','o','o',' ','l','o','n','g',\r
+{45} chr(ord('T') + $80),'o','o',' ','m','a','n','y',' ','b','l','o','c','k','s',\r
+{46} chr(ord('B') + $80),'a','d',' ','p','a','r','a','m','e','t','e','r',' ','t','y','p','e',' ',\r
+{47} chr(ord('B') + $80),'a','d',' ','p','a','r','a','m','e','t','e','r',' ','n','u','m','b','e','r',\r
+{48} chr(ord(' ') + $80),'l','i','n','e','s',' ','o','f',' ','s','o','u','r','c','e',' ','a','s','s','e','m','b','l','e','d',\r
+{49} chr(ord(' ') + $80),'b','y','t','e','s',' ','w','r','i','t','t','e','n',' ','t','o',' ','t','h','e',' ','o','b','j','e','c','t',' ','f','i','l','e',\r
+{50} chr(ord('M') + $80),'i','s','s','i','n','g',' ','t','y','p','e',' ','l','a','b','e','l',\r
+{51} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','R','E','P','T',\r
+{52} chr(ord('B') + $80),'a','d',' ','o','r',' ','m','i','s','s','i','n','g',' ','s','i','n','u','s',' ','p','a','r','a','m','e','t','e','r',\r
+{53} chr(ord('O') + $80),'n','l','y',' ','R','E','L','O','C',' ','b','l','o','c','k',\r
+{54} chr(ord('L') + $80),'a','b','e','l',' ','t','a','b','l','e',':',\r
+{55} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','S','T','R','U','C','T',\r
+{56} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','S',\r
+{57} chr(ord('C') + $80),'a','n',' ','n','o','t',' ','u','s','e',' ','r','e','c','u','r','s','i','v','e',' ','s','t','r','u','c','t','u','r','e','s',\r
+{58} chr(ord('I') + $80),'m','p','r','o','p','e','r',' ','s','y','n','t','a','x',\r
+{59} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','A','R','R','A','Y',\r
+{60} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','A',\r
+{61} chr(ord('C') + $80),'P','U',' ','d','o','e','s','n','''','t',' ','h','a','v','e',' ','r','e','g','i','s','t','e','r',' ',\r
+{62} chr(ord('C') + $80),'o','n','s','t','a','n','t',' ','e','x','p','r','e','s','s','i','o','n',' ','v','i','o','l','a','t','e','s',' ','s','u','b','r','a','n','g','e',' ','b','o','u','n','d','s',\r
+{63} chr(ord('B') + $80),'a','d',' ','r','e','g','i','s','t','e','r',' ','s','i','z','e',\r
+{64} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','P','A','G','E','S',\r
+{65} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','P','G',\r
+{66} chr(ord('I') + $80),'n','f','i','n','i','t','e',' ','r','e','c','u','r','s','i','o','n',\r
+{67} chr(ord('D') + $80),'e','f','a','u','l','t',' ','a','d','d','r','e','s','s','i','n','g',' ','m','o','d','e',\r
+{68} chr(ord('U') + $80),'n','k','n','o','w','n',' ','d','i','r','e','c','t','i','v','e',' ',\r
+{69} chr(ord('U') + $80),'n','r','e','f','e','r','e','n','c','e','d',' ','p','r','o','c','e','d','u','r','e',' ',\r
+{70} chr(ord('P') + $80),'a','g','e',' ','e','r','r','o','r',' ','a','t',' ',\r
+{71} chr(ord('I') + $80),'l','l','e','g','a','l',' ','i','n','s','t','r','u','c','t','i','o','n',' ','a','t',' ','R','E','L','O','C',' ','b','l','o','c','k',\r
+{72} chr(ord('U') + $80),'n','r','e','f','e','r','e','n','c','e','d',' ','d','i','r','e','c','t','i','v','e',' ','.','E','N','D',\r
+{73} chr(ord('U') + $80),'n','d','e','f','i','n','e','d',' ','s','y','m','b','o','l',' ',\r
+{74} chr(ord('I') + $80),'n','c','o','r','r','e','c','t',' ','h','e','a','d','e','r',' ','f','o','r',' ','t','h','i','s',' ','f','i','l','e',' ','t','y','p','e',\r
+{75} chr(ord('I') + $80),'n','c','o','m','p','a','t','i','b','l','e',' ','s','t','a','c','k',' ','p','a','r','a','m','e','t','e','r','s',\r
+{76} chr(ord('Z') + $80),'e','r','o',' ','p','a','g','e',' ','R','E','L','O','C',' ','b','l','o','c','k',\r
+{77} chr(ord(' ') + $80),'(','B','A','N','K','=', // od 77 kolejnosc wystapienia istotna\r
+{78} chr(ord(' ') + $80),'(','B','L','O','K','=',\r
+{79} chr(ord('L') + $80),'a','b','e','l',' ',\r
+{80} chr(ord(')') + $80),' ','E','R','R','O','R',':',' ',\r
+{81} chr(ord('0') + $80),'2',')',\r
+{82} chr(ord('8') + $80),'1','6',')',\r
+{83} chr(ord('O') + $80),'R','G',' ','s','p','e','c','i','f','i','e','d',' ','a','t',' ','R','E','L','O','C',' ','b','l','o','c','k',\r
+{84} chr(ord('C') + $80),'a','n','''','t',' ','s','k','i','p',' ','o','v','e','r',' ','t','h','i','s',\r
+{85} chr(ord('A') + $80),'d','d','r','e','s','s',' ','r','e','l','o','c','a','t','i','o','n',' ','o','v','e','r','l','o','a','d',\r
+{86} chr(ord('N') + $80),'o','t',' ','r','e','l','o','c','a','t','a','b','l','e',\r
+{87} chr(ord('V') + $80),'a','r','i','a','b','l','e',' ','a','d','d','r','e','s','s',' ','o','u','t',' ','o','f',' ','r','a','n','g','e',\r
+{88} chr(ord('M') + $80),'i','s','s','i','n','g',' ','#','W','H','I','L','E',\r
+{89} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','W',\r
+{90} chr(ord('B') + $80),'L','K',' ','U','P','D','A','T','E',' ',\r
+{91} chr(ord('A') + $80),'D','D','R','E','S','S',\r
+{92} chr(ord('E') + $80),'X','T','E','R','N','A','L',\r
+{93} chr(ord('P') + $80),'U','B','L','I','C',\r
+{94} chr(ord('S') + $80),'Y','M','B','O','L',\r
+{95} chr(ord('M') + $80),'i','s','s','i','n','g',' ','#','I','F',\r
+{96} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','T',\r
+{97} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','M','A','C','R','O',\r
+{98} chr(ord('S') + $80),'k','i','p','p','i','n','g',' ','o','n','l','y',' ','t','h','e',' ','f','i','r','s','t',' ','i','n','s','t','r','u','c','t','i','o','n',\r
+{99} chr(ord('R') + $80),'e','p','e','a','t','i','n','g',' ','o','n','l','y',' ','t','h','e',' ','l','a','s','t',' ','i','n','s','t','r','u','c','t','i','o','n',\r
+{100} chr(ord('O') + $80),'n','l','y',' ','S','D','X',' ','R','E','L','O','C',' ','b','l','o','c','k',\r
+{101} chr(ord('L') + $80),'i','n','e',' ','t','o','o',' ','l','o','n','g',\r
+{102} chr(ord('C') + $80),'o','n','s','t','a','n','t',' ','e','x','p','r','e','s','s','i','o','n',' ','e','x','p','e','c','t','e','d',\r
+{103} chr(ord('C') + $80),'a','n',' ','n','o','t',' ','d','e','c','l','a','r','e',' ','l','a','b','e','l',' ',\r
+{104} chr(ord(' ') + $80),'a','s',' ','p','u','b','l','i','c',\r
+{105} chr(ord('W') + $80),'r','i','t','i','n','g',' ','l','i','s','t','i','n','g',' ','f','i','l','e','.','.','.',\r
+{106} chr(ord('W') + $80),'r','i','t','i','n','g',' ','o','b','j','e','c','t',' ','f','i','l','e','.','.','.',\r
+{107} chr(ord('U') + $80),'s','e',' ','s','q','u','a','r','e',' ','b','r','a','c','k','e','t','s',' ','i','n','s','t','e','a','d',\r
+{108} chr(ord('C') + $80),'a','n','''','t',' ','f','i','l','l',' ','f','r','o','m',' ','h','i','g','h','e','r',' ','t','o',' ','l','o','w','e','r',' ','m','e','m','o','r','y',' ','l','o','c','a','t','i','o','n',\r
+{109} chr(ord('A') + $80),'c','c','e','s','s',' ','v','i','o','l','a','t','i','o','n','s',' ','a','t',' ','a','d','d','r','e','s','s',' ',\r
+{110} chr(ord('N') + $80),'o',' ','i','n','s','t','r','u','c','t','i','o','n',' ','t','o',' ','r','e','p','e','a','t',\r
+{111} chr(ord('I') + $80),'l','l','e','g','a','l',' ','w','h','e','n',' ','A','t','a','r','i',' ','f','i','l','e',' ','h','e','a','d','e','r','s',' ','d','i','s','a','b','l','e','d',\r
+{112} chr(ord('T') + $80),'h','e',' ','r','e','f','e','r','e','n','c','e','d',' ','l','a','b','e','l',' ',\r
+{113} chr(ord(' ') + $80),'h','a','s',' ','n','o','t',' ','p','r','e','v','i','o','u','s','l','y',' ','b','e','e','n',' ','d','e','f','i','n','e','d',' ','p','r','o','p','e','r','l','y',\r
+{114} chr(ord('U') + $80),'n','i','n','i','t','i','a','l','i','z','e','d',' ','v','a','r','i','a','b','l','e',\r
+{115} chr(ord('U') + $80),'n','u','s','e','d',' ','l','a','b','e','l',' ',\r
+{116} chr(ord('''') + $80),'#','''',' ','i','s',' ','a','l','l','o','w','e','d',' ','o','n','l','y',' ','i','n',' ','r','e','p','e','a','t','e','d',' ','l','i','n','e','s',\r
+\r
+{117} chr(ord('S') + $80),\r
+ 'y','n','t','a','x',':',' ','m','a','d','s',' ','s','o','u','r','c','e',' ','[','s','w','i','t','c','h','e','s',']',#13,#10,\r
+ '-','b',':','a','d','d','r','e','s','s',#9,'G','e','n','e','r','a','t','e',' ','b','i','n','a','r','y',' ','f','i','l','e',' ','a','t',' ','s','p','e','c','i','f','i','c',' ','a','d','d','r','e','s','s',#13,#10,\r
+ '-','c',#9,#9,'L','a','b','e','l',' ','c','a','s','e',' ','s','e','n','s','i','t','i','v','i','t','y',#13,#10,\r
+ '-','d',':','l','a','b','e','l','=','v','a','l','u','e',#9,'D','e','f','i','n','e',' ','a',' ','l','a','b','e','l',#13,#10,\r
+ '-','f',#9,#9,'C','P','U',' ','c','o','m','m','a','n','d',' ','a','t',' ','f','i','r','s','t',' ','c','o','l','u','m','n',#13,#10,\r
+ '-','h','c','[',':','f','i','l','e','n','a','m','e',']',#9,'H','e','a','d','e','r',' ','f','i','l','e',' ','f','o','r',' ','C','C','6','5',#13,#10,\r
+ '-','h','m','[',':','f','i','l','e','n','a','m','e',']',#9,'H','e','a','d','e','r',' ','f','i','l','e',' ','f','o','r',' ','M','A','D','S',#13,#10,\r
+ '-','i',':','p','a','t','h',#9,#9,'A','d','d','i','t','i','o','n','a','l',' ','i','n','c','l','u','d','e',' ','d','i','r','e','c','t','o','r','i','e','s',#13,#10,\r
+ '-','l','[',':','f','i','l','e','n','a','m','e',']',#9,'G','e','n','e','r','a','t','e',' ','l','i','s','t','i','n','g',#13,#10,\r
+ '-','m',':','f','i','l','e','n','a','m','e',#9,'F','i','l','e',' ','w','i','t','h',' ','m','a','c','r','o',' ','d','e','f','i','n','i','t','i','o','n',#13,#10,\r
+ '-','o',':','f','i','l','e','n','a','m','e',#9,'S','e','t',' ','o','b','j','e','c','t',' ','f','i','l','e',' ','n','a','m','e',#13,#10,\r
+ '-','p',#9,#9,'P','r','i','n','t',' ','f','u','l','l','y',' ','q','u','a','l','i','f','i','e','d',' ','f','i','l','e',' ','n','a','m','e','s',' ','i','n',' ','l','i','s','t','i','n','g',' ','a','n','d',' ','e','r','r','o','r',' ','m','e','s','s','a','g','e','s',#13,#10,\r
+ '-','s',#9,#9,'S','i','l','e','n','t',' ','m','o','d','e',#13,#10,\r
+ '-','t','[',':','f','i','l','e','n','a','m','e',']',#9,'L','i','s','t',' ','l','a','b','e','l',' ','t','a','b','l','e',#13,#10,\r
+ '-','x',#9,#9,'E','x','c','l','u','d','e',' ','u','n','r','e','f','e','r','e','n','c','e','d',' ','p','r','o','c','e','d','u','r','e','s',#13,#10,\r
+ '-','v','u',#9,#9,'V','e','r','i','f','y',' ','c','o','d','e',' ','i','n','s','i','d','e',' ','u','n','r','e','f','e','r','e','n','c','e','d',' ','p','r','o','c','e','d','u','r','e','s',#13,#10,\r
+ '-','u',#9,#9,'W','a','r','n',' ','o','f',' ','u','n','u','s','e','d',' ','l','a','b','e','l','s',\r
+\r
+ chr($80),\r
+\r
+// version\r
+\r
+{118} chr(ord('m') + $80),'a','d','s',' ','1','.','9','.','0',chr($80),' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',\r
+\r
+ chr($80));\r
+\r
+\r
+const\r
+ pass_max = 16; // maksymalna mozliwa liczba przebiegow asemblacji\r
+\r
+ __equ = $80; // kody pseudo rozkazow\r
+ __opt = $81;\r
+ __org = $82;\r
+ __ins = $83;\r
+ __end = $84;\r
+ __dta = $85;\r
+ __icl = $86;\r
+ __run = $87; // RUN\r
+ __nmb = $88;\r
+ __ini = $89; // INI-RUN = 2 !!! koniecznie !!!\r
+// __bot = $8a; // BOT aktualnie nie oprogramowany\r
+ __rmb = $8b;\r
+ __lmb = $8c;\r
+ __ert = $8d;\r
+// __ift = $8e; // -> .IF\r
+// __els = $8f; // -> .ELSE\r
+// __eif = $90; // -> .ENDIF\r
+// __eli = $91; // -> .ELSEIF\r
+ __smb = $92;\r
+ __blk = $93;\r
+ __ext = $94;\r
+\r
+ __cpbcpd = $97; // kody makro rozkazow __cpbcpd..__jskip\r
+ __adbsbb = $98;\r
+ __phrplr = $99;\r
+ __adwsbw = $9A;\r
+ __BckSkp = $9B;\r
+ __inwdew = $9C;\r
+ __addsub = $9D;\r
+ __movaxy = $9E;\r
+ __jskip = $9F; // koniec kodów makro rozkazów\r
+\r
+ __macro = $A0; // kody dyrektyw, kolejnosc wg tablicy 'MAC' + $A0\r
+ __if = $A1;\r
+ __endif = $A2;\r
+ __endm = $A3;\r
+ __exit = $A4;\r
+ __error = $A5;\r
+ __else = $A6;\r
+ __print = $A7; // = __echo\r
+ __proc = $A8;\r
+ __endp = $A9;\r
+ __elseif = $AA;\r
+ __local = $AB;\r
+ __endl = $AC;\r
+ __rept = $AD;\r
+ __endr = $AE;\r
+\r
+ __byte = $AF; // kody dla .BYTE, .WORD, .LONG, .DWORD\r
+// __word = $B0; // nastepuja po sobie, !!! koniecznie !!!\r
+// __long = $B1;\r
+ __dword = $B2;\r
+\r
+ __byteValue = __byte-1; // zastapi operacje (...-__byte+1)\r
+\r
+ __struct = $B3;\r
+ __ends = $B4;\r
+ __ds = $B5;\r
+ __symbol = $B6;\r
+ __fl = $B7;\r
+ __array = $B8;\r
+ __enda = $B9;\r
+ __get = $BA;\r
+ __put = $BB;\r
+ __sav = $BC;\r
+ __pages = $BD;\r
+ __endpg = $BE;\r
+ __reloc = $BF;\r
+ __dend = $C0; // zastepuje dyrektywy .ENDL, .ENDP, .ENDS, .ENDM itd.\r
+ __link = $C1;\r
+ __extrn = $C2; // odpowiednik pseudo rozkazu EXT\r
+ __public = $C3; // odpowiednik dla .GLOBAL, .GLOBL\r
+\r
+ __reg = $C4; // __REG, __VAR koniecznie w tej kolejnosci\r
+ __var = $C5;\r
+\r
+ __or = $C6;\r
+ __by = $C7;\r
+ __he = $C8;\r
+ __wo = $C9;\r
+ __en = $CA;\r
+ __sb = $CB;\r
+ __while = $CC;\r
+ __endw = $CD;\r
+ __test = $CE;\r
+ __endt = $CF;\r
+ __using = $D0;\r
+ __ifndef = $D1;\r
+ __nowarn = $D2;\r
+ __def = $D3;\r
+ __ifdef = $D4;\r
+ __align = $D5;\r
+ __zpvar = $D6;\r
+ __enum = $D7;\r
+ __ende = $D8;\r
+\r
+ __over = __ende; // koniec kodow dyrektyw\r
+\r
+\r
+// __switch = $E0; // nie oprogramowane\r
+// __case = $E1;\r
+ __telse = $E2;\r
+\r
+\r
+ __nill = $F0;\r
+ __addEqu = $F1;\r
+ __xasm = $F2;\r
+\r
+ __blkSpa = $F3;\r
+ __blkRel = $F4;\r
+ __blkEmp = $F5;\r
+\r
+ __struct_run_noLabel = $F6; // ostatni wolny tutaj kod to $F7\r
+\r
+\r
+ __rel = $0000; // wartosc dla etykiet relokowalnych\r
+\r
+ __relASM = $0100; // adres asemblacji dla bloku .RELOC\r
+\r
+ __relHea = ord('M')+ord('R') shl 8; // naglowek 'MR' dla bloku .RELOC\r
+\r
+\r
+ __id_param = $FFF7; // !!! zaczynamy koniecznie od __ID_PARAM !!!\r
+ __id_array = $FFF8;\r
+ __dta_struct = $FFF9;\r
+ __id_ext = $FFFA;\r
+ __id_smb = $FFFB;\r
+ __id_macro = $FFFC;\r
+ __id_enum = $FFFD;\r
+ __id_struct = $FFFE;\r
+ __id_proc = $FFFF;\r
+\r
+ __array_run = byte(__id_array);\r
+ __macro_run = byte(__id_macro);\r
+ __enum_run = byte(__id_enum);\r
+ __struct_run = byte(__id_struct);\r
+ __proc_run = byte(__id_proc);\r
+\r
+ __hea_dos = $FFFF; // naglowek dla bloku DOS\r
+ __hea_reloc = $0000; // naglowek dla bloku .RELOC\r
+ __hea_public = $FFED; // naglowek dla bloku aktualizacji symboli public\r
+ __hea_external = $FFEE; // naglowek dla bloku aktualizacji symboli external\r
+ __hea_address = $FFEF; // naglowek dla bloku aktualizacji adresow relokowalnych\r
+\r
+ __pDef = 'D'; // Default\r
+ __pReg = 'R'; // Registry\r
+ __pVar = 'V'; // Variable\r
+\r
+\r
+ __test_label = '##TB'; // etykieta dla poczatku bloku #IF\r
+ __telse_label = '@?@?@ML?ET'; // etykieta dla poczatku bloku #ELSE\r
+ __endt_label = '@?@?@ML?TE'; // etykieta dla konca bloku #IF (#END)\r
+\r
+ __while_label = '##B'; // etykieta dla poczatku bloku #WHILE\r
+ __endw_label = '@?@?@ML?E'; // etykieta dla konca bloku #WHILE (#END)\r
+ \r
+\r
+ mads_stack: array [0..2] of string[14] =\r
+ ('@STACK_POINTER', '@STACK_ADDRESS', '@PROC_VARS_ADR');\r
+\r
+ tType: array [1..4] of char =\r
+ ('B','A','T','F'); // typy uzywane wewnetrznie przez MADS\r
+\r
+ relType: array [1..7] of char =\r
+ ('B','W','L','D','<','>','^'); // typy zapisywane w relokowalnych plikach\r
+\r
+ mads_param: array [1..4] of string [7] =\r
+ ('.BYTE ', '.WORD ', '.LONG ', '.DWORD ');\r
+\r
+ PathDelim: char = '/';\r
+\r
+\r
+function _pth(const a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* test dla roznych znakow PathDelim *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ _pth := (a in ['/','\'])\r
+end;\r
+\r
+\r
+{procedure czytaj_komentarz(var i: integer; var a, txt: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* czytamy komentarz ograniczony znakami /* */ *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ txt:=txt+'/*'; inc(i,2);\r
+ komentarz:=true;\r
+\r
+ while komentarz and (i<=length(a)) do begin\r
+\r
+ txt:=txt+a[i];\r
+\r
+ if a[i]='*' then\r
+ if a[i+1]='/' then begin txt:=txt+'/'; inc(i); komentarz:=false end;\r
+\r
+ inc(i);\r
+ end;\r
+end; }\r
+\r
+\r
+procedure omin_spacje (var i:integer; var a:string);\r
+(*----------------------------------------------------------------------------*)\r
+(* omijamy tzw. "biale spacje" czyli spacje, tabulatory, komentarze /* */ *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+begin\r
+\r
+ if a<>'' then begin\r
+ while a[i] in [' ',#9] do inc(i);\r
+\r
+ if (a[i]='/') and (a[i+1]='*') then begin\r
+ txt:=''; ___search_comment_block(i,a, txt);\r
+\r
+ if not(komentarz) then omin_spacje(i,a);\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure __inc(var i:integer; var a:string);\r
+begin\r
+\r
+ if i>length(a) then exit;\r
+\r
+ inc(i);\r
+ omin_spacje(i,a);\r
+ \r
+end;\r
+\r
+\r
+function UpCas_(const a: char): char;\r
+begin\r
+\r
+ if not(case_used) then\r
+ Result:=UpCase(a)\r
+ else\r
+ Result:=a;\r
+\r
+end;\r
+\r
+\r
+function ata2int(const a: byte): byte;\r
+(*----------------------------------------------------------------------------*)\r
+(* zamiana znakow ATASCII na INTERNAL *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result:=a;\r
+\r
+ case (a and $7f) of\r
+ 0..31: inc(Result,64);\r
+ 32..95: dec(Result,32);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function IntToStr(const a: Int64): string;\r
+var tmp: _typStrINT;\r
+begin\r
+ str(a, tmp);\r
+\r
+ Result := tmp;\r
+end;\r
+\r
+\r
+function StrToInt(var a: string): Int64;\r
+var i: integer;\r
+begin\r
+ val(a,Result, i);\r
+end;\r
+\r
+\r
+procedure flush_dst;\r
+(*----------------------------------------------------------------------------*)\r
+(* oproznienie bufora zapisu *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ if buf_i>0 then blockwrite(dst,t_buf,buf_i);\r
+ buf_i:=0;\r
+end;\r
+\r
+\r
+procedure put_dst(const a: byte);\r
+(*----------------------------------------------------------------------------*)\r
+(* zapisz do bufora zapisu *)\r
+(*----------------------------------------------------------------------------*)\r
+var v: byte;\r
+begin\r
+\r
+ if fill>0 then begin\r
+\r
+ flush_dst;\r
+\r
+ v:=$ff;\r
+\r
+ while fill>0 do begin\r
+ blockwrite(dst,v,1);\r
+ dec(fill);\r
+ end;\r
+\r
+ end; \r
+ \r
+ t_buf[buf_i]:=a; inc(buf_i);\r
+ if buf_i>=sizeof(t_buf) then flush_dst;\r
+end;\r
+\r
+\r
+function Hex(a:cardinal; b:shortint): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* zamiana na zapis hexadecymalny *)\r
+(* 'B' okresla maksymalna liczbe nibbli do zamiany *)\r
+(* jesli sa jeszcze jakies wartosci to kontynuuje zamiane *)\r
+(*----------------------------------------------------------------------------*)\r
+var v: byte;\r
+\r
+const\r
+ tHex: array [0..15] of char =\r
+ ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');\r
+\r
+begin\r
+ Result:='';\r
+\r
+ while (b>0) or (a<>0) do begin\r
+\r
+ v := byte(a);\r
+ Result:=tHex[v shr 4] + tHex[v and $0f] + Result;\r
+\r
+ a:=a shr 8;\r
+\r
+ dec(b,2);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function load_mes(const b: integer): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* tworzymy STRING z komunikatem nr w 'B' *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+begin\r
+\r
+ i:=imes[b]-imes[b-1];\r
+\r
+ SetLength(Result, i);\r
+ move(mes[imes[b-1]], Result[1], i);\r
+end;\r
+\r
+\r
+function GetFilePath(var a: string): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* z pelnej nazwy pliku wycinamy sciezke (ExtractFilePath) *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+begin\r
+ Result:='';\r
+\r
+ if a<>'' then begin\r
+ i:=length(a);\r
+ while not(_pth(a[i])) and (i>=1) do dec(i);\r
+\r
+ Result:=a;\r
+ SetLength(Result,i);\r
+ end;\r
+ \r
+end;\r
+\r
+\r
+function GetFileName(var a: string): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* z pelnej nazwy pliku wycinamy nazwe pliku (ExtractFileName) *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+begin\r
+ Result:='';\r
+\r
+ if a<>'' then begin\r
+ i:=length(a);\r
+ while not(_pth(a[i])) and (i>=1) do dec(i);\r
+\r
+ Result:=copy(a,i+1,length(a));\r
+ end; \r
+\r
+end;\r
+\r
+\r
+function show_full_name(var a:string; const b,c:Boolean): string;\r
+var pth: string;\r
+begin\r
+ pth:=GetFilePath(a);\r
+\r
+ Result:=a;\r
+\r
+ if b then begin\r
+\r
+ if pth='' then Result:=path+Result;\r
+\r
+ end else\r
+ Result:=GetFileName(Result);\r
+\r
+ if c then Result:='Source: '+Result;\r
+end;\r
+\r
+\r
+procedure warning(const a: byte);\r
+(*----------------------------------------------------------------------------*)\r
+(* wyswietla ostrzezenie, nie przerywa asemblacji *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+begin\r
+\r
+ if not(noWarning) then begin\r
+\r
+ txt:=load_mes(a+1);\r
+\r
+ case a of\r
+ 8: txt:=txt+'?';\r
+ 109: txt:=txt+'$'+HEX(zpvar,4);\r
+ 69,115: txt:=txt+str_blad;\r
+ 70: txt:=txt+'$'+HEX(adres,4);\r
+ end;\r
+\r
+ warning_mes:=show_full_name(global_name,full_name,false)+' ('+IntToStr(line)+') WARNING: '+txt;\r
+\r
+ if warning_mes<>warning_old then begin\r
+ writeln(warning_mes);\r
+ warning_old:=warning_mes;\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure madH_save(var b:integer; var s:string);\r
+(*----------------------------------------------------------------------------*)\r
+(* zapisujemy plik naglowkowy MADS'a *)\r
+(*----------------------------------------------------------------------------*)\r
+var okej: Boolean;\r
+ tst: char;\r
+ i: integer;\r
+begin\r
+\r
+ tst:=s[1];\r
+\r
+ okej:=false;\r
+\r
+ for i:=High(t_mad)-1 downto 0 do\r
+ if t_mad[i].bnk=b then\r
+ if t_mad[i].typ=tst then begin okej:=true; Break end;\r
+\r
+ if okej then begin\r
+ writeln(mmm,#13#10,'; ',s);\r
+ for i:=High(t_mad)-1 downto 0 do\r
+ if t_mad[i].bnk=b then\r
+ if t_mad[i].typ=tst then writeln(mmm,t_mad[i].nam,#9,'=',#9,'$',Hex(t_mad[i].adr,4));\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure new_message(var a: string);\r
+var i: integer;\r
+begin\r
+\r
+ if a='' then exit;\r
+\r
+ i:=High(messages);\r
+\r
+ messages[i].pas:=pass;\r
+ messages[i].mes:=a;\r
+\r
+ SetLength(messages,i+2);\r
+\r
+ a:='';\r
+end;\r
+\r
+\r
+procedure koniec(const err: byte);\r
+(*----------------------------------------------------------------------------*)\r
+(* ERR = 0 bez bledow *)\r
+(* ERR = 1 tylko komunikaty WARNING *)\r
+(* ERR = 2 blad i zatrzymanie asemblacji *)\r
+(* ERR = 3 bledne parametry dla MADS'a *)\r
+(*----------------------------------------------------------------------------*)\r
+var a, b: integer;\r
+ ok: Boolean;\r
+ txt: string;\r
+ f: textfile;\r
+begin\r
+\r
+ if open_ok then begin\r
+\r
+ Flush(lst);\r
+ CloseFile(lst);\r
+\r
+ Flush_dst;\r
+\r
+ a:=integer( FileSize(dst) );\r
+ CloseFile(dst);\r
+\r
+\r
+ AssignFile(f, plik_lst); FileMode:=0; Reset(f); // sprawdzamy liczbe wierszy w 'PLIK_LST'\r
+ b:=0;\r
+ while not(eof(f)) do begin\r
+ ReadLn(f, t); inc(b);\r
+ if b>2 then Break;\r
+ end;\r
+ CloseFile(f);\r
+\r
+\r
+ if list_lab then CloseFile(lab);\r
+\r
+\r
+ if (b<3) or (err>1) then begin\r
+ Erase(lst); // usuwamy plik LST\r
+ if list_lab then Erase(lab);\r
+ end else\r
+ if (opt and 4>0) then begin\r
+ txt:=load_mes(105+1);\r
+ if not(silent) then new_message(txt);\r
+ end;\r
+\r
+\r
+ if (a=0) or (err>1) then\r
+ Erase(dst) // usuwamy plik OBX (plik DST wczesniej musi zostac zamkniety) \r
+ else begin\r
+ txt:=load_mes(106+ord(raw.use)+1);\r
+ if not(silent) then new_message(txt);\r
+ end;\r
+\r
+\r
+ if over then\r
+ if end_string<>'' then write(end_string);\r
+\r
+\r
+ if over and not(silent) then begin\r
+\r
+ if err<>2 then begin\r
+ txt:=IntToStr(line_all)+load_mes(48+1)+' in '+IntToStr(pass_end)+' pass';\r
+ new_message(txt);\r
+\r
+ if a>0 then begin\r
+ txt:=IntToStr(a)+load_mes(49+1);\r
+ new_message(txt);\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ if list_mmm then begin\r
+\r
+ b:=0;\r
+ while b<256 do begin\r
+\r
+ ok:=false;\r
+ for a:=High(t_mad)-1 downto 0 do\r
+ if t_mad[a].bnk=b then begin ok:=true; Break end;\r
+\r
+ if ok then begin\r
+\r
+ if b>0 then writeln(mmm,#13#10,' lmb #',b,#9#9,'; BANK #',b);\r
+\r
+ txt:='CONSTANS'; madH_save(b,txt); // constans\r
+ txt:='VARIABLES'; madH_save(b,txt); // variables\r
+ txt:='PROCEDURES'; madH_save(b,txt); // procedures\r
+\r
+ end;\r
+\r
+ inc(b);\r
+ end;\r
+\r
+ CloseFile(mmm);\r
+ end;\r
+\r
+ if list_hhh then begin\r
+ writeln(hhh,#13#10+'#endif');\r
+ CloseFile(hhh);\r
+ end;\r
+\r
+\r
+ for a:=0 to High(messages)-1 do\r
+ if messages[a].pas < 16 then begin\r
+\r
+ if a<>High(messages)-1 then\r
+ writeln(messages[a].mes)\r
+ else\r
+ write(messages[a].mes);\r
+ \r
+ for b:=High(messages)-1 downto 0 do // usuwamy powtarzajace sie komunikaty\r
+// if messages[b].pas=messages[a].pas then\r
+ if messages[b].mes=messages[a].mes then messages[b].pas:=$ff;\r
+\r
+ end;\r
+\r
+ if not(silent) then writeln;\r
+\r
+ Halt(err);\r
+end;\r
+\r
+\r
+function TestFile(var a: string): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy istnienie pliku na dysku bez udzialu 'SysUtils', *)\r
+(* jest to odpowiednik funkcji 'FileExists' *)\r
+(*----------------------------------------------------------------------------*)\r
+var f: textfile; // !!! koniecznie plik tekstowy !!!\r
+begin\r
+\r
+ AssignFile(f, a);\r
+// {$I-}\r
+ FileMode:=0;\r
+ Reset(f);\r
+// {$I+}\r
+\r
+ if IOResult = 0 then begin\r
+ Result:=true;\r
+ CloseFile(f);\r
+ end else\r
+ Result:=false;\r
+\r
+end;\r
+\r
+\r
+procedure just_t(const a:cardinal);\r
+var len: integer;\r
+begin\r
+\r
+ len:=length(t);\r
+\r
+ if not(len>31) then\r
+ if len+3>29 then begin\r
+ t:=t+' +';\r
+ while length(t)<32 do t:=t+' ';\r
+ end else\r
+ t:=t+' '+Hex(a,2);\r
+\r
+end;\r
+\r
+\r
+procedure bank_adres(a: integer);\r
+begin\r
+ if (dreloc.use) and (a-rel_ofs>=0) then dec(a, rel_ofs);\r
+\r
+ if bank>0 then t:=t+Hex(bank,2)+',';\r
+\r
+ {if a>=0 then} t:=t+Hex(a,4); // inaczej nie wyswietli wartosci 64bit\r
+end;\r
+\r
+\r
+procedure save_dst(const a: byte);\r
+var x, y, ex, ey: integer;\r
+ znk: char;\r
+begin\r
+\r
+ if (pass=pass_end) and (opt and 2>0) then begin\r
+\r
+ if org then begin\r
+\r
+ SetLength(t,7);\r
+\r
+ if hea and (opt and 1>0) and not(dreloc.sdx) then t:=t+'FFFF> ';\r
+\r
+ x:=adres;\r
+ y:=t_hea[hea_i];\r
+\r
+ if dreloc.use then begin\r
+ dec(x,rel_ofs);\r
+ dec(y,rel_ofs);\r
+ end;\r
+\r
+ if hea_ofs.adr>=0 then begin\r
+ y:=hea_ofs.adr+(y-x); x:=hea_ofs.adr;\r
+ end;\r
+\r
+ if x<=y then begin\r
+ ex:=x; ey:=y\r
+ end else begin\r
+ ey:=x; ex:=y\r
+ end;\r
+\r
+ if blok>0 then begin // dlugosc bloku relokowalnego\r
+ y:=y-x+1;\r
+ znk:=',';\r
+ end else\r
+ znk:='-';\r
+\r
+ if adres>=0 then begin\r
+ if ex>ey then bank_adres(t_hea[hea_i-1]+1) else bank_adres(x);\r
+ if (ex<=ey) and (opt and 1>0) then t:=t+znk+Hex(y,4)+'>';\r
+ end;\r
+\r
+ if hea and (opt and 1>0) and not(dreloc.sdx) then begin\r
+ put_dst($FF); put_dst($FF);\r
+ end;\r
+\r
+ if (opt and 1>0) then begin\r
+ put_dst( byte(x) ); put_dst( byte(x shr 8) );\r
+ put_dst( byte(y) ); put_dst( byte(y shr 8) );\r
+ end;\r
+\r
+ org:=false; hea:=false;\r
+ end;\r
+\r
+ just_t(a);\r
+\r
+ if not(blokuj_zapis) then put_dst(a);\r
+\r
+ end else begin\r
+\r
+ fill:=0; // istotne dla zapisu pliku RAW\r
+\r
+ if org and raw.use then begin\r
+ hea:=false; // istotne dla zapisu pliku RAW\r
+ org:=false; // istotne dla zapisu pliku RAW\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure save_dstW(const a: integer);\r
+begin\r
+ save_dst( byte(a) ); // lo\r
+ save_dst( byte(a shr 8) ); // hi\r
+end;\r
+\r
+\r
+procedure save_dstS(var a: string);\r
+var i, len: integer;\r
+begin\r
+ len:=length(a);\r
+\r
+ save_dstW( len );\r
+\r
+ for i:=1 to len do save_dst( ord(a[i]) );\r
+end;\r
+\r
+\r
+procedure blad(var a: string; const b: integer);\r
+(*----------------------------------------------------------------------------*)\r
+(* wyswietla komunikat bledu nr w 'B' *)\r
+(* wyjatek stanowi b<0 wtedy wyswietli komunikat 'Branch...' *)\r
+(* dla komunikatu nr 14 wyswietli nazwe wybranego trybu pracy CPU 8-16bit *)\r
+(*----------------------------------------------------------------------------*)\r
+var add, prv, con: string;\r
+begin\r
+\r
+ if b=0 then begin\r
+\r
+ overflow := true;\r
+\r
+ if pass<>pass_end then exit;\r
+ end;\r
+\r
+ \r
+ add:=''; prv:=''; con:='';\r
+\r
+ line_err := line;\r
+ \r
+ if run_macro then begin\r
+ con := t_wyw[1].zm; new_message(con);\r
+ global_name:=t_wyw[wyw_idx].pl;\r
+ inc(line_err,t_wyw[wyw_idx].nr);\r
+\r
+ end else\r
+ if not(rept_run) and not(FOX_ripit) and not(loop_used) and not(code6502) then\r
+ if line_add>0 then inc(line_err,line_add);\r
+\r
+{\r
+ if str_blad<>'' then\r
+ while (length(str_blad)>0) and (str_blad[1]='#') do str_blad:=copy(str_blad,2,length(str_blad));\r
+}\r
+\r
+\r
+// usuwamy znaki #0 bo to pewnie jakies krzaki-dziwaki\r
+ while (length(a)>0) and (pos(#0,a)>0) do SetLength(a,pos(#0,a)-1); \r
+\r
+\r
+ if (a<>'') and not(b in [18,34]) then begin con := a; new_message(con) end;\r
+\r
+ con := con+show_full_name(global_name,full_name,false)+' ('+IntToStr(Int64(line_err)+ord(line_err=0))+load_mes(81);\r
+\r
+ if b=18 then add:=' '''+a+'''';\r
+\r
+ if b=2 then prv:=load_mes(80);\r
+\r
+ if b=113 then prv:=load_mes(112+1);\r
+\r
+ \r
+ if b in [2,113] then prv:=prv+str_blad;\r
+\r
+ \r
+ if b in [5,8,9,35,41,46,61,68,73,103] then add:=add+str_blad;\r
+\r
+ if b in [2,5,35] then add:=add+load_mes(77+1+ord(dreloc.use))+IntToStr(bank)+')'; // BLOK / BANK\r
+\r
+ if b=103 then add:=add+load_mes(104+1); // ... as public\r
+\r
+ if b=14 then add:=load_mes( 82+ord( opt and 16>0 ) ); // if opt and 16>0 then add:='816)' else add:='02)';\r
+\r
+ if b=17 then\r
+ if proc then add:='P' else\r
+ if macro then add:='M';\r
+\r
+ if b<0 then\r
+ con := con+load_mes(22)+Hex(abs(b),4)+load_mes(23)\r
+ else\r
+ if b<>34 then\r
+ con := con+prv+load_mes(b+1)+add\r
+ else\r
+ con := con+a+add;\r
+\r
+\r
+ status := 2;\r
+\r
+ new_message(con);\r
+\r
+// pewne bledy wymagaja natychmiastowego zakonczenia asemblacji\r
+// jesli wystapi za duzo bledow (>512) to te¿ konczymy asemblacje\r
+ if (b in [3,8,10,12,13,15,17,18,23,24,25,28,30,34,40,41,46,57,58,62,66,73,74,76,87]) or (High(messages)>512) then begin over:=true; koniec(2) end;\r
+end;\r
+\r
+\r
+procedure justuj;\r
+var j: integer;\r
+begin\r
+\r
+ if (pass=pass_end) and (t<>'') and not(FOX_ripit) then begin\r
+\r
+ j:=length(t);\r
+\r
+ while j<32 do begin\r
+ t:=t+#9;\r
+ inc(j,8);\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure blad_und(var old: string; const b: string; const x: byte);\r
+(*----------------------------------------------------------------------------*)\r
+(* wyswietla komunikat 'Undeclared label ????' *)\r
+(* wyswietla komunikat 'Label ???? declared twice' *)\r
+(* wyswietla komunikat 'Undeclared macro ????' *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ str_blad:=b;\r
+\r
+ if x=69 then\r
+ warning(x)\r
+ else\r
+ blad(old,x);\r
+\r
+end;\r
+\r
+\r
+procedure WriteAccessFile(var a: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy mozliwosc zapisu do pliku o podanej nazwie *)\r
+(*----------------------------------------------------------------------------*)\r
+var f: textfile; // !!! koniecznie plik tekstowy !!!\r
+begin\r
+\r
+ AssignFile(f,a);\r
+// {$I-}\r
+ FileMode:=1;\r
+ Rewrite(f);\r
+// {$I+}\r
+\r
+ if IOResult = 0 then\r
+ CloseFile(f)\r
+ else\r
+ blad(a,18);\r
+\r
+end;\r
+\r
+\r
+function GetFile(a: string; var zm: string): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* szukamy pliku w zadeklarowanych sciezkach poszukiwan *)\r
+(*----------------------------------------------------------------------------*)\r
+var c, p: string;\r
+ i: integer;\r
+begin\r
+ if a='' then blad(zm,3);\r
+\r
+ p:=path+a;\r
+ if TestFile(p) then a:=path+a;\r
+\r
+ Result:=a;\r
+\r
+ if TestFile(a) then exit;\r
+\r
+ for i:=0 to High(t_pth)-1 do begin // !!! kolejnosc przegladania T_PTH[0..] ma znaczenie !!!\r
+ p:=t_pth[i];\r
+\r
+ if p<>'' then\r
+ if not(_pth(p[length(p)])) then p:=p+PathDelim;\r
+\r
+ c:=p+a;\r
+ if TestFile(c) then begin Result:=c; Break end;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure blad_ill(var a:string; const c:char);\r
+(*----------------------------------------------------------------------------*)\r
+(* wyswietla komunikat 'Illegal character ??' *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ str_blad:=c;\r
+\r
+ blad(a,8);\r
+end;\r
+\r
+\r
+function fASC(var a: string): byte;\r
+(*----------------------------------------------------------------------------*)\r
+(* !!! koniecznie obliczamy kod dla 3 pierwszych znakow !!! *)\r
+(* obliczamy sume kontrolna dla 3 literowego ciagu znakowego 'A'..'Z' *)\r
+(* obliczona suma kontrolna jest indeksem do tablicy HASH *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: cardinal;\r
+ j: integer;\r
+begin\r
+\r
+ Result:=0;\r
+\r
+ if length(a)>=3 then begin // !!! koniecznie LENGTH(A)>=3 !!! aby obliczal LDA.W itp.\r
+\r
+ for j:=1 to 3 do\r
+ if not(a[j] in ['A'..'Z']) then exit;\r
+\r
+ i:= ord(a[1])-ord('@') + (ord(a[2])-ord('@')) shl 5 + (ord(a[3])-ord('@')) shl 10;\r
+\r
+ Result:=hash[i];\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function fCRC16(var a: string): byte;\r
+(*----------------------------------------------------------------------------*)\r
+(* obliczamy sume kontrolna CRC 16-bit dla krotkiego ciagu znakowego <3..6> *)\r
+(* obliczona 16-bitowa suma kontrolna jest indeksem do tablicy HASH *)\r
+(*----------------------------------------------------------------------------*)\r
+var x, i: integer;\r
+begin\r
+ x:=$ffff;\r
+\r
+ i:=1;\r
+ while i<=length(a) do begin // WHILE jest krótsze od FOR\r
+ x:=tCRC16[byte(x shr 8) xor byte(a[i])] xor (x shl 8);\r
+ inc(i);\r
+ end;\r
+\r
+ Result:=hash[x and $ffff];\r
+end;\r
+\r
+\r
+function l_lab(var a: string): integer;\r
+(*----------------------------------------------------------------------------*)\r
+(* szukamy etykiety i zwracamy jej indeks do tablicy 'T_LAB' *)\r
+(* jesli nie ma takiej etykiety zwracamy wartosc -1 *)\r
+(*----------------------------------------------------------------------------*)\r
+var x: cardinal;\r
+ i, len: integer;\r
+begin\r
+ Result:=-1;\r
+\r
+ len:=length(a); \r
+\r
+ x:=$ffffffff;\r
+\r
+ i:=1;\r
+ while i<=len do begin // WHILE jest krótsze od FOR\r
+ x:=tCRC32[byte(x) xor byte(a[i])] xor (x shr 8);\r
+ inc(i);\r
+ end;\r
+\r
+// OK jesli znaleziona etykieta ma kod >=__id_param, lub aktualna wartosc BANK=0\r
+// OK jesli znaleziona etykieta jest z aktualnego banku lub banku zerowego (BNK=BANK | BNK=0)\r
+\r
+ for i:=High(t_lab)-1 downto 0 do\r
+ if (t_lab[i].len=len) and (t_lab[i].nam=x) then\r
+ if (bank=0) or (t_lab[i].bnk>=__id_param) then begin Result:=i; Break end else\r
+ if t_lab[i].bnk in [bank,0] then begin Result:=i; Break end;\r
+\r
+end;\r
+\r
+\r
+procedure obetnij_kropke(var b: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* usuwamy z ciagu ostatni ciag znakow po kropce, ciag konczy znak kropki *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+begin\r
+\r
+ i:=length(b);\r
+ if (b<>'') and (i>1) then begin\r
+\r
+ dec(i);\r
+ while (b[i]<>'.') and (i>=1) do dec(i);\r
+\r
+ SetLength(b,i);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function search(var a,x: string): integer;\r
+(*----------------------------------------------------------------------------*)\r
+(* szukamy nazwy etykiety w tablicy T_LAB, jesli w nazwie wystepuje kropka *)\r
+(* obcinamy nazwe i szukamy dalej *)\r
+(*----------------------------------------------------------------------------*)\r
+var b, t: string;\r
+begin\r
+ b:=x+lokal_name;\r
+\r
+ t:=b+a;\r
+ Result:=l_lab(t);\r
+\r
+ while (Result<0) and (pos('.',b)>0) do begin\r
+\r
+ obetnij_kropke(b);\r
+\r
+ t:=b+a;\r
+ Result:=l_lab(t);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function load_lab(var a:string; const test:Boolean): integer;\r
+(*----------------------------------------------------------------------------*)\r
+(* szukamy etykiety i zwracamy jej indeks do tablicy 'T_LAB' *)\r
+(* jesli nie ma takiej etykiety zwracamy wartosc -1 *)\r
+(* *)\r
+(* jesli jest uruchomione makro i nie znajdziemy etykiety to szukamy w proc *)\r
+(* jesli nie znajdziemy w proc to wtedy szukamy w glownym programie *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+ i: integer;\r
+begin\r
+\r
+ if test then begin\r
+\r
+ if run_macro then begin\r
+ Result:=search(a,macro_nr);\r
+\r
+ if Result>=0 then exit;\r
+ end;\r
+\r
+\r
+ if proc then begin\r
+ Result:=search(a,proc_name);\r
+\r
+ if Result>=0 then exit;\r
+ end;\r
+\r
+ txt:='';\r
+ Result:=search(a,txt);\r
+ if Result>=0 then exit;\r
+\r
+ end;\r
+\r
+\r
+ txt:=lokal_name+a;\r
+ Result:=l_lab(txt);\r
+\r
+ if Result<0 then Result:=search(a,proc_name); \r
+ \r
+ if Result<0 then // test dla .USE [.USING]\r
+ if usi_idx>0 then\r
+ for i:=0 to usi_idx-1 do {begin}\r
+ if ((pos(t_usi[i].nam,lokal_name)=1) or (pos(t_usi[i].nam,proc_name)=1)) or (lokal_name=t_usi[i].nam) or (proc_name=t_usi[i].nam) then begin\r
+\r
+ txt:=t_usi[i].lab+'.'+a; \r
+\r
+ Result:=l_lab(txt);\r
+\r
+ if Result>=0 then\r
+ exit\r
+ else begin\r
+ txt:=lokal_name+txt;\r
+\r
+ Result:=l_lab(txt);\r
+\r
+ if Result>=0 then exit;\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+end;\r
+\r
+\r
+procedure zapisz_etykiete(var a:string; const ad:cardinal; const ba:integer; const symbol:char);\r
+(*----------------------------------------------------------------------------*)\r
+(* zapisujemy nazwe etykiety, jej adres itp w pliku .LAB *)\r
+(* dodatkowo jesli jest to wymagane w pliku naglowkowym .C dla cc65 *)\r
+(* nie zapisujemy etykiet tymczasowych, lokalnych w makrach *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+begin\r
+\r
+ if pass=pass_end then\r
+ if not(struct.use) and not(not(mae_labels) and (symbol='?')) and not(pos('::',a)>0) then begin\r
+\r
+ if list_lab then writeln(lab,Hex(ba,2),#9,Hex(ad,4),#9,a);\r
+\r
+ if not(proc) and (ba<256) then begin\r
+ if list_hhh and (ba=0) then writeln(hhh,'#define ',name,'_',a,' 0x',Hex(ad,4));\r
+ if list_mmm then begin\r
+ i:=High(t_mad); // SAVE_MAD\r
+ //\r
+ t_mad[i].nam:=a; //\r
+ t_mad[i].adr:=ad; //\r
+ t_mad[i].bnk:=byte(ba); //\r
+ t_mad[i].typ:=label_type; //\r
+ //\r
+ SetLength(t_mad,i+2); //\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function loa_str(var a:string; var id:integer): integer;\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdz czy wystepuje deklaracja pola struktury w T_STR *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+begin\r
+\r
+ Result:=-1;\r
+\r
+ for i:=High(t_str)-1 downto 0 do // !!! koniecznie przegladamy od tylu !!!\r
+ if t_str[i].id=id then\r
+ if t_str[i].lab=a then begin Result:=i; Break end;\r
+\r
+// dzieki temu ze przegladamy od tylu nigdy nie trafimy na nazwe struktury,\r
+// nazwa struktury ma numer NO ten sam co pierwsze pole struktury\r
+end;\r
+\r
+\r
+function loa_str_no(var id:integer; const x:integer): integer;\r
+(*----------------------------------------------------------------------------*)\r
+(* odczytaj indeks do pola struktury o konkretnym numerze X *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+begin\r
+\r
+ Result:=-1;\r
+\r
+ for i:=High(t_str)-1 downto 0 do // !!! koniecznie przegladamy od tylu !!!\r
+ if t_str[i].id=id then\r
+ if t_str[i].no=x then begin Result:=i; Break end;\r
+\r
+end;\r
+\r
+\r
+procedure save_str(var a:string; const ofs,siz,rpt:integer; const ad:cardinal; const bn:integer);\r
+(*----------------------------------------------------------------------------*)\r
+(* zapisz informacje na temat pol struktury, jesli wczesniej nie wystapily *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+begin\r
+ \r
+ i:=loa_str(a, struct.id);\r
+\r
+ if i<0 then begin\r
+ i:=High(t_str);\r
+ SetLength(t_str,i+2);\r
+ end;\r
+\r
+ t_str[i].id:=struct.id;\r
+\r
+ t_str[i].no:=struct.cnt;\r
+\r
+ t_str[i].adr := ad;\r
+ t_str[i].bnk := bn;\r
+\r
+ t_str[i].lab := a;\r
+ t_str[i].ofs := ofs;\r
+ t_str[i].siz := siz;\r
+\r
+ if rpt=0 then\r
+ t_str[i].rpt := 1\r
+ else\r
+ t_str[i].rpt := rpt;\r
+ \r
+end;\r
+\r
+\r
+procedure s_lab(var a:string; const ad:cardinal; var ba:integer; var old:string; const symbol:char);\r
+(*----------------------------------------------------------------------------*)\r
+(* wlasciwa procedura realizujaca zapamietanie etykiety w tablicy 'T_LAB' *)\r
+(*----------------------------------------------------------------------------*)\r
+var tmp: cardinal;\r
+ x, len, i: integer;\r
+begin\r
+// sprawdz czy nie ma juz takiej etykiety\r
+// bo jesli jest to nie dopisuj nowej pozycji tylko popraw stara\r
+ x:=l_lab(a);\r
+\r
+ if x<0 then begin\r
+ x:=High(t_lab);\r
+ SetLength(t_lab,x+2);\r
+ end else\r
+ if symbol<>'?' then\r
+ if (t_lab[x].bnk<>ba) and not(struct_used.use) and not(enum.use) then blad_und(old,a,2);\r
+\r
+ len:=length(a);\r
+\r
+ tmp:=$ffffffff; // crc32\r
+\r
+ i:=1;\r
+ while i<=len do begin // WHILE jest krótsze od FOR\r
+ tmp:=tCRC32[byte(tmp) xor byte(a[i])] xor (tmp shr 8);\r
+ inc(i);\r
+ end;\r
+\r
+ if pass>0 then\r
+ if (symbol<>'?') or mae_labels then // jesli to styl etykiet MAE to musimy je sprawdzic\r
+ if t_lab[x].nam=tmp then // normalnie sprawdzamy tylko etykiety z pierwszym znakiem <>'?'\r
+ if (t_lab[x].bnk<__id_param) and not(t_lab[x].lid) then begin\r
+\r
+ if t_lab[x].pas=pass then blad_und(old,a,2); // nie mozna sprawdzac dwa razy tej samej etykiety w aktualnym przebiegu\r
+\r
+ if not(next_pass) then // sprawdz czy potrzebny jest dodatkowy przebieg\r
+ if mne_used then // jakis mnemonik musial zostac wczesniej wykonany\r
+ next_pass := (t_lab[x].adr <> ad);\r
+\r
+ end;\r
+\r
+\r
+ if (pass=pass_end) and unused_label and (ba<__id_param) and not(struct.use) and not(run_macro) and not(t_lab[x].use) then begin\r
+ str_blad:=a;\r
+ warning(115);\r
+ end;\r
+\r
+\r
+ if t_lab[x].lid and not(new_local) then blad_und(old,a,2);\r
+ \r
+ t_lab[x].lid := new_local;\r
+\r
+ t_lab[x].typ := label_type;\r
+\r
+ t_lab[x].len := len;\r
+\r
+ t_lab[x].nam := tmp;\r
+\r
+ if new_local then begin\r
+ if t_lab[x].pas<>pass then t_lab[x].adr := ad; // tylko pierwszy adres dla .LOCAL\r
+ end else\r
+ t_lab[x].adr := ad;\r
+ \r
+ t_lab[x].bnk := ba;\r
+ t_lab[x].blk := blok;\r
+\r
+ t_lab[x].pas := pass;\r
+\r
+ t_lab[x].ofs := org_ofset;\r
+\r
+ if (blok>0) or dreloc.use then t_lab[x].rel := true;\r
+\r
+ zapisz_etykiete(a,ad,ba,symbol);\r
+end;\r
+\r
+\r
+procedure save_lab(var a:string; const ad:cardinal; ba:integer; var old:string);\r
+(*----------------------------------------------------------------------------*)\r
+(* zapamietujemy etykiete, adres, bank *)\r
+(*----------------------------------------------------------------------------*)\r
+var tmp: string;\r
+begin\r
+\r
+ if a<>'' then begin // !!! konieczny test\r
+\r
+ if mae_labels and (a[1]<>'?') then begin\r
+\r
+ tmp:=a;\r
+ lokal_name:=a+'.';\r
+\r
+ end else\r
+ if run_macro then tmp:=macro_nr+lokal_name+a else // !!! nie remowac LOKAL_NAME !!!\r
+ if proc then tmp:=proc_name+lokal_name+a else\r
+ tmp:=lokal_name+a;\r
+\r
+ s_lab( tmp, ad, ba, old, a[1] );\r
+\r
+ end;\r
+ \r
+end;\r
+\r
+\r
+procedure save_arr(const a:cardinal; var b:integer);\r
+begin\r
+\r
+ t_arr[array_idx].adr:=a;\r
+ t_arr[array_idx].bnk:=b;\r
+\r
+ t_arr[array_idx].ofs:=org_ofset;\r
+\r
+ inc(array_idx);\r
+\r
+ if array_idx>High(t_arr) then SetLength(t_arr, array_idx+1);\r
+\r
+end;\r
+\r
+\r
+procedure save_hea;\r
+begin\r
+ t_hea[hea_i]:=adres-1 - fill;\r
+\r
+ fill:=0;\r
+ \r
+ inc(hea_i);\r
+ \r
+ if hea_i>High(t_hea) then SetLength(t_hea,hea_i+1);\r
+end;\r
+\r
+\r
+procedure save_par(var a: string);\r
+var i: integer;\r
+begin\r
+ i:=High(t_par);\r
+\r
+ t_par[i]:=a;\r
+\r
+ SetLength(t_par,i+2);\r
+end;\r
+\r
+\r
+procedure save_mac(var a: string);\r
+var i: integer;\r
+begin\r
+ i:=High(t_mac);\r
+\r
+ t_mac[i]:=a; \r
+\r
+ SetLength(t_mac,i+2);\r
+end;\r
+\r
+\r
+procedure save_end(const a: byte);\r
+begin\r
+ t_end[end_idx].kod := a;\r
+ t_end[end_idx].adr := adres;\r
+\r
+ t_end[end_idx].sem := false; // semicolon {\r
+\r
+ inc(end_idx);\r
+\r
+ if end_idx>High(t_end) then SetLength(t_end, end_idx+1);\r
+end;\r
+\r
+\r
+procedure dec_end(var zm: string; const a: byte);\r
+begin\r
+ dec(end_idx);\r
+\r
+ if t_end[end_idx].kod <> a then\r
+ case a of\r
+ __endpg: blad(zm,64); // Missing .PAGES\r
+ __ends: blad(zm,55); // Missing .STRUCT\r
+ __endm: blad(zm,97); // Missing .MACRO\r
+ __endw: blad(zm,88); // Missing .WHILE\r
+ __endt: blad(zm,95); // Missing .TEST\r
+ __enda: blad(zm,59); // Missing .ARRAY\r
+ __endr: blad(zm,51); // Missing .REPT\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure save_pub(var a,zm: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* zapisujemy symbol .PUBLIC *)\r
+(* jesli ADD = FALSE to w przypadku powtorzenia symbolu wystapi blad *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+begin\r
+\r
+ for i:=pub_idx-1 downto 0 do // symbole public nie moga sie powtarzac\r
+ if t_pub[i].nam=a then blad_und(zm,a,2);\r
+\r
+ t_pub[pub_idx].nam := a;\r
+\r
+ inc(pub_idx);\r
+\r
+ if pub_idx>High(t_pub) then SetLength(t_pub,pub_idx+1);\r
+end;\r
+\r
+\r
+procedure save_rel(var a:integer; const idx, b:integer; var reloc_value:relVal);\r
+begin\r
+\r
+if dreloc.use or dreloc.sdx then begin\r
+\r
+ if vector then t_rel[rel_idx].adr:=a-rel_ofs else t_rel[rel_idx].adr:=a-rel_ofs+1;\r
+\r
+ t_rel[rel_idx].blk:=b;\r
+ if not(empty) then t_rel[rel_idx].idx:=idx else t_rel[rel_idx].idx:=-100;\r
+ t_rel[rel_idx].blo:=blok;\r
+\r
+ if dreloc.use then begin\r
+ t_rel[rel_idx].idx:=siz_idx;\r
+ t_rel[rel_idx].bnk:=bank;\r
+\r
+ inc(siz_idx);\r
+\r
+ rel_used:=true; // pozwalamy na zapis rozmiaru do T_SIZ\r
+\r
+ if siz_idx>High(t_siz) then SetLength(t_siz,siz_idx+1);\r
+ end;\r
+\r
+ inc(rel_idx);\r
+\r
+ if rel_idx>High(t_rel) then SetLength(t_rel,rel_idx+1);\r
+\r
+ reloc:=true;\r
+\r
+ reloc_value.use:=true;\r
+\r
+ inc(reloc_value.cnt);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure save_relAddress(const arg:integer; var reloc_value: relVal);\r
+begin\r
+\r
+ if not(branch) then\r
+ if t_lab[arg].rel then begin\r
+ save_rel(adres, -1, t_lab[arg].blk, reloc_value);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function wartosc(var a:string; var v:Int64; const o:char): cardinal;\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy zakres wartosci zmiennej 'V' na podstawie kodu w 'O' *)\r
+(*----------------------------------------------------------------------------*)\r
+var x: Boolean;\r
+ i: int64;\r
+begin\r
+ Result:=cardinal( v );\r
+\r
+ i:=abs(v); // koniecznie ABS inaczej nie zadziala prawidlowo\r
+\r
+ case o of\r
+ 'B' : x := i > $FF;\r
+ 'A','V' : x := i > $FFFF;\r
+ 'E','T' : x := i > $FFFFFF;\r
+// 'F','G','L','H' : x := i > $FFFFFFFF; // !!! nie realne !!! zaremowac aby dzialalo odejmowanie\r
+ else\r
+ x:=false;\r
+ end;\r
+\r
+ if x then blad(a,0);\r
+ \r
+end;\r
+\r
+\r
+function _ope(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* dopuszczalne operandy *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (a in ['=','<','>','!'])\r
+end;\r
+\r
+\r
+function _eol(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* test konca linii *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (a in [#0,#9,' '])\r
+end;\r
+\r
+\r
+function _dec(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* dopuszczalne znaki dla liczb decymalnych *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (a in ['0'..'9'])\r
+end;\r
+\r
+\r
+function _lab(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* dopuszczalne znaki dla etykiet *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (UpCase(a) in ['A'..'Z','0'..'9','_','?','@','.'])\r
+end;\r
+\r
+\r
+function _bin(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* dopuszczalne znaki dla liczb binarnych *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (a in ['0'..'1'])\r
+end;\r
+\r
+\r
+function _hex(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* dopuszczalne znaki dla liczb heksadecymalnych *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (UpCase(a) in ['0'..'9','A'..'F'])\r
+end;\r
+\r
+\r
+function _first_char(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* pierwsze dopuszczalne znaki dla linii *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (UpCase(a) in ['A'..'Z','_','?','@','.','+','-','=','*',':'])\r
+end;\r
+\r
+\r
+function _dir_first(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* pierwsze dopuszczalne znaki dla dyrektyw *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (a in ['.','#'])\r
+end;\r
+\r
+\r
+function _lab_first(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* pierwsze dopuszczalne znaki dla etykiet *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (UpCase(a) in ['A'..'Z','_','?','@'])\r
+end;\r
+\r
+\r
+function _lab_firstEx(var a: char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* pierwsze dopuszczalne znaki dla etykiet w wyrazeniach *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := (UpCase(a) in ['A'..'Z','_','?','@',':'])\r
+end;\r
+\r
+\r
+function test_char(i:integer; var a:string; const sep,sep2:Char): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* test konca linii, linie moga konczyc znaki #0, #9, ' ', ';', '//','/*','\' *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+begin\r
+\r
+ if a='' then begin Result:=false; exit end; \r
+\r
+ if (a[i]='/') and (a[i+1]='*') then begin // !!! omin_spacje !!! tutaj niemozliwe\r
+\r
+ txt:=''; ___search_comment_block(i,a, txt);\r
+ \r
+{ inc(i,2);\r
+ while i<=length(a) do begin\r
+\r
+ if a[i]='*' then\r
+ if a[i+1]='/' then begin\r
+\r
+ inc(i);\r
+ if i=length(a) then begin\r
+ Result:=true;\r
+ exit\r
+ end else begin\r
+ __inc(i,a);\r
+ Break\r
+ end;\r
+\r
+ end;\r
+\r
+ __inc(i,a);\r
+ end;}\r
+\r
+ end;\r
+\r
+ Result := (a[i] in [#0,#9,'\',';',sep,sep2]) or ((a[i]='/') and (a[i+1] in ['/'{,'*'}]));\r
+end;\r
+\r
+\r
+procedure test_eol(const i:integer; var a,old:string; const b:char);\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy czy nie ma niepoprawnych znakow na koncu linii *)\r
+(* linia moze konczyc sie znakami #0,#9,';',' ','//' lub przecinkiem ',' *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ if not(a[i] in [#0,#9,'\',';',' ',b]) and not((a[i]='/') and (a[i+1] in ['/','*'])) then blad(old,4)\r
+end;\r
+\r
+\r
+function get_directive(var i:integer; var a:string): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* pobierz dyrektywe zaczynajaca sie znakami '.', '#' *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result:='';\r
+\r
+ if _dir_first(a[i]) then begin\r
+ Result:=a[i];\r
+ inc(i);\r
+\r
+ while _lab(a[i]) do begin Result:=Result+UpCase(a[i]); inc(i) end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function get_lab(var i:integer; var a:string; const tst:Boolean): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* pobierz etykiete zaczynajaca sie znakami 'A'..'Z','_','?','@' *)\r
+(* jesli TST = TRUE to etykieta musi zawierac jakies znaki *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result:='';\r
+\r
+ if a<>'' then begin\r
+\r
+ if tst then omin_spacje(i,a);\r
+\r
+ if _lab_first(a[i]) then\r
+ while _lab(a[i]) do begin Result:=Result+UpCas_(a[i]); inc(i) end;\r
+\r
+ end;\r
+\r
+ if tst then\r
+ if Result='' then blad(a,15);\r
+end;\r
+\r
+\r
+function get_string(var i:integer; var a,old:string; const test:Boolean): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* pobiera ciag znakow, ograniczony znakami '' lub "" *)\r
+(* podwojny '' oznacza literalne ' *)\r
+(* podwojny "" oznacza literalne " *)\r
+(* TEST = TRUE sprawdza czy ciag jest pusty *)\r
+(*----------------------------------------------------------------------------*)\r
+var len: integer;\r
+ znak, gchr: char;\r
+begin\r
+ Result:='';\r
+\r
+ omin_spacje(i,a);\r
+ if not(a[i] in ['''','"']) then exit;\r
+\r
+ gchr:=a[i]; len:=length(a);\r
+\r
+ while i<=len do begin\r
+ inc(i); // omijamy pierwszy znak ' lub "\r
+\r
+ znak:=a[i];\r
+\r
+ if znak=gchr then begin\r
+ inc(i);\r
+ if a[i]=gchr then znak:=gchr else begin\r
+ if test then if Result='' then blad(old,3);\r
+ exit;\r
+ end;\r
+ end;\r
+\r
+ Result:=Result+znak;\r
+ end;\r
+\r
+ if not(komentarz) then blad(a,3); // nie napotkal znaku konczacego ciag ' lub "\r
+end;\r
+\r
+\r
+function get_datUp(var i:integer; var a:string; const sep:Char; const tst:Boolean): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* pobieramy ciag znakow (dyrektywy), zmieniamy wielkosc liter na duze *)\r
+(* jeli TST = TRUE to ciag musi byc niepusty *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result:='';\r
+\r
+ omin_spacje(i,a);\r
+\r
+ if a<>'' then\r
+ while (a[i]<>'=') and not(test_char(i,a,' ',sep)) do begin\r
+ Result := Result + UpCase(a[i]);\r
+ inc(i);\r
+ end;\r
+\r
+ if tst then\r
+ if Result='' then blad(a,23);\r
+\r
+end;\r
+\r
+\r
+function get_type(var i:integer; var zm,old: string; const tst:Boolean): byte;\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy czy odczytany ciag znakow oznacza dyrektywe typu danych *)\r
+(* akceptowane dyrektywy typu to .BYTE, .WORD, .LONG, .DWORD *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+begin\r
+ omin_spacje(i,zm);\r
+\r
+// txt:=get_datUp(i,zm,#0,false);\r
+ txt:=get_directive(i,zm);\r
+\r
+ if (txt='') and not(tst) then begin Result:=0; exit end; // wyjatek dla .RELOC [.BYTE] [.WORD]\r
+\r
+ Result := fCRC16(txt);\r
+\r
+ if not(Result in [__byte..__dword]) then blad_und(old,txt,46);\r
+\r
+ dec(Result, __byteValue);\r
+end;\r
+\r
+\r
+function get_typeExt(var i:integer; var zm:string): byte;\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy czy odczytany ciag znakow oznacza dyrektywe typu danych dla EXT *)\r
+(* akceptowane dyrektywy typu to .BYTE, .WORD, .LONG, .DWORD, .PROC *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+begin\r
+ omin_spacje(i,zm);\r
+\r
+// txt:=get_datUp(i,zm,'(',false);\r
+ txt:=get_directive(i,zm);\r
+\r
+ Result := fCRC16(txt);\r
+\r
+ if not(Result in [__byte..__dword, __proc]) then blad_und(zm,txt,46);\r
+end;\r
+\r
+\r
+function ciag_ograniczony(var i:integer; var a:string; const cut:Boolean): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* pobiera ciag ograniczony dwoma znakami 'LEWA' i 'PRAWA' *)\r
+(* znaki 'LEWA' i 'PRAWA' moga byc zagniezdzone *)\r
+(* jesli CUT = TRUE to usuwamy poczatkowy i koncowy nawias *)\r
+(*----------------------------------------------------------------------------*)\r
+var nawias, len: integer;\r
+ znak, lewa, prawa: char;\r
+ petla: Boolean;\r
+begin\r
+ Result:='';\r
+\r
+ if not(a[i] in ['[','(','{']) then exit;\r
+\r
+ lewa:=a[i];\r
+ if lewa='(' then prawa:=')' else prawa:=chr(ord(lewa)+2);\r
+\r
+ nawias:=0; petla:=true; len:=length(a);\r
+\r
+ while petla and (i<=len) do begin\r
+\r
+ znak := a[i];\r
+\r
+ if znak=lewa then inc(nawias) else\r
+ if znak=prawa then dec(nawias);\r
+\r
+// if not(zag) then\r
+// if nawias>1 then test_nawias(a,lewa,0);\r
+\r
+// if nawias=0 then petla:=false;\r
+ petla := not(nawias=0);\r
+\r
+ if znak='\' then begin\r
+ petla:=false;\r
+ Break;\r
+ end else\r
+ \r
+ if znak in ['''','"'] then begin\r
+ Result := Result + znak + get_string(i,a,a,false) + znak\r
+ end else begin\r
+ Result := Result + UpCas_(znak);\r
+ inc(i)\r
+ end;\r
+ \r
+ end;\r
+\r
+\r
+ if petla and not(komentarz) then\r
+ case lewa of\r
+ '[': blad(a,6);\r
+ '(': blad(a,7);\r
+ '{': blad(a,20);\r
+ end;\r
+\r
+ if cut then\r
+ if Result<>'' then Result:=copy(Result,2,length(Result)-2);\r
+end;\r
+\r
+\r
+function test_param(var i:integer; var a:string): Boolean;\r
+(*----------------------------------------------------------------------------*)\r
+(* test na obecnosc parametrow makra, czyli ':0..9', '%%0..9' *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result := ((a[i]=':') and _dec(a[i+1])) or ((a[i]='%') and (a[i+1]='%') and _dec(a[i+2]))\r
+end;\r
+\r
+\r
+function get_dat(var i:integer; var a:string; const Sep:Char; const spacja:Boolean): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* wczytaj dowolne znaki, oprocz spacji, tabulatora i 'Sep' *)\r
+(* jesli wystepuja znaki otwierajace ciag, czytaj taki ciag *)\r
+(*----------------------------------------------------------------------------*)\r
+var znak: char;\r
+ len: integer;\r
+begin\r
+ Result:='';\r
+\r
+ len:=length(a);\r
+\r
+ while i<=len do\r
+\r
+ if a[i]=Sep then\r
+ exit\r
+ else\r
+\r
+ case UpCase(a[i]) of\r
+ '[','(','{':\r
+ if not(komentarz) then\r
+ Result:=Result + ciag_ograniczony(i,a,false)\r
+ else begin\r
+ Result:=Result+a[i];\r
+ inc(i);\r
+ end;\r
+\r
+ 'A'..'Z': Result:=Result + get_lab(i,a, false);\r
+\r
+ '''','"':\r
+ if not(komentarz) then begin\r
+ znak:=a[i];\r
+ Result:=Result + znak + get_string(i,a,a,false) + znak;\r
+ end else begin\r
+ Result:=Result+a[i];\r
+ inc(i);\r
+ end;\r
+\r
+ '/': case a[i+1] of\r
+ '/': exit;\r
+ '*': begin ___search_comment_block(i,a, Result); if komentarz then exit end;\r
+ else\r
+ begin\r
+ Result:=Result+'/';\r
+ inc(i);\r
+ end;\r
+ end;\r
+\r
+ ';','\': exit;\r
+\r
+ ' ',#9: if spacja then exit else begin Result:=Result+a[i]; inc(i) end;\r
+\r
+ else\r
+ begin\r
+// if a[i]=Sep then exit;\r
+ Result := Result + UpCas_(a[i]);\r
+ inc(i);\r
+ end;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function get_dat_noSPC(var i:integer; var a:string; const sep,sep2:Char; var old:string): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* wczytujemy ciag znakow pomijajac znaki spacji *)\r
+(*----------------------------------------------------------------------------*)\r
+var len: integer;\r
+begin\r
+ Result:='';\r
+\r
+ omin_spacje(i,a);\r
+\r
+ len:=length(a);\r
+\r
+ while i<=len do begin\r
+\r
+ case a[i] of\r
+ ' ',#9:\r
+ if sep=' ' then exit else __inc(i,a);\r
+\r
+ '.','$','%':\r
+ if a[i]=sep then exit else begin\r
+ if (test_char(i+1,a,' ',#0)) and not(komentarz) then blad(old,4);\r
+ Result:=Result+a[i]; __inc(i,a);\r
+ end;\r
+\r
+ '/': case a[i+1] of\r
+ '/': exit;\r
+ '*': begin ___search_comment_block(i,a, Result); if komentarz then exit end;\r
+ else\r
+ begin\r
+ Result:=Result+'/';\r
+ __inc(i,a);\r
+ end;\r
+ end;\r
+\r
+ ';','\': exit;\r
+\r
+ else\r
+\r
+ if a[i] in [sep,sep2] then\r
+ exit\r
+ else\r
+ Result := Result + get_dat(i,a,sep,true);\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function OperExt(var i:integer; var old:string; const a,b:char; var value:Boolean): char;\r
+(*----------------------------------------------------------------------------*)\r
+(* operatory zlozone zamieniamy na odpowiedni jednoliterowy kod *)\r
+(*----------------------------------------------------------------------------*)\r
+var x: integer;\r
+begin\r
+ Result:=' ';\r
+\r
+ x:=ord(a) shl 8+ord(b);\r
+\r
+ case x of\r
+ 15422,8509: Result := 'A'; // '<>', '!='\r
+ 15421: Result := 'B'; // '<='\r
+ 15933: Result := 'C'; // '>='\r
+ 15420: Result := 'D'; // '<<'\r
+ 15934: Result := 'E'; // '>>'\r
+ 15677: Result := '='; // '=='\r
+ 9766: Result := 'F'; // '&&'\r
+ 31868: Result := 'G'; // '||'\r
+ end;\r
+\r
+ if not(value) or (Result=' ') then begin\r
+ str_blad:=a+b;\r
+ blad(old,8);\r
+ end;\r
+\r
+ inc(i,2); value:=false;\r
+end;\r
+\r
+\r
+function OperNew(var i:integer; var old:string; const a:char; var value:Boolean; const b:Boolean): char;\r
+begin\r
+ if value<>b then blad_ill(old,a);\r
+\r
+ Result:=a;\r
+\r
+ inc(i); value:=false;\r
+end;\r
+\r
+\r
+function test_string(var i:integer; var a:string; const typ:Char): integer;\r
+(*----------------------------------------------------------------------------*)\r
+(* obliczamy wartosc ktora zmodyfikuje ciag znakowy lub plikowy *)\r
+(* dla '*' jest to wartosc 128, czyli invers *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Result:=0; // wynik jest typem ze znakiem, koniecznie !!!\r
+\r
+ omin_spacje(i,a);\r
+\r
+ case a[i] of\r
+ '*': begin\r
+ Result := 128;\r
+ inc(i);\r
+ end;\r
+\r
+ '+','-': Result := integer( ___wartosc_noSPC(a,a,i,',',typ) );\r
+ end;\r
+\r
+ omin_spacje(i,a);\r
+end;\r
+\r
+\r
+procedure subrange_bounds(var a:string; const v,y:integer);\r
+begin\r
+ if (v<0) or (v>y) then blad(a,62);\r
+end;\r
+\r
+\r
+procedure save_dtaS(war:cardinal; ile:integer);\r
+begin\r
+\r
+ while ile>0 do begin\r
+\r
+ save_dst( byte(war) );\r
+\r
+ war:=war shr 8;\r
+\r
+ inc(adres);\r
+ dec(ile);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure save_dta(const war:cardinal; var tmp:string; const op_:char; const invers:byte);\r
+(*----------------------------------------------------------------------------*)\r
+(* zapisujemy bajty danych do .ARRAY w zaleznosci od ustawionego typu danych *)\r
+(*----------------------------------------------------------------------------*)\r
+var k, i: integer;\r
+ v: byte;\r
+begin\r
+\r
+ if aray or put_used then\r
+ if array_used.idx>$FFFF then exit else begin\r
+\r
+ if op_ in ['C','D'] then begin\r
+ i:=length(tmp);\r
+\r
+ for k:=1 to i do begin\r
+ v:=byte( ord(tmp[k])+invers );\r
+ if op_='D' then v:=ata2int(v);\r
+\r
+ {if not(loop_used) and not(FOX_ripit) then} just_t(v);\r
+\r
+ if aray then\r
+ t_tmp[array_used.idx]:=v\r
+ else\r
+ t_get[array_used.idx]:=v;\r
+\r
+ inc(array_used.idx);\r
+\r
+ if array_used.idx>array_used.max then array_used.max:=array_used.idx;\r
+ end;\r
+\r
+ exit;\r
+ end;\r
+\r
+ {if not(loop_used) and not(FOX_ripit) then} just_t(war);\r
+\r
+ if aray then\r
+ t_tmp[array_used.idx]:=cardinal(war)\r
+ else\r
+ t_get[array_used.idx]:=byte(war);\r
+\r
+ inc(array_used.idx);\r
+\r
+ if array_used.idx>array_used.max then array_used.max:=array_used.idx;\r
+\r
+ exit;\r
+ end;\r
+\r
+\r
+ case op_ of\r
+ 'L','B':\r
+ begin\r
+ save_dst( byte(war) ); inc(adres);\r
+ end;\r
+\r
+ 'H': begin\r
+ save_dst( byte(war shr 8) ); inc(adres);\r
+ end;\r
+\r
+ 'A','V':\r
+ begin\r
+ save_dst( byte(war) );\r
+ save_dst( byte(war shr 8) ); inc(adres,2);\r
+ end;\r
+\r
+ 'T','E':\r
+ begin\r
+ save_dst( byte(war) );\r
+ save_dst( byte(war shr 8) );\r
+ save_dst( byte(war shr 16) ); inc(adres,3);\r
+ end;\r
+\r
+ 'F': begin\r
+ save_dst( byte(war) );\r
+ save_dst( byte(war shr 8) );\r
+ save_dst( byte(war shr 16) );\r
+ save_dst( byte(war shr 24) ); inc(adres,4);\r
+ end;\r
+\r
+ 'G': begin\r
+ save_dst( byte(war shr 24) );\r
+ save_dst( byte(war shr 16) );\r
+ save_dst( byte(war shr 8) );\r
+ save_dst( byte(war) ); inc(adres,4);\r
+ end;\r
+\r
+ 'C','D':\r
+ begin\r
+ i:=length(tmp);\r
+\r
+ for k:=1 to i do begin\r
+ v:=byte( ord(tmp[k])+invers );\r
+ if op_='D' then v:=ata2int(v);\r
+ save_dst(v);\r
+ end;\r
+ inc(adres,i);\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function oblicz_wartosc_ogr(var zm,old:string; var i:integer): Int64;\r
+(*----------------------------------------------------------------------------*)\r
+(* obliczamy wartosc ograniczona nawiasami '[' lub '(' *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+ k: integer;\r
+begin\r
+ Result:=0;\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if zm[i] in ['[','('] then begin\r
+ txt:=ciag_ograniczony(i,zm,true);\r
+\r
+ k:=1;\r
+ Result:=___wartosc_noSPC(txt,old,k,#0,'F')\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function get_labelEx(var i:integer; var a:string): string;\r
+begin\r
+ Result:='';\r
+\r
+ if _lab_firstEx(a[i]) then begin\r
+\r
+ Result:=Result+UpCas_(a[i]);\r
+ inc(i);\r
+\r
+ while _lab(a[i]) do begin Result:=Result+UpCas_(a[i]); inc(i) end;\r
+\r
+ end;\r
+\r
+ //if not( _eol(a[i]) ) then blad_ill(old,a[i]); // z tym testem nie policzy ciagu wyr|wyr \r
+end;\r
+\r
+\r
+function get_labEx(var i:integer; var a,old:string): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* pobierz etykiete zaczynajaca sie znakami 'A'..'Z','_','?','@',':' *)\r
+(* jesli wystepuja nawiasy '( )' lub '[ ]' to usuwamy je *)\r
+(*----------------------------------------------------------------------------*)\r
+var tmp: string;\r
+ k: integer;\r
+begin\r
+\r
+ omin_spacje(i,a);\r
+\r
+ if a[i] in ['(','['] then begin\r
+ tmp := ciag_ograniczony(i,a,true);\r
+\r
+ k:=1;\r
+ omin_spacje(k,tmp);\r
+\r
+ Result := get_labelEx(k, tmp);\r
+ end else\r
+ Result := get_labelEx(i, a);\r
+\r
+ if Result='' then blad(old,15);\r
+\r
+end;\r
+\r
+\r
+function load_label_ofset(a:string; var old:string; const test:Boolean): integer;\r
+(*----------------------------------------------------------------------------*)\r
+(* znajdujemy indeks do tablicy T_LAB *)\r
+(*----------------------------------------------------------------------------*)\r
+var b: integer;\r
+begin\r
+\r
+ if a='' then blad(old,23);\r
+\r
+ if a[1]=':' then begin\r
+ b := bank;\r
+ bank := 0; // wymuszamy BANK=0 aby odczytac etykiete z najnizszego poziomu\r
+\r
+ a:=copy(a,2,length(a));\r
+ Result:=l_lab(a);\r
+\r
+ bank := b; // przywracamy poprzednia wartosc BANK\r
+ end else\r
+ Result:=load_lab(a,true);\r
+\r
+ if test then\r
+ if (Result<0) and (pass=pass_end) then blad_und(old,a,5);\r
+\r
+end;\r
+\r
+\r
+procedure testRange(var old:string; var i:integer; const b:byte);\r
+begin\r
+ if (i<0) or (i>$FFFF) then begin\r
+ blad(old,b);\r
+ i:=0;\r
+ end;\r
+end;\r
+\r
+\r
+function read_HEX(var i:integer; var a,old: string): string;\r
+begin\r
+ inc(i); // omin pierwszy znak '$'\r
+\r
+ Result:='';\r
+ while _hex(a[i]) do begin Result:=Result+UpCase(a[i]); inc(i) end;\r
+\r
+ if not(test_param(i,a)) then\r
+ if Result='' then blad_ill(old,a[i]);\r
+\r
+ Result:='$'+Result;\r
+end;\r
+\r
+\r
+procedure save_lst(const c:char);\r
+(*----------------------------------------------------------------------------*)\r
+(* formatowanie wierszy listingu przed zapisaniem ich do pliku .LST *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: byte;\r
+begin\r
+\r
+ if pass=pass_end then begin\r
+\r
+ if not(loop_used) and not(FOX_ripit) then begin\r
+ t:=IntToStr(line);\r
+ while length(t)<6 do t:=' '+t;\r
+ t:=t+' ';\r
+ end;\r
+\r
+\r
+ case c of\r
+\r
+ 'l': if not(FOX_ripit) then begin t:=t+'= '; bank_adres(nul.i) end;\r
+\r
+ 'i': bank_adres(adres);\r
+\r
+ 'a': begin\r
+\r
+ if not(hea) and not(loop_used) and not(FOX_ripit) and\r
+ not(struct.use) and (adres>=0) then bank_adres(adres);\r
+\r
+ if nul.l>0 then begin\r
+ data_out:=true;\r
+ for i:=0 to nul.l-1 do save_dst(nul.h[i]);\r
+ end;\r
+\r
+ end;\r
+\r
+ end; // end case\r
+\r
+ end;\r
+\r
+ inc(adres,nul.l); // to zawsze musi sie wykonac niezaleznie od przebiegu\r
+end;\r
+\r
+\r
+procedure zapisz_lokal;\r
+begin\r
+ t_loc[lokal_nr].nam := lokal_name;\r
+\r
+ inc(lokal_nr);\r
+\r
+ if lokal_nr>High(t_loc) then SetLength(t_loc,lokal_nr+1);\r
+end;\r
+\r
+\r
+procedure oddaj_lokal(var a: string);\r
+begin\r
+ if lokal_nr=0 then blad(a,28);\r
+ dec(lokal_nr);\r
+\r
+ lokal_name := t_loc[lokal_nr].nam;\r
+end;\r
+\r
+\r
+procedure new_DOS_header;\r
+var old_opt: byte;\r
+begin\r
+ old_opt:=opt;\r
+\r
+ opt:=opt or 1; // wymuszamy zapis naglowka DOS-a\r
+ save_hea; org:=true;\r
+\r
+ opt:=old_opt;\r
+end;\r
+\r
+\r
+function oblicz_wartosc(var a:string; var old:string): Int64;\r
+(*----------------------------------------------------------------------------*)\r
+(* obliczamy wartosc wyrazenia, uwzgledniajac operacje arytmetyczne *)\r
+(* w 'J' jest licznik dla STOS'u *)\r
+(* zamiast tablic dynamicznych wprowadzilem tablice statyczne i ograniczylem *)\r
+(* maksymalna liczbe operacji i operatorow w wyrazeniu do 512 *)\r
+(*----------------------------------------------------------------------------*)\r
+type znak_wart = record\r
+ znak: char;\r
+ wart: Int64;\r
+ end;\r
+\r
+ _typCash = array [0..16] of char; // taka sama liczba elementow jak PRIOR\r
+ _typOper = array [0..511] of char;\r
+ _typStos = array [0..511] of znak_wart;\r
+\r
+\r
+var i, j, b, x, k, v, pomoc, ofset, _hlp, len, op_idx, arg: integer;\r
+ old_reloc_value_cnt: integer;\r
+ tmp, txt: string;\r
+ iarg, war: Int64;\r
+ petla, value, old_reloc_value_use: Boolean;\r
+ oper, byt: char;\r
+\r
+ fsize: file;\r
+\r
+ reloc_value: relVal;\r
+\r
+ stos_: _carArray;\r
+ cash : _typCash;\r
+ stos : _typStos;\r
+ op : _typOper;\r
+\r
+const\r
+ prior: array [0..16] of char= // piorytet operatorow\r
+ ('D','E','&','|','^','/','*','%','+',{'-',}'=','A','B','<','C','>','F','G');\r
+\r
+begin\r
+\r
+ if a='' then blad(old,23); \r
+ \r
+ Result:=0;\r
+\r
+ // init tablicy dynamicznej OP\r
+// SetLength(op,2);\r
+ op[0]:='+'; oper:='+'; op_idx:=1;\r
+\r
+ i:=1; war:=0; b:=0;\r
+\r
+// fillchar(cash,sizeof(cash),' '); // wypelniamy spacjami\r
+\r
+ cash[0]:=' ';\r
+ cash[1]:=' ';\r
+ cash[2]:=' ';\r
+ cash[3]:=' ';\r
+ cash[4]:=' ';\r
+ cash[5]:=' ';\r
+ cash[6]:=' ';\r
+ cash[7]:=' ';\r
+ cash[8]:=' ';\r
+ cash[9]:=' ';\r
+ cash[10]:=' ';\r
+ cash[11]:=' ';\r
+ cash[12]:=' ';\r
+ cash[13]:=' ';\r
+ cash[14]:=' ';\r
+ cash[15]:=' ';\r
+ cash[16]:=' '; \r
+\r
+ value:=false;\r
+\r
+ reloc_value.use:=false;\r
+ reloc_value.cnt:=0;\r
+\r
+ j:=1; // na pozycji zerowej (J=0) tablicy 'STOS' dopiszemy '+0'\r
+ // !!! zmienne I,J uzywane sa przez petle WHILE !!!\r
+\r
+// SetLength(stos,3);\r
+\r
+ len:=length(a);\r
+\r
+ while (i<=len) and not(overflow) do begin\r
+\r
+ case UpCase(a[i]) of\r
+\r
+ '#': begin\r
+ if ___rept_ile<0 then blad(old,116); \r
+\r
+ war:=___rept_ile;\r
+ value:=true;\r
+ __inc(i,a); \r
+ end;\r
+\r
+ // odczytaj operator '<'\r
+ '<': if a[i+1] in ['<','=','>'] then\r
+ oper:=OperExt(i,old,'<',a[i+1],value) else\r
+ if value then oper:=OperNew(i,old,'<',value,true) else\r
+ oper:=OperNew(i,old,'M',value,false);\r
+\r
+ // odczytaj operator '>'\r
+ '>': if a[i+1] in ['=','>'] then\r
+ oper:=OperExt(i,old,'>',a[i+1],value) else\r
+ if value then oper:=OperNew(i,old,'>',value,true) else\r
+ oper:=OperNew(i,old,'S',value,false);\r
+\r
+ // odczytaj operator '='\r
+ '=': if a[i+1]='=' then\r
+ oper:=OperExt(i,old,'=','=',value) else\r
+ if value then oper:=OperNew(i,old,'=',value,true) else\r
+ oper:=OperNew(i,old,'X',value,false);\r
+\r
+ // odczytaj operator '&'\r
+ '&': if a[i+1]='&' then\r
+ oper:=OperExt(i,old,'&','&',value) else\r
+ oper:=OperNew(i,old,'&',value,true);\r
+\r
+ // odczytaj operator '|'\r
+ '|': if a[i+1]='|' then\r
+ oper:=OperExt(i,old,'|','|',value) else\r
+ oper:=OperNew(i,old,'|',value,true);\r
+\r
+ // odczytaj operator '!'\r
+ '!': if a[i+1]='=' then\r
+ oper:=OperExt(i,old,'!','=',value) else\r
+ oper:=OperNew(i,old,'!',value,false);\r
+\r
+ // odczytaj operator '^'\r
+ '^': if not(value) then begin\r
+ oper:='H'; inc(i)\r
+ end else oper:=OperNew(i,old,'^',value,true);\r
+\r
+ // odczytaj operator '/'\r
+ '/': if a[i+1]='*' then begin\r
+ omin_spacje(i,a);\r
+ value:=false;\r
+ end else oper:=OperNew(i,old,'/',value,true);\r
+\r
+ // odczytaj operator '*'\r
+ '*': if not(value) then begin\r
+ b:=bank;\r
+ war:=adres; inc(i);\r
+ value:=true;\r
+\r
+ label_type:='V';\r
+\r
+ if not(branch) then begin\r
+ save_rel(adres, -1, bank, reloc_value);\r
+ end;\r
+\r
+ end else oper:=OperNew(i,old,'*',value,true);\r
+\r
+ // odczytaj operator '~'\r
+ '~': oper:=OperNew(i,old,'~',value,false);\r
+\r
+ // odczytaj operatory '+' '-'\r
+ '+','-':\r
+ oper:=OperNew(i,old,a[i],value,value);\r
+\r
+ // odczytaj wartosc decymalna lub wyjatkowo hex 0x...\r
+ '0'..'9':\r
+ begin\r
+ if value then blad(old,4);\r
+\r
+ if (UpCase(a[i+1])='X') and (a[i]='0') then begin // 0x...\r
+\r
+ inc(i);\r
+ tmp:=read_HEX(i,a,old);\r
+\r
+ end else begin // 0..9\r
+\r
+ tmp:='';\r
+ while _dec(a[i]) do begin tmp:=tmp+a[i]; __inc(i,a) end;\r
+\r
+ end;\r
+\r
+ war:=StrToInt(tmp);\r
+\r
+ value:=true;\r
+ end;\r
+\r
+ // odczytaj .R, .OR, .LO, .HI, .GET, .AND, .XOR, .NOT, .LEN, .ADR, .DEF\r
+ '.':\r
+ if a[i+1] in ['r','R'] then begin // .R\r
+ if ___rept_ile<0 then blad(old,116);\r
+ \r
+ war:=___rept_ile;\r
+ inc(i,2);\r
+ value:=true;\r
+ if not(loop_used) and not(FOX_ripit) then t:=t+' #'+Hex(cardinal(war),2); // zapisz w pliku LST #numer\r
+\r
+ end else begin\r
+\r
+ tmp:='.'+UpCase(a[i+1])+UpCase(a[i+2]);\r
+ _hlp:=ord(tmp[2]) shl 16+ord(tmp[3]) shl 8;\r
+\r
+ case _hlp of\r
+ $4F5200: begin\r
+ oper:=OperExt(i,old,'|','|',value); // .OR\r
+ inc(i);\r
+ end;\r
+\r
+ $4C4F00: begin // .LO (expression)\r
+ inc(i,3);\r
+\r
+ old_reloc_value_cnt := reloc_value.cnt;\r
+ old_reloc_value_use := reloc_value.use;\r
+\r
+ war:=byte( oblicz_wartosc_ogr(a,old,i) );\r
+\r
+ reloc_value.use := old_reloc_value_use;\r
+ inc(reloc_value.cnt, old_reloc_value_cnt);\r
+\r
+ value:=true;\r
+ end;\r
+\r
+ $484900: begin // .HI (expression)\r
+ inc(i,3);\r
+\r
+ old_reloc_value_cnt := reloc_value.cnt;\r
+ old_reloc_value_use := reloc_value.use;\r
+\r
+ war:=byte( oblicz_wartosc_ogr(a,old,i) shr 8 );\r
+\r
+ reloc_value.use := old_reloc_value_use;\r
+ inc(reloc_value.cnt, old_reloc_value_cnt);\r
+ \r
+ value:=true;\r
+ end;\r
+\r
+ else begin\r
+\r
+ tmp:=tmp+UpCase(a[i+3]);\r
+ inc( _hlp , ord(tmp[4]) );\r
+\r
+ case _hlp of\r
+ $474554:\r
+ begin // .GET\r
+ inc(i,4);\r
+ omin_spacje(i,a); arg:=0;\r
+\r
+ old_reloc_value_cnt := reloc_value.cnt;\r
+ old_reloc_value_use := reloc_value.use;\r
+\r
+ if a[i] in ['[','('] then arg:=integer( oblicz_wartosc_ogr(a,old,i) );\r
+\r
+ subrange_bounds(old,arg,$FFFF); // !!! konieczny test\r
+\r
+ reloc_value.use := old_reloc_value_use;\r
+ inc(reloc_value.cnt, old_reloc_value_cnt);\r
+\r
+ war:=t_get[arg];\r
+ value:=true;\r
+ end;\r
+\r
+ $414E44:\r
+ begin\r
+ oper:=OperExt(i,old,'&','&',value); // .AND\r
+ inc(i,2);\r
+ end;\r
+\r
+ $584F52:\r
+ begin\r
+ oper:=OperNew(i,old,'^',value,true); // .XOR\r
+ inc(i,3);\r
+ end;\r
+\r
+ $4E4F54:\r
+ begin\r
+ oper:=OperNew(i,old,'!',value,false); // .NOT\r
+ inc(i,3);\r
+ end;\r
+\r
+ $4C454E: // .LEN label\r
+ begin\r
+ // omijamy 4 znaki dyrektywy '.LEN'\r
+ // i odczytujemy nazwe etykiety\r
+ inc(i,4);\r
+\r
+ if a[i] in ['''','"'] then begin // file size\r
+\r
+ txt:=get_string(i,a,old,true);\r
+\r
+ txt:=GetFile(txt,a); if not(TestFile(txt)) then blad(txt,18);\r
+\r
+ assignfile(fsize, txt); FileMode:=0; Reset(fsize, 1);\r
+ war:=FileSize(fsize);\r
+ CloseFile(fsize);\r
+\r
+ end else begin // var size\r
+\r
+ txt:=get_labEx(i,a, old);\r
+ arg:=load_label_ofset(txt, old, true);\r
+\r
+ if arg>=0 then\r
+ case t_lab[arg].bnk of\r
+ __id_proc: war:=t_prc[t_lab[arg].adr].len; // dlugosc bloku .PROC\r
+ __id_array: war:=t_arr[t_lab[arg].adr].len; // dlugosc bloku .ARRAY\r
+ __id_struct: war:=t_str[t_lab[arg].adr].siz; // dlugosc bloku .STRUCT\r
+ else\r
+ war:=t_lab[arg].lln; // dlugosc bloku .LOCAL\r
+ end;\r
+\r
+ end;\r
+\r
+ value:=true;\r
+ end;\r
+\r
+ $414452:\r
+ begin // .ADR label\r
+ // omijamy 4 znaki dyrektywy '.ADR'\r
+ // i odczytujemy nazwe etykiety\r
+ inc(i,4);\r
+\r
+ txt:=get_labEx(i,a, old);\r
+\r
+ arg:=load_label_ofset(txt, old, true);\r
+\r
+ war:=0;\r
+\r
+ if arg>=0 then begin\r
+\r
+ old_reloc_value_cnt := reloc_value.cnt;\r
+ old_reloc_value_use := reloc_value.use;\r
+\r
+ war:= oblicz_wartosc(txt,old);\r
+\r
+ reloc_value.use := old_reloc_value_use;\r
+ inc(reloc_value.cnt, old_reloc_value_cnt);\r
+ \r
+ case t_lab[arg].bnk of\r
+ __id_proc: dec(war, t_prc[t_lab[arg].adr].ofs);\r
+ else\r
+ dec(war, t_lab[arg].ofs)\r
+ end;\r
+\r
+ end;\r
+ \r
+ value:=true;\r
+ end;\r
+\r
+ $444546:\r
+ begin // .DEF label\r
+ // omijamy 4 znaki dyrektywy '.DEF'\r
+ // i odczytujemy nazwe etykiety\r
+ inc(i,4);\r
+\r
+ txt:=get_labEx(i,a, old);\r
+ arg:=load_label_ofset(txt, old, false);\r
+\r
+// war:=ord(arg>=0); // !!! nie dziala prawidlowo dla .IFNDEF z Exomizera !!!\r
+\r
+ if arg>=0 then // !!! koniecznie ta wersja !!!\r
+ war := ord( t_lab[arg].pas>0 )\r
+ else\r
+ war:=0;\r
+\r
+ value:=true;\r
+ end;\r
+\r
+ else begin\r
+\r
+ tmp:=tmp+UpCase(a[i+4])+UpCase(a[i+5]);\r
+\r
+ if tmp<>'.ZPVAR' then\r
+ blad_und(old,tmp,68)\r
+ else begin\r
+ inc(i,6);\r
+ war:=zpvar;\r
+ value:=true;\r
+ end;\r
+\r
+ end; \r
+\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+ // odczytaj etykiete i okresl jej wartosc\r
+ // znak ':' oznacza etykiete globalna lub parametr makra\r
+ 'A'..'Z','_','?','@',':':\r
+ begin\r
+ petla:=false; b:=0; war:=0; //pomoc:=0;\r
+\r
+ if a[i]=':' then\r
+\r
+ if _lab_first(a[i+1]) then begin\r
+ petla:=true; inc(i)\r
+ end else\r
+ if _dec(a[i+1]) then begin\r
+\r
+ if run_macro then begin\r
+ value:=false; oper:=' '; Break; //i:=len+1\r
+ end else\r
+ blad_ill(old,':');\r
+\r
+ end else\r
+ blad(old,4);\r
+\r
+ if i<=len then begin\r
+\r
+ if value then blad(old,4);\r
+\r
+ tmp:=get_lab(i,a, false); if petla then tmp:=':'+tmp;\r
+\r
+\r
+ arg:=load_label_ofset(tmp, old, true);\r
+\r
+\r
+{ if arg>=0 then // skladnia dla enum label1::label2\r
+ if t_lab[arg].bnk=__id_enum then // usunieta w celu zachowania spojnosci\r
+ if (a[i]=':') and (a[i+1]=':') then begin // akceptowany jest znak '.' zamiast '::'\r
+ inc(i, 2);\r
+ tmp:=tmp+'.'+get_lab(i,a, false);\r
+\r
+ if petla then tmp:=':'+tmp;\r
+\r
+ arg:=load_label_ofset(tmp, old, true);\r
+ end; }\r
+\r
+\r
+ // jesli przetwarzamy makro to nie musza byc zdefiniowane wartosci etykiet\r
+ // w pozostalych przypadkach wystapi blad 'Undeclared label ????'\r
+\r
+ if arg<0 then begin\r
+ undeclared:=true; // wystapila niezdefiniowana etykieta\r
+ value:=false; oper:=' '; Break // przerywamy obliczanie wyrazenia\r
+ end else\r
+ if (pass=pass_end) and (t_lab[arg].bnk<__id_param) and t_lab[arg].sts then blad_und(old,tmp,113);\r
+\r
+ undeclared:=t_lab[arg].sts; // aktualny status etykiety\r
+\r
+ pomoc:=t_lab[arg].adr;\r
+\r
+ if (t_lab[arg].typ in ['P','V']) then variable:=true;\r
+\r
+ t_lab[arg].use:=true;\r
+\r
+\r
+ if arg>=0 then\r
+ case t_lab[arg].bnk of\r
+\r
+ __id_struct: // zamiana struktur na dane DTA, na poczatku sprawdzimy czy 'DTA_USED = true'\r
+\r
+ if not(dta_used) then begin\r
+\r
+ b := t_str[pomoc].bnk;\r
+ war := t_str[pomoc].siz;\r
+\r
+ end else\r
+ if pass=0 then begin // teraz nie znamy wszystkich struktur, musimy koñczyc\r
+\r
+ if a[i]<>'[' then warning(102); // 'Constant expression expected', brakuje indeksu [idx]\r
+\r
+ end else begin // w drugim przebiegu mamy pewnosc ze poznalismy wszystkie struktury\r
+\r
+ dta_used:=false;\r
+\r
+ struct_used.use:=true;\r
+\r
+ save_lst('i');\r
+\r
+ // odczytujemy ofset do tablicy 'T_STR'\r
+ ofset:=t_lab[arg].adr;\r
+\r
+ struct_used.idx:=ofset; // w OFSET indeks do pierwszego pola struktury\r
+\r
+ // liczba pol struktury\r
+ b := t_str[ofset].ofs;\r
+\r
+ inc(ofset); txt:='';\r
+\r
+ // odczytujemy zadeklarowana liczbe elementow danych strukturalnych [?]\r
+ arg:=integer( oblicz_wartosc_ogr(a,old,i) );\r
+\r
+ testRange(old, arg, 62);\r
+\r
+ struct_used.cnt:=arg;\r
+\r
+ omin_spacje(i,a);\r
+\r
+ // odczytujemy wartosci elementow ograniczone nawiasami ( )\r
+ while a[i] ='(' do begin\r
+\r
+ tmp:=ciag_ograniczony(i,a,true);\r
+\r
+ k:=1; tmp:=get_dat_noSPC(k,tmp,#0,#0,old);\r
+ k:=1;\r
+\r
+ SetLength(stos_,1);\r
+\r
+ // wczytujemy elementy ograniczone nawiasami, w 'X' jest licznik\r
+ x:=0;\r
+ while k<=length(tmp) do begin\r
+\r
+ pomoc:=loa_str_no(t_str[ofset].id, x); // zawsze musi odnalezc wlasciwe pole struktury\r
+\r
+ v:=t_str[pomoc].siz; byt:=tType[v];\r
+\r
+ war:=___wartosc_noSPC(tmp,old,k,',',byt);\r
+\r
+ _hlp:=t_str[pomoc].rpt * v;\r
+\r
+ save_dtaS(cardinal(war), _hlp);\r
+\r
+ inc(x);\r
+// if pass>0 then\r
+ if x>b then blad(old,40); // jesli liczba podanych elementow jest wieksza niz w strukturze\r
+\r
+ pomoc:=High(stos_);\r
+ stos_[pomoc]:=cardinal( war );\r
+\r
+ SetLength(stos_,pomoc+2);\r
+\r
+ omin_spacje(k,tmp);\r
+ if tmp[k]=',' then __inc(k,tmp) else Break;\r
+ end;\r
+\r
+// if pass>0 then\r
+ if x<>b then blad(old,40);\r
+\r
+ // zmniejszamy licznik elementow\r
+ dec(arg); if arg<-1 then blad(old,40);\r
+\r
+ omin_spacje(i,a);\r
+ end;\r
+\r
+ omin_spacje(i,a);\r
+\r
+ value:=( High(stos_) = b ); // jesli podalismy jakies wartosci poczatkowe to VALUE=TRUE\r
+\r
+ if not(value) then new_DOS_header; // jesli nie podalismy wartosci to musimy wymusic ORG-a\r
+\r
+ // !!! nie mozna domyslnie zapisywac zer dla zmiennej strukturalnej !!!\r
+ // !!! bo nie zawsze mozna zapisywac pamiec pod aktualnym adresem !!!\r
+\r
+ // reszte elementow struktury wypelniamy ostatnimi wartosciami lub zerami\r
+ while arg>=0 do begin\r
+\r
+ for x:=0 to b-1 do begin\r
+\r
+ pomoc:=loa_str_no(t_str[ofset].id, x);\r
+\r
+ v:=t_str[pomoc].siz; //byt:=tType[v];\r
+\r
+ _hlp:=t_str[pomoc].rpt * v;\r
+\r
+ if value then begin\r
+ war:=stos_[x];\r
+ save_dtaS(cardinal(war), _hlp); // nowy adres i zapisanie wartosci poczatkowej struktury\r
+ end else begin\r
+ war:=0;\r
+ inc(adres, _hlp); // nowy adres bez zapisywania wartosci poczatkowej\r
+ end;\r
+\r
+ end;\r
+\r
+ dec(arg);\r
+ end;\r
+\r
+ b:=bank;\r
+ value:=false;\r
+ oper:=' ';\r
+ end;\r
+\r
+ __id_enum: begin\r
+ omin_spacje(i,a);\r
+ \r
+ if a[i] in ['(','['] then begin\r
+\r
+ _hlp:=usi_idx; // dla enum_name(label1|label2|...)\r
+\r
+ t_usi[usi_idx].lok:=end_idx;\r
+ t_usi[usi_idx].lab:=tmp;\r
+\r
+ if proc then\r
+ t_usi[usi_idx].nam:=proc_name\r
+ else \r
+ t_usi[usi_idx].nam:=lokal_name;\r
+\r
+ inc(usi_idx);\r
+\r
+ SetLength(t_usi, usi_idx+1);\r
+\r
+ war:=oblicz_wartosc_ogr(a,old,i);\r
+\r
+ usi_idx:=_hlp;\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ __id_proc: begin\r
+ b:=t_prc[pomoc].bnk;\r
+ war:=t_prc[pomoc].adr;\r
+\r
+ if ExProcTest then\r
+ t_prc[pomoc].use:=true; // procedura .PROC musi byc asemblowana\r
+\r
+ save_relAddress(arg, reloc_value);\r
+ end;\r
+\r
+ __id_ext: begin\r
+ if blocked then blad_und(old,tmp,41);\r
+\r
+ if not(branch) then begin\r
+\r
+ if vector then\r
+ _hlp:=adres\r
+ else\r
+ _hlp:=adres+1;\r
+\r
+ if dreloc.use then dec(_hlp, rel_ofs);\r
+\r
+ t_ext[ext_idx].adr := _hlp;\r
+ t_ext[ext_idx].bnk := bank;\r
+ t_ext[ext_idx].idx := pomoc;\r
+\r
+ inc(ext_idx);\r
+\r
+ if ext_idx>High(t_ext) then SetLength(t_ext,ext_idx+1);\r
+ end;\r
+\r
+ ext_used.use:=true;\r
+ ext_used.idx:=pomoc;\r
+ ext_used.siz:=t_extn[pomoc].siz;\r
+\r
+ inc(reloc_value.cnt);\r
+ end;\r
+\r
+ __id_smb: begin\r
+ if blocked then blad_und(old,tmp,41);\r
+\r
+ if not(branch) then begin\r
+ save_rel(adres,pomoc,0, reloc_value);\r
+ t_smb[pomoc].use:=true;\r
+ war:=__rel;\r
+ end;\r
+\r
+ end;\r
+\r
+ __id_array: begin\r
+ b:=t_arr[pomoc].bnk;\r
+ war:=t_arr[pomoc].adr;\r
+\r
+ omin_spacje(i,a);\r
+ if a[i]='[' then begin\r
+ ofset:=integer( oblicz_wartosc_ogr(a,old,i) );\r
+ subrange_bounds(old,ofset,t_arr[pomoc].idx);\r
+\r
+ inc(war, Int64(ofset)*t_arr[pomoc].siz);\r
+ end;\r
+\r
+ save_relAddress(arg, reloc_value);\r
+ end;\r
+\r
+ __dta_struct: begin\r
+\r
+ save_relAddress(arg, reloc_value);\r
+\r
+ b:=t_str[pomoc].bnk;\r
+ war:=t_str[pomoc].adr;\r
+\r
+ ofset:=integer( oblicz_wartosc_ogr(a,old,i) );\r
+\r
+ subrange_bounds(old,ofset,t_str[pomoc].ofs);\r
+\r
+ arg:=t_str[t_lab[arg].adr].idx;\r
+\r
+ ofset:=ofset * t_str[arg].siz; // indeks * dlugosc_struktury\r
+\r
+ if a[i]='.' then begin\r
+ inc(i);\r
+ txt:=get_lab(i,a, false);\r
+\r
+ // szukamy w T_STR\r
+ pomoc:=loa_str(txt, t_str[arg].id);\r
+\r
+ if pomoc>=0 then\r
+ inc(ofset,t_str[pomoc].ofs)\r
+ else\r
+ if pass=pass_end then blad_und(old,txt,46);\r
+\r
+ end;\r
+\r
+ inc(war,ofset);\r
+ end;\r
+ else\r
+ begin\r
+\r
+\r
+ // wystapi blad 'Address relocation overload'\r
+ // jesli dokonujemy operacji na wiecej niz jednej relokowalnej etykiecie\r
+\r
+ save_relAddress(arg, reloc_value);\r
+\r
+\r
+ if dreloc.use or dreloc.sdx then\r
+ if reloc_value.use and (reloc_value.cnt>1) then blad(old,85);\r
+\r
+\r
+ b:=t_lab[arg].bnk;\r
+ war:=t_lab[arg].adr;\r
+\r
+ while pos('.',tmp)>0 do begin\r
+\r
+ obetnij_kropke(tmp);\r
+\r
+ k:=length(tmp); // usun ostatni znak kropki\r
+ SetLength(tmp,k-1);\r
+\r
+ arg:=l_lab(tmp);\r
+\r
+ pomoc:=t_lab[arg].adr;\r
+\r
+ if (arg>=0) and ExProcTest then\r
+ if t_lab[arg].bnk=__id_proc then begin\r
+ t_prc[pomoc].use:=true; // procedura .PROC musi byc asemblowana\r
+ Break;\r
+ end;\r
+ \r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+ value:=true;\r
+ end;\r
+\r
+\r
+ // wyjatkowo dla PASS=0 i prawdopodobnego odwolania do tablicy przyjmij wartosc =0\r
+ omin_spacje(i,a);\r
+ if a[i]='[' then\r
+ if pass<pass_end then\r
+ exit\r
+ else\r
+ blad_und(old,tmp,5);\r
+\r
+ end;\r
+\r
+ // odczytaj wartosc hexadecymalna\r
+ '$': begin\r
+\r
+ if value then blad(old,4);\r
+\r
+ tmp:=read_HEX(i,a,old);\r
+\r
+ war:=StrToInt(tmp);\r
+\r
+ value:=true;\r
+ end;\r
+\r
+ // odczytaj wartosc binarna lub potraktuj '%' jako operator\r
+ // lub jako numer parametru dla makra gdy wystapily znaki '%%'\r
+ '%': if a[i+1]='%' then begin\r
+\r
+ if not(_dec(a[i+2])) then blad(old,47); // %%0..9\r
+\r
+// b:=0; war:=0;\r
+ value:=false; oper:=' '; Break; //i:=len+1\r
+ end else\r
+ if value then oper:=OperNew(i,old,'%',value,true) else\r
+ begin\r
+ inc(i); // omin pierwszy znak '%'\r
+// war:=get_value(i,a,'B',old);\r
+\r
+ tmp:='';\r
+ while _bin(a[i]) do begin tmp:=tmp+a[i]; __inc(i,a) end;\r
+\r
+ if not(test_param(i,a)) then\r
+ if tmp='' then blad_ill(old,a[i]);\r
+\r
+// war:=BinToInt(tmp);\r
+ war:=0;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* realizacja zamiany ciagu zero-jedynkowego na wartosc decymalna *)\r
+(*----------------------------------------------------------------------------*)\r
+ if tmp<>'' then begin\r
+\r
+ k:=Length(tmp);\r
+\r
+ //remove leading zeros\r
+ pomoc:=1;\r
+ while tmp[pomoc]='0' do inc(pomoc);\r
+\r
+ //do the conversion\r
+ for ofset:=k downto pomoc do\r
+ if tmp[ofset]='1' then\r
+ war:=war+(1 shl (k-ofset));\r
+ end;\r
+ \r
+ value:=true;\r
+ end;\r
+\r
+ // odczytaj string ograniczony apostrofami ''\r
+ '''','"':\r
+ begin\r
+ if value then blad(old,4);\r
+\r
+ k:=ord(a[i]);\r
+ tmp:=get_string(i,a,old,true);\r
+\r
+ if length(tmp)>1 then blad(old,3); // maksymalnie 1 znak\r
+ \r
+ if chr(k)='''' then\r
+ war:=ord(tmp[1])\r
+ else\r
+ war:=ata2int(ord(tmp[1]));\r
+\r
+ byt:=a[i+1];\r
+\r
+ if not(_lab_firstEx(byt) or _dec(byt) or (byt in ['$','%'])) then\r
+ inc(war,test_string(i,a,'F'));\r
+\r
+ value:=true;\r
+ end;\r
+\r
+ // odczytaj wartosc miedzy { }\r
+ '{': begin\r
+ if value then blad(old,4);\r
+\r
+ klamra_used := true;\r
+\r
+ petla:=dreloc.use; // blokujemy relokowalnosc DRELOC.USE=FALSE\r
+ dreloc.use:=false;\r
+\r
+ tmp:=ciag_ograniczony(i,a,true); // test na poprawnosc nawiasow\r
+ k:=1; nul:=oblicz_mnemonik__(k,tmp,old);\r
+\r
+ dreloc.use:=petla; // przywracamy poprzednia wartosc DRELOC.USE\r
+\r
+ klamra_used := false;\r
+\r
+ war:=nul.h[0];\r
+\r
+ nul.l:=0;\r
+\r
+ value:=true;\r
+ end;\r
+\r
+ // odczytaj wartosc miedzy [ ] ( )\r
+ '[','(':\r
+ begin\r
+ if value then blad(old,4);\r
+\r
+ old_reloc_value_cnt := reloc_value.cnt;\r
+ old_reloc_value_use := reloc_value.use;\r
+\r
+ war:=oblicz_wartosc_ogr(a,old,i);\r
+\r
+ reloc_value.use := old_reloc_value_use;\r
+ inc(reloc_value.cnt, old_reloc_value_cnt);\r
+\r
+ value:=true;\r
+ end;\r
+\r
+ // jesli napotkasz spacje to zakoncz przetwarzanie\r
+ // do 'value' wpisz 'false' aby nie traktowal tego jako liczby\r
+ ' ',#9:\r
+ begin\r
+ value:=false; oper:=' '; Break; //i:=len+1\r
+ end;\r
+\r
+ else\r
+ blad_ill(old,a[i]);\r
+ end;\r
+\r
+\r
+// jesli przetwarzamy wartosc numeryczna to zapisz na stosie\r
+// t¹ wartosc i operator\r
+ if value then begin\r
+\r
+ op[op_idx]:='+';\r
+\r
+ // przetworz operatory z 'OP' cofajac sie\r
+ for k:=op_idx downto 1 do\r
+ case op[k] of\r
+ '-': war := -war;\r
+ 'M': war := byte(war);\r
+ 'S': war := byte(war shr 8);\r
+ 'H': war := byte(war shr 16);\r
+// 'I': war := byte(war shr 24);\r
+ '!': war := ord(war=0);\r
+ '~': war := not(war);\r
+ 'X': war := b;\r
+ end;\r
+\r
+ if op[0]='-' then begin war:=-war; op[0]:='+' end;\r
+\r
+ stos[j].znak := op[0];\r
+ stos[j].wart := war;\r
+\r
+ cash[pos(op[0],prior)-1]:=op[0];\r
+\r
+ // zeruj indeks do tablicy dynamicznej OP\r
+ op_idx:=0; oper:=' ';\r
+\r
+ inc(j);\r
+// if j>High(stos) then SetLength(stos,j+1);\r
+\r
+ end else begin\r
+\r
+ op[op_idx] := oper;\r
+\r
+ inc(op_idx);\r
+ // if op_idx>High(op) then SetLength(op,op_idx+1);\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ if not(overflow) then\r
+ if oper<>' ' then blad(old,23);\r
+\r
+\r
+ if reloc_value.cnt>1 then blad(old,85);\r
+\r
+\r
+// obliczenie wartosci wg piorytetu obliczen\r
+// na koncu dodawaj tak dlugo az nie uzyskasz wyniku\r
+ len:=0; war:=0;\r
+\r
+ while cash[len]=' ' do inc(len); // omijaj puste operatory\r
+ if len>=sizeof(cash) then exit; // nie wystapil zaden operator\r
+\r
+ stos[0].znak:='+'; stos[0].wart:=0;\r
+ stos[j].znak:='+'; stos[j].wart:=0;\r
+ inc(j);\r
+\r
+// SetLength(stos,j+1);\r
+\r
+\r
+ while j>1 do begin\r
+ // 'petla=true' jesli nie wystapi zaden operator\r
+ // 'petla=false' jesli wystapi operator\r
+ i:=0; petla:=true;\r
+\r
+ while i<=j-2 do begin\r
+\r
+ war := stos[i].wart;\r
+ oper := stos[i+1].znak;\r
+ iarg := stos[i+1].wart;\r
+\r
+ // obliczaj wg kolejnosci operatorow z 'prior'\r
+ // operatory '/','*','%' maja ten sam piorytet, stanowi¹ wyj¹tek\r
+\r
+ if (oper=cash[len]) or ((oper in ['/','*','%']) and (len in [5..7])) then begin\r
+ case oper of\r
+ '+': war := war + iarg;\r
+ '&': war := war and iarg;\r
+ '|': war := war or iarg;\r
+ '^': war := war xor iarg;\r
+ '*': war := war * iarg;\r
+\r
+ '/','%':\r
+ if iarg=0 then begin\r
+\r
+ overflow:=true;\r
+\r
+ if pass=pass_end then\r
+ blad(old,26)\r
+ else\r
+ war:=0;\r
+\r
+ end else\r
+ case oper of\r
+ '/': war := war div iarg;\r
+ '%': war := war mod iarg;\r
+ end;\r
+\r
+ '=': war := ord(war=iarg);\r
+ 'A': war := ord(war<>iarg);\r
+ 'B': war := ord(war<=iarg);\r
+ '<': war := ord(war<iarg);\r
+ 'C': war := ord(war>=iarg);\r
+ '>': war := ord(war>iarg);\r
+ 'D': war := war shl iarg;\r
+ 'E': war := war shr iarg;\r
+ 'F': war := ord(war<>0) and ord(iarg<>0);\r
+ 'G': war := ord(war<>0) or ord(iarg<>0);\r
+ end;\r
+\r
+ // obliczyl nowa wartosc, skasuj znak\r
+\r
+ stos[i].wart := war;\r
+ stos[i+1].znak := ' ';\r
+\r
+ inc(i); petla:=false;\r
+ end;\r
+\r
+ inc(i)\r
+ end;\r
+\r
+// przepisz elementy ktore maja niepusty znak na poczatek tablicy STOS\r
+ k:=0;\r
+\r
+ for i:=0 to j-1 do\r
+ if stos[i].znak<>' ' then begin\r
+ stos[k] := stos[i];\r
+ inc(k)\r
+ end;\r
+\r
+ j:=k;\r
+\r
+ if petla and (len<sizeof(prior)-1) then begin\r
+ inc(len);\r
+ while cash[len]=' ' do inc(len);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ if overflow then // konieczny warunek dla .MACRO\r
+ Result := 0\r
+ else\r
+ Result := war;\r
+\r
+end;\r
+\r
+\r
+function oblicz_wartosc_noSPC(var zm,old:string; var i:integer; const sep,typ:Char): Int64;\r
+(*----------------------------------------------------------------------------*)\r
+(* pobieramy ciag pomijajac spacje, nastepnie obliczamy jego wartosc *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+begin\r
+\r
+ txt:=get_dat_noSPC(i,zm,sep,#0,old);\r
+\r
+ Result:=oblicz_wartosc(txt,old);\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ wartosc(old,Result,typ);\r
+\r
+end;\r
+\r
+\r
+function get_expres(var i:integer; var a,old:string; const tst:Boolean): Int64;\r
+(*----------------------------------------------------------------------------*)\r
+(* pobierz ciag znakow ograniczony przecinkiem i oblicz jego wartosc *)\r
+(* nie wczytuj nawiasow zamykajacych ')' *)\r
+(* jesli TST = TRUE to sprawdzaj czy to koniec wyrazenia *)\r
+(*----------------------------------------------------------------------------*)\r
+var k: integer;\r
+ tmp: string;\r
+begin\r
+ k:=i;\r
+ tmp:=get_dat(k,a,')',false);\r
+\r
+ tmp:=a;\r
+ SetLength(tmp,k-1); // tmp:=copy(a,1,k-1);\r
+\r
+ Result:=___wartosc_noSPC(tmp,old,i,',','F');\r
+\r
+ if tst then\r
+ if a[i]<>',' then blad(old,52) else inc(i);\r
+end;\r
+\r
+\r
+procedure put_lst(const a:string);\r
+(*----------------------------------------------------------------------------*)\r
+(* zapisujemy wiersze listingu po asemblacji do pliku .LST *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+\r
+ if (pass=pass_end) and (a<>'') then begin\r
+\r
+ if run_macro then // nie zapisuj zawartosci makra jesli bit5 OPT skasowany\r
+ if (opt and $20=0) and not(data_out) then exit;\r
+\r
+ if (opt and 4>0) and not(FOX_ripit) then writeln(lst,a);\r
+ if (opt and 8>0) and not(FOX_ripit) then writeln(a);\r
+\r
+ if not(FOX_ripit) then t:='';\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure zapisz_lst(var a: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* wymuszenie zapisania wiersza listingu do pliku .LST *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+\r
+ if (pass=pass_end) then begin\r
+ justuj; put_lst(t+a); a:='';\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure wymus_zapis_lst(var a: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* dodatkowe wymuszenie zapisania wiersza listingu do pliku .LST *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+\r
+ if pass=pass_end then begin\r
+ save_lst(' ');\r
+ justuj; put_lst(t+a);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure _siz(const t: Boolean);\r
+begin\r
+\r
+ if t then\r
+ t_siz[siz_idx-1].siz:=dreloc.siz\r
+ else\r
+ t_siz[siz_idx].siz:=dreloc.siz;\r
+\r
+end;\r
+\r
+\r
+procedure _sizm(const a: byte);\r
+begin\r
+\r
+ t_siz[siz_idx-1].lsb:=a;\r
+\r
+end;\r
+\r
+\r
+procedure oblicz_dane(var i:integer; var a,old:string; const typ: byte);\r
+(*----------------------------------------------------------------------------*)\r
+(* zwracamy wartosci liczbowe dla ciagu DTA, .BYTE, .WORD, .LONG, .DWORD *)\r
+(*----------------------------------------------------------------------------*)\r
+(* B( -> BYTE, A( -> WORD, V( -> VECTOR (WORD) *)\r
+(* L( -> BYTE, H( -> BYTE *)\r
+(* T( -> 24bit, E( -> 24bit *)\r
+(* F( -> DWORD *)\r
+(* G( -> DWORD (odwrocona kolejnosc) *)\r
+(* C' -> ATASCII *)\r
+(* D' -> INTERNAL *)\r
+(* sin(centre,amp,size[,first,last]) *)\r
+(*----------------------------------------------------------------------------*)\r
+var op_, default: char;\r
+ sin_a, sin_b, sin_c, sin_d, sin_e, x, len, k: integer;\r
+ war: Int64;\r
+ invers: byte;\r
+ value, nawias, ciag: Boolean;\r
+ tmp: string;\r
+begin\r
+ omin_spacje(i,a);\r
+\r
+ if empty or enum.use then blad(old,58);\r
+\r
+ war:=0; invers:=0;\r
+\r
+ value:=false; nawias:=false; ciag:=false;\r
+\r
+ if not(pisz) then branch:=false;\r
+\r
+ reloc := false;\r
+\r
+ data_out := true;\r
+\r
+ tmp:=' ';\r
+\r
+\r
+// ------------------ okreslenie domyslnego typu wartosci ---------------------\r
+\r
+ default := tType[typ];\r
+ op_:=default;\r
+\r
+ dreloc.siz:=relType[typ];\r
+\r
+// ----------------------------------------------------------------------------\r
+\r
+\r
+ if not(pisz) and test_char(i,a,#0,#0) then begin // jesli brakuje danych to generuj domyslnie zera\r
+ save_dta(cardinal(war),tmp,op_,invers);\r
+ exit;\r
+ end;\r
+\r
+ if struct.use then blad(old,58);\r
+\r
+ vector:=true;\r
+\r
+ if not(pisz) then dta_used:=true;\r
+\r
+\r
+ len:=length(a);\r
+\r
+ while i<=len do begin\r
+\r
+// SIN, RND\r
+ if UpCase(a[i]) in ['S','R'] then begin\r
+ x:=ord(UpCase(a[i+1])) shl 16+ord(UpCase(a[i+2])) shl 8+ord(a[i+3]);\r
+\r
+ CASE x of\r
+ // IN(\r
+ $494E28: begin\r
+ inc(i,3);\r
+\r
+ // sprawdzamy poprawnosc nawiasow\r
+ k:=i;\r
+ tmp:=ciag_ograniczony(k,a,true);\r
+\r
+ value:=true; invers:=0; tmp:='';\r
+\r
+ inc(i);\r
+ sin_a:=integer( get_expres(i,a,old,true) );\r
+ sin_b:=integer( get_expres(i,a,old,true) );\r
+ sin_c:=integer( get_expres(i,a,old,false) );\r
+\r
+ if sin_c<=0 then blad(old,0); \r
+\r
+ sin_d:=0;\r
+ sin_e:=sin_c-1;\r
+\r
+ if a[i]=',' then begin\r
+\r
+ inc(i);\r
+ sin_d:=integer( get_expres(i,a,old,true) );\r
+ sin_e:=integer( get_expres(i,a,old,false) );\r
+\r
+ inc(i);\r
+ end else inc(i);\r
+\r
+\r
+ while sin_d <= sin_e do begin\r
+ war:= sin_a + round(sin_b * sin(sin_d * 2 * pi / sin_c));\r
+\r
+ war:=wartosc(old,war,op_);\r
+ save_dta(cardinal(war),tmp,op_,invers);\r
+\r
+ inc(sin_d);\r
+ end;\r
+\r
+\r
+ omin_spacje(i,a);\r
+ end;\r
+\r
+ // ND(\r
+ $4E4428: begin\r
+ inc(i,3);\r
+\r
+ // sprawdzamy poprawnosc nawiasow\r
+ k:=i;\r
+ tmp:=ciag_ograniczony(k,a,true);\r
+\r
+ value:=true; invers:=0; tmp:='';\r
+\r
+ inc(i);\r
+ sin_a:=integer( get_expres(i,a,old,true) );\r
+ sin_b:=integer( get_expres(i,a,old,true) );\r
+ sin_c:=integer( get_expres(i,a,old,false) );\r
+ inc(i);\r
+\r
+ sin_d:=sin_b-sin_a;\r
+\r
+ randomize;\r
+ for x:=0 to sin_c-1 do begin\r
+\r
+ war:=sin_a+Int64(random(sin_d+1));\r
+\r
+ war:=wartosc(old,war,op_);\r
+ save_dta(cardinal(war),tmp,op_,invers)\r
+ end;\r
+\r
+ omin_spacje(i,a);\r
+ end;\r
+\r
+ END; //end case\r
+\r
+ end;\r
+\r
+\r
+\r
+ case UpCase(a[i]) of\r
+ 'A','B','E','F','G','H','L','T','V':\r
+\r
+ begin\r
+ k:=i;\r
+\r
+ if a[i+1] in [' ',#9] then begin\r
+ __inc(i,a);\r
+\r
+ if a[i]='(' then dec(i) else i:=k;\r
+ end;\r
+\r
+ if a[i+1]='(' then begin\r
+ // pobierz ciag ograniczony nawiasami ( )\r
+ if value then blad(old,4);\r
+\r
+ op_:=UpCase(a[k]); inc(i);\r
+ // sprawdzamy poprawnosc\r
+ k:=i;\r
+ tmp:=ciag_ograniczony(k,a,true);\r
+ nawias:=true;\r
+\r
+ // dane inne niz 2 bajtowe nie sa relokowalne w przypadku SPARTA DOS X\r
+ // relokowalne sa wszystkie jesli uzylismy dyrektywy .RELOC\r
+ if dreloc.use then begin\r
+// if op_='G' then branch:=true else branch:=false;\r
+ branch := (op_='G');\r
+\r
+ case op_ of\r
+ 'E','T': dreloc.siz:=relType[3];\r
+ 'A','V': dreloc.siz:=relType[2];\r
+ 'F': dreloc.siz:=relType[4];\r
+ 'L': dreloc.siz:='<';\r
+ 'H': dreloc.siz:='>';\r
+ else\r
+ dreloc.siz:=relType[1];\r
+ end;\r
+\r
+ _siz(false); \r
+\r
+ end else\r
+// if op_ in ['E','F','G','T'] then branch:=true else branch:=false;\r
+ branch := (op_ in ['E','F','G','T']);\r
+\r
+ inc(i); // omin nawias otwierajacy\r
+\r
+ end else begin\r
+\r
+ if dreloc.use then _siz(false);\r
+\r
+ if value then blad(old,4);\r
+ war:=get_expres(i,a,old, false);\r
+ value:=true;\r
+\r
+ { if reloc and not(nawias) then ????????????????????????\r
+ if pass=pass_end then warning(116); }\r
+\r
+ if pisz then end_string := end_string + '$' + hex(cardinal(war),4);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ 'C','D':\r
+ begin\r
+ k:=i;\r
+\r
+ if a[i+1] in [' ',#9] then begin\r
+ __inc(i,a);\r
+\r
+ if a[i] in ['''','"'] then dec(i) else i:=k;\r
+ end;\r
+\r
+ if a[i+1] in ['''','"'] then begin\r
+ // pobierz ciag ograniczony apostrofami '' lub ""\r
+ op_:=UpCase(a[k]); inc(i);\r
+\r
+ end else begin\r
+\r
+ if dreloc.use then _siz(false);\r
+\r
+ if value then blad(old,4);\r
+ war:=get_expres(i,a,old, false);\r
+ value:=true;\r
+\r
+ { if reloc and not(nawias) then ????????????????????????\r
+ if pass=pass_end then warning(116); }\r
+\r
+ if pisz then end_string := end_string + '$' + hex(cardinal(war),4);\r
+ end;\r
+\r
+ end;\r
+\r
+ '''','"': begin\r
+ if value then blad(old,4);\r
+\r
+// if aray then\r
+ if not(op_ in ['C','D']) then\r
+ if a[i]='"' then op_:='D' else op_:='C';\r
+\r
+ tmp:=get_string(i,a,old,true);\r
+ war:=0; ciag:=true;\r
+ invers:=byte( test_string(i,a,'B') );\r
+ value:=true;\r
+\r
+ if pisz then end_string := end_string + tmp;\r
+ end;\r
+\r
+\r
+ '(': begin nawias:=true; inc(i) end;\r
+\r
+\r
+ ')': if nawias and value then begin\r
+ value:=false; nawias:=false; inc(i);\r
+\r
+ omin_spacje(i,a);\r
+\r
+ if not(test_char(i,a,#0,#0)) then // jesli nie ma konca linii to jedynym\r
+ if a[i]<>',' then blad(old,107); // akceptowanym znakiem jest znak ','\r
+\r
+ end else blad(old,4);\r
+\r
+\r
+ ',': begin\r
+ inc(i); invers:=0; value:=false;\r
+\r
+ omin_spacje(i,a);\r
+ if test_char(i,a,#0,#0) then blad(old,23); // jesli koniec linii to blad 'Unexpected end of line'\r
+\r
+ if not(nawias) then op_:=default;\r
+ end;\r
+\r
+\r
+ ' ',#9: omin_spacje(i,a); \r
+\r
+\r
+ '/': case a[i+1] of\r
+ '/': Break;\r
+ '*': begin tmp:=''; ___search_comment_block(i,a, tmp); if komentarz then Break end;\r
+ else\r
+ blad(old,4); // value:=false; i:=length(a)+1\r
+ end;\r
+\r
+ ';','\': Break; // value:=false; i:=length(a)+1\r
+\r
+ else\r
+ begin\r
+ if _eol(a[i]) then Break;\r
+\r
+ if dreloc.use then _siz(false);\r
+\r
+ if value then blad(old,4);\r
+\r
+ war:=get_expres(i,a,old, false);\r
+ value:=true;\r
+\r
+ if pisz then end_string := end_string + '$' + hex(cardinal(war),4);\r
+\r
+ end;\r
+ end;\r
+\r
+\r
+ if dta_used then\r
+ if value then begin\r
+\r
+ if not(ciag) then\r
+ if op_ in ['C','D'] then op_:='B';\r
+\r
+\r
+ if reloc and dreloc.use then begin\r
+ dec(war,rel_ofs); reloc:=false;\r
+\r
+ _sizm(byte(war)); \r
+ end;\r
+\r
+ if not(pisz) then begin\r
+\r
+ if ext_used.use and (op_ in ['L','H']) then\r
+ case op_ of\r
+ 'L': t_ext[ext_idx-1].typ:='<';\r
+ 'H': begin t_ext[ext_idx-1].typ:='>'; t_ext[ext_idx-1].lsb:=byte(war) end;\r
+ end;\r
+\r
+ war:=wartosc(old,war,op_);\r
+ save_dta(cardinal(war),tmp,op_,invers);\r
+ end else\r
+ branch:=true; // jesli PISZ=TRUE to nie ma relokowalnosci\r
+\r
+ ciag:=false;\r
+ end;\r
+\r
+ omin_spacje(i,a);\r
+ end;\r
+\r
+ vector:=false; dta_used:=false;\r
+end;\r
+\r
+\r
+function value_code(var a: Int64; var old: string; const test:Boolean): char;\r
+(*----------------------------------------------------------------------------*)\r
+(* przedstawiamy wartosc w postaci kodu literowego 'Z', 'Q', 'T' , 'D' *)\r
+(* kody literowe symbolizuja typ wartosci BYTE, WORD, LONG, DWORD *)\r
+(*----------------------------------------------------------------------------*)\r
+var x: cardinal;\r
+begin\r
+ Result:='D';\r
+\r
+ x:=cardinal( abs(a) );\r
+\r
+ case x of\r
+ 0..$FF: Result:='Z';\r
+ $100..$FFFF: Result:='Q';\r
+ $10000..$FFFFFF: if test then Result:='T' else blad(old,14);\r
+// $1000000..$FFFFFFFF: Result:='D';\r
+ else\r
+ if not(test) then blad(old,0);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure reg_size(const i:byte; const a:Boolean);\r
+(*----------------------------------------------------------------------------*)\r
+(* nowe rozmiary rejestrow dla operacji sledzenia SEP, REP *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+\r
+ if i in [$10,$30] then begin regX:=a; regY:=a end;\r
+ if i in [$20,$30] then regA:=a;\r
+\r
+end;\r
+\r
+\r
+procedure test_reg_size(var a:string; const b:Boolean; const i:byte);\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy rozmiar rejestrow dla wlaczonej opcji sledzenia SEP, REP *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+\r
+ if b then begin\r
+ if i>2 then blad(a,63);\r
+ end else\r
+ if i<3 then blad(a,63);\r
+\r
+end;\r
+\r
+\r
+function macro_rept_if_test: Boolean;\r
+begin\r
+ Result := (not(rept) and if_test)\r
+end;\r
+\r
+\r
+procedure test_siz(var a:string; var siz:Char; const x:Char; var pomin:Boolean);\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy identyfikator rozmiaru *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ if siz in [' ',x] then siz:=x else blad(a,14);\r
+\r
+ pomin:=true;\r
+end;\r
+\r
+\r
+function adr_label(const n: byte; const tst:Boolean): cardinal;\r
+(*----------------------------------------------------------------------------*)\r
+(* szukamy wartosci dla etykiety o nazwie z MADS_STACK[N], jesli nie zostaly *)\r
+(* zdefiniowane etykiety z MADS_STACK wowczas przypisujemy im wartosci *)\r
+(* z MADS_STACK_DEFAULT[N] *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+ txt: string;\r
+\r
+const\r
+ mads_stack_default: array [0..2] of cardinal = ($fe, $0500, $0600);\r
+\r
+begin\r
+ Result:=0;\r
+\r
+ txt:=mads_stack[n]; i:=load_lab(txt,false);\r
+\r
+ if tst then\r
+ if i<0 then begin\r
+ Result:=mads_stack_default[n]; // brak deklaracji dla etykiety z TXT\r
+\r
+ s_lab(txt,Result,bank,txt,'@');\r
+ end;\r
+\r
+ if i>=0 then Result:=t_lab[i].adr; // odczytujemy wartosc etykiety\r
+end;\r
+\r
+\r
+procedure test_skipa;\r
+begin\r
+\r
+ if t_bck[1]=adres then exit;\r
+\r
+ t_bck[0] := t_bck[1];\r
+ t_bck[1] := adres;\r
+\r
+ if skip.use then begin\r
+\r
+ t_skp[skip.idx] := adres;\r
+\r
+ inc(skip.idx);\r
+\r
+ if skip.idx>High(t_skp) then SetLength(t_skp,skip.idx+1);\r
+\r
+ inc(skip.cnt);\r
+ if skip.cnt>1 then begin\r
+ skip.use := false;\r
+ skip.xsm := false;\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure addResult(var hlp, Res: int5);\r
+var i: integer;\r
+begin\r
+ for i:=0 to hlp.l-1 do Res.h[Res.l+i]:=hlp.h[i];\r
+ inc(Res.l, hlp.l);\r
+end;\r
+\r
+\r
+function asm_mnemo(var txt, old:string): int5;\r
+var i: integer;\r
+begin\r
+ i:=1; Result:=oblicz_mnemonik__(i,txt, old);\r
+\r
+ inc(adres, Result.l);\r
+end;\r
+\r
+\r
+function moveAXY(var mnemo,zm,zm2, old: string): int5;\r
+var tmp: string;\r
+ hlp: int5;\r
+ r: byte;\r
+ v: integer;\r
+begin\r
+\r
+ mnemo[1]:='L'; mnemo[2]:='D'; // LD?\r
+ tmp:=mnemo + #32 + zm;\r
+ Result:=asm_mnemo(tmp,old);\r
+\r
+ if regAXY_opty and not(dreloc.use) and not(dreloc.sdx) then\r
+ if zm[1] in ['#','<','>'] then begin\r
+\r
+ v:=Result.h[1];\r
+\r
+ case mnemo[3] of\r
+ 'A': r := 0;\r
+ 'X': r := 1;\r
+// 'Y': r := 2;\r
+ else\r
+ r:=2;\r
+ end;\r
+\r
+ if regOpty.use then\r
+ if regOpty.reg[r]=v then Result.l:=0;\r
+\r
+ regOpty.reg[r]:=v;\r
+ end;\r
+\r
+\r
+ mnemo[1]:='S'; mnemo[2]:='T'; // ST?\r
+ tmp:=mnemo + #32 + zm2;\r
+ hlp:=asm_mnemo(tmp,old);\r
+\r
+ addResult(hlp, Result);\r
+\r
+ Result.tmp:=hlp.h[0];\r
+end;\r
+\r
+\r
+function adrMode(var a: string): byte;\r
+begin\r
+\r
+ Result:=fCRC16(a);\r
+\r
+ if Result in [$60..$7e] then\r
+ dec(Result,$60)\r
+ else\r
+ Result:=0;\r
+\r
+end;\r
+\r
+\r
+procedure save_fake_label(var ety,old:string; const tst:cardinal);\r
+var war: integer;\r
+begin\r
+\r
+ war:=load_lab(ety,false); // uaktualniamy wartosc etykiety\r
+\r
+ if war<0 then\r
+ s_lab(ety,tst,bank,old,ety[1])\r
+ else\r
+ t_lab[war].adr:=tst;\r
+\r
+end;\r
+\r
+\r
+procedure __next(var i:integer; var zm:string);\r
+begin\r
+ omin_spacje(i,zm);\r
+ if zm[i]=',' then __inc(i,zm);\r
+ omin_spacje(i,zm);\r
+end;\r
+\r
+\r
+procedure get_parameters(var j:integer; var str:string; var par:_strArray; const mae:Boolean; const sep1,sep2: char);\r
+(*----------------------------------------------------------------------------*)\r
+(* jesli wystepuje znak '=' to omijamy spacje sprzed i zza znaku '=' *)\r
+(* zapamietamy wszystkie etykiety (parametry) w tablicy dynamicznej *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+ i: integer;\r
+begin\r
+\r
+ SetLength(par,1);\r
+\r
+ if str='' then exit;\r
+\r
+ omin_spacje(j,str);\r
+\r
+ while not(test_char(j,str, sep1,sep2)) do begin\r
+\r
+ txt:=get_dat(j,str,',',true); // TRUE - konczy gdy napotka biala spacje\r
+\r
+ i:=length(txt); // wyjatek jesli odczytal ciag znakow zakonczony\r
+ // znakiem '=', np. 'label='\r
+ if i>0 then\r
+ if txt[i]='=' then begin\r
+ SetLength(txt, i-1);\r
+ dec(j);\r
+ end;\r
+\r
+\r
+ i := j;\r
+\r
+ omin_spacje(j,str);\r
+\r
+ if str[j]='=' then begin // '=' nowa wartosc dla etykiety\r
+ __inc(j,str);\r
+ txt:=txt+'=';\r
+ txt:=txt+get_dat(j,str,',',true);\r
+ end else\r
+ j := i; // jesli nie odczytal znaku '='\r
+\r
+\r
+ // if txt<>'' then begin // !!! inaczej nie bedzie pomijal parametrow PROC !!!\r
+ // np. proc_label ,1\r
+ i:=High(par);\r
+\r
+ par[i]:=txt;\r
+\r
+ SetLength(par,i+2);\r
+\r
+ // end;\r
+\r
+\r
+ if str[j] in [',',' ',#9] then\r
+ __next(j,str)\r
+ else\r
+ if mae and test_char(j,str,#0,#0) then Break;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function TypeToByte(const a: char): byte;\r
+begin\r
+\r
+ case a of\r
+ 'B': Result := 1;\r
+ 'W': Result := 2;\r
+ 'L': Result := 3;\r
+ 'D': Result := 4;\r
+ else\r
+ Result := 0;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function ValueToType(const a: Int64): byte;\r
+begin\r
+\r
+ case abs(a) of\r
+ 0..$FF: Result:=1;\r
+ $100..$FFFF: Result:=2;\r
+ $10000..$FFFFFF: Result:=3;\r
+ else\r
+ Result:=4\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function getByte(var pom: string; const ile: byte; const ch: Char): string;\r
+begin\r
+\r
+ Result:='';\r
+\r
+ case ch of\r
+ 'W': case ile of\r
+ 2: pom[1]:='>';\r
+ 1: pom[1]:='<';\r
+ end;\r
+\r
+ 'L': case ile of\r
+ 3: pom[1]:='^';\r
+ 2: pom[1]:='>';\r
+ 1: pom[1]:='<';\r
+ end;\r
+\r
+ 'D': case ile of\r
+ 4: Result:='>>24';\r
+ 3: pom[1]:='^';\r
+ 2: pom[1]:='>';\r
+ 1: pom[1]:='<';\r
+ end;\r
+ end;\r
+ \r
+end;\r
+\r
+\r
+function oblicz_mnemonik(var i:integer; var a,old:string): int5;\r
+(*----------------------------------------------------------------------------*)\r
+(* funkcja zwraca wartosc typu INT5 *)\r
+(* INT5.L -> liczba bajtow *)\r
+(* INT5.H -> kod maszynowy mnemonika, ARGUMENTY *)\r
+(*----------------------------------------------------------------------------*)\r
+var j, m, idx, len: integer;\r
+ op_, mnemo, mnemo_tmp, zm, tmp, str, pom, add: string;\r
+ war, war_roz, help: Int64;\r
+ code, ile, k, byt: byte;\r
+ op, siz: char;\r
+ test, zwieksz, incdec, mvnmvp, mSEP, mREP, pomin, opty, isvar: Boolean;\r
+ branch_run: Boolean;\r
+ tryb: cardinal;\r
+ hlp: int5;\r
+ par: _strArray;\r
+\r
+const\r
+ maska: array [1..23] of cardinal=(\r
+ $01,$02,$04,$08,$10,$20,$40,$80,$100,$200,$400,$800,$1000,$2000,\r
+ $4000,$8000,$10000,$20000,$40000,$80000,$100000,$200000,$400000);\r
+\r
+ addycja: array [1..24] of byte=(\r
+ 0,0,4,8,8,12,16,20,20,24,28,44,0,0,8,4,8,16,20,24,24,32,32,32);\r
+\r
+ addycja_16: array [1..207] of byte=(\r
+ 0,0,0,2,2,4,6,8,8,12,14,16,17,18,20,20,22,24,28,30,32,34,48,\r
+ 0,0,0,2,2,8,6,4,8,16,14,16,17,18,24,24,22,32,32,30,32,34,48,\r
+ 0,0,0,0,0,0,0,0,0,0,2,0,0,0,0,0,0,0,0,0,0,0,220,\r
+ 0,0,0,0,0,0,0,0,0,0,16,0,0,0,0,0,0,0,0,0,32,144,48,\r
+ 0,0,0,0,0,0,0,101,0,8,0,0,0,0,16,0,0,0,24,0,0,0,0,\r
+ 0,0,0,0,0,0,0,0,0,56,0,0,0,0,16,0,0,0,58,0,0,0,0,\r
+ 0,0,0,0,0,0,0,146,0,0,0,0,114,0,0,0,0,0,0,0,0,0,0,\r
+ 0,0,0,0,0,140,0,0,0,148,0,0,0,0,156,0,0,0,164,0,0,0,0,\r
+ 0,0,0,0,0,204,0,0,0,212,0,0,0,0,220,0,0,0,228,0,0,0,0);\r
+\r
+ // kod maszynowy mnemonika w pierwszej adresacji (CPU 6502)\r
+ kod: array [0..55] of byte=(\r
+ $A1,$9E,$9C,$81,$82,$80,$61,$21,\r
+ $02,$E1,$14,$40,$42,$01,$C1,$BC,\r
+ $DC,$C2,$E2,$41,$22,$62,$00,$18,\r
+ $58,$B8,$D8,$08,$28,$48,$68,$40,\r
+ $60,$38,$78,$F8,$C8,$E8,$88,$CA,\r
+ $8A,$98,$9A,$A8,$AA,$BA,$EA,$10,\r
+ $30,$D0,$90,$B0,$F0,$50,$70,$20);\r
+\r
+ // kod maszynowy mnemonika w pierwszej adresacji (CPU 65816)\r
+ kod_16: array [0..91] of byte=(\r
+ $A1,$9E,$9C,$81,$82,$80,$61,$21,\r
+ $02,$E1,$20,$4C,$42,$01,$C1,$BC,\r
+ $DC,$3A,$1A,$41,$22,$62,$00,$18,\r
+ $58,$B8,$D8,$08,$28,$48,$68,$40,\r
+ $60,$38,$78,$F8,$C8,$E8,$88,$CA,\r
+ $8A,$98,$9A,$A8,$AA,$BA,$EA,$10,\r
+ $30,$D0,$90,$B0,$F0,$50,$70,$24,\r
+ $64,$DE,$BE,$10,$00,$80,$FE,$54,\r
+ $44,$62,$8B,$0B,$4B,$DA,$5A,$AB,\r
+ $2B,$FA,$7A,$6B,$DB,$5B,$1B,$7B,\r
+ $3B,$9B,$BB,$CB,$42,$EB,$FB,$3A,\r
+ $1A,$14,$4E,$80);\r
+\r
+ // mozliwe adresacje rozkazu (10 bitow) CPU6502\r
+ // bity w najstarszym bajcie oznaczaja przesuniecie w tablicy 'ADDYCJA'\r
+ ads: array [0..55] of cardinal=(\r
+ $000006ED,$8000032C,$800004AC,$000006E5,$00000124,$000000A4,$000006ED,$000006ED,\r
+ $000004B4,$000006ED,$00000020,$00000820,$000004B4,$000006ED,$000006ED,$8000002C,\r
+ $8000002C,$000004A4,$000004A4,$000006ED,$000004B4,$000004B4,$00000000,$00000000,\r
+ $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,\r
+ $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,\r
+ $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000002,\r
+ $00000002,$00000002,$00000002,$00000002,$00000002,$00000002,$00000002,$00000024);\r
+\r
+ // mozliwe adresacje rozkazu (32 bity) CPU65816\r
+ // bity w najstarszym bajcie oznaczaja przesuniecie w tablicy 'ADDYCJA_16'\r
+ ads_16: array [0..91] of cardinal=(\r
+ $000F7EE9,$800282A0,$800442A0,$000F7E69,$00008220,$00004220,$000F7EE9,$000F7EE9,\r
+ $00044320,$000F7EE9,$40400600,$20700600,$00044320,$000F7EE9,$000F7EE9,$800002A0,\r
+ $800002A0,$02044320,$01044320,$000F7EE9,$00044320,$00044320,$00000000,$00000000,\r
+ $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,\r
+ $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,\r
+ $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000002,\r
+ $00000002,$00000002,$00000002,$00000002,$00000002,$00000002,$00000002,$100442A0,\r
+ $08044220,$80000080,$80000080,$00000220,$00000220,$00000012,$80000080,$00000004,\r
+ $00000004,$04001090,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,\r
+ $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,\r
+ $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,\r
+ $00000000,$00000400,$00000400,$00000010);\r
+\r
+begin\r
+ Result.l:=0;\r
+ \r
+ if a='' then blad(old,12);\r
+\r
+ op_:=''; siz:=' '; op:=' ';\r
+\r
+ war_roz:=0;\r
+\r
+ mvnmvp:=true; mSEP:=false; mREP:=false; pomin:=false; ext_used.use:=false;\r
+\r
+ zwieksz:=false; incdec:=false; reloc:=false; branch:=false; mne_used:=false;\r
+\r
+ omin_spacje(i,a);\r
+\r
+ m:=i; // zapamietaj pozycje\r
+\r
+// pobierz nazwe rozkazu, oblicz jego CRC16\r
+ mnemo:=''; mnemo_tmp:='';\r
+\r
+ if _lab_first(a[i]) then\r
+ while _lab(a[i]) or (a[i] in [':','%']) do begin\r
+ mnemo:=mnemo+UpCase(a[i]);\r
+ mnemo_tmp:=mnemo_tmp+UpCas_(a[i]);\r
+ inc(i);\r
+ end;\r
+\r
+\r
+ // asemblujemy procedury .PROC do ktorych wystapilo odwolanie w programie\r
+ // przelacznik -x 'Exclude unreferenced procedures' musi byc uaktywniony\r
+ if exclude_proc then\r
+ if proc and (pass>0) then\r
+ if not(t_prc[proc_nr-1].use) then begin\r
+\r
+ if VerifyProc then begin\r
+\r
+ exProcTest := false;\r
+ exclude_proc:= false;\r
+\r
+ Result:=oblicz_mnemonik(m,a,old); // dodatkowy test linii gdy EXCLUDE_PROC:=FALSE\r
+\r
+ if Result.l<__equ then Result.l:=0;\r
+\r
+ exProcTest := true;\r
+ exclude_proc:= true;\r
+\r
+ i:=m;\r
+ end;\r
+\r
+ exit;\r
+ end;\r
+\r
+\r
+ // jesli czytamy tablice ARRAY to linia zaczyna sie znakiem '(' lub '['\r
+ // jesli innym niz znaki konca linii to blad 'Improper syntax'\r
+ if aray then begin\r
+ Result.l:=__array_run; i:=1; exit\r
+ end;\r
+\r
+\r
+ // jesli brakuje mnemonika to sprawdz czy nie jest to cyfra (blad 'Illegal instruction')\r
+ // w innym przypadku nie przetwarzamy tego i wychodzimy\r
+ if mnemo='' then\r
+ if _dec(a[i]) or (a[i] in ['$','%']) then\r
+ blad(old,12)\r
+ else\r
+ exit;\r
+\r
+\r
+ // wyjatek znak '=' jest rownowazny 'EQU'\r
+ // dla etykiety zaczynajacej sie od pierwszego znaku w wierszu\r
+ if mnemo='=' then begin Result.l:=__equ; exit end;\r
+\r
+\r
+ // jesli wystepuje znak ':' tzn ze laczymy mnemoniki w stylu XASM'a\r
+ j:=pos(':',mnemo);\r
+ if j>0 then begin\r
+ Result.i:=i;\r
+ i:=m; // modyfikujemy wartosc spod adresu 'i'\r
+ Result.l:=__xasm;\r
+ exit;\r
+ end;\r
+\r
+\r
+// sprawdz czy to operacja przypisania '=' , 'EQU' , '+=' , '-=' , '++' , '--'\r
+// dla etykiety poprzedzonej minimum jedna spacja lub tabulatorem\r
+\r
+ j:=i;\r
+\r
+ omin_spacje(i,a);\r
+\r
+ tmp:='';\r
+\r
+ if UpCase(a[i])='E' then begin\r
+ tmp:=get_datUp(i,a,#0,false);\r
+ k:=fASC(tmp);\r
+ end else begin\r
+\r
+ while a[i] in ['=','+','-'] do begin\r
+ tmp:=tmp+a[i];\r
+ if a[i]='=' then Break;\r
+ __inc(i,a);\r
+ end;\r
+\r
+ k:=fCRC16(tmp);\r
+\r
+ end;\r
+\r
+// if (tmp='EQU') or (tmp='=') or (tmp='+=') or (tmp='-=') or (tmp='++') or (tmp='--') then begin\r
+ if k in [__equ+1, __nill] then begin\r
+ i:=m; // modyfikujemy wartosc spod adresu 'i'\r
+ Result.l:=__addEqu;\r
+ exit;\r
+ end;\r
+\r
+\r
+ i:=j;\r
+\r
+\r
+ len:=length(mnemo);\r
+\r
+\r
+// sprawdz czy wystapilo rozszerzenie mnemonika\r
+ if len=5 then\r
+ if a[i-2]='.' then\r
+ case UpCase(a[i-1]) of\r
+ 'A','W','Q': siz:='Q';\r
+ 'B','Z': siz:='Z';\r
+ 'L','T': siz:='T';\r
+ end;\r
+\r
+\r
+// poszukaj mnemonika w tablicy HASH\r
+ k:=0;\r
+\r
+ if len=3 then\r
+ k:=fASC(mnemo)\r
+ else\r
+ if siz<>' ' then begin // jesli SIZ<>' ' tzn ze jest to 3-literowy mnemonik z rozszerzeniem\r
+\r
+ k:=fASC(mnemo);\r
+\r
+ if k>0 then SetLength(mnemo,3); // jesli taki mnemonik istnieje to OK,\r
+ // !!! w przeciwnym wypadku zapewne jest to jakies makro !!!\r
+ end;\r
+\r
+\r
+ if not(opt and 16>0) then\r
+ if k in [57..92] then k:=0; // symbole mnemonikow maja kody <1..91>\r
+ // symbole mnemonikow 6502 <1..56>\r
+ // symbole mnemonikow 65816 <57..92>\r
+\r
+// w IDX przechowujemy aktualny adres asemblacji, tej zmiennej nie uzyjemy w innym celu\r
+\r
+if k in [__cpbcpd..__jskip] then begin\r
+\r
+ if adres<0 then\r
+ if pass=pass_end then blad(old,10);\r
+\r
+ if siz<>' ' then blad(old,33);\r
+\r
+ if not(k in [__BckSkp, __phrplr]) then begin // __BckSkp i __phrplr nie potrzebuja parametrow\r
+\r
+ omin_spacje(i,a);\r
+\r
+ SetLength(par, 1);\r
+ \r
+ while not(test_char(i,a,#0,#0)) do begin\r
+\r
+ idx:=High(par);\r
+\r
+ par[idx]:=get_dat(i,a,' ',true);\r
+\r
+ //if par[idx][1] in ['<','>'] then insert('#',par[idx],1); // !!! zaremowac !!! bo zle liczy "mva >$e000+3 $80" \r
+\r
+ SetLength(par, idx+2);\r
+\r
+ omin_spacje(i,a);\r
+ end;\r
+\r
+ tmp:=par[0];\r
+ end;\r
+\r
+ idx := adres;\r
+\r
+ Result.l:=0;\r
+\r
+\r
+ case k of\r
+\r
+// obsluga PHR, PLR\r
+ __phrplr:\r
+ begin\r
+\r
+ Result.l:=5;\r
+\r
+ if mnemo[2]='H' then begin\r
+ Result.h[0]:=$48;\r
+ Result.h[1]:=$8a;\r
+ Result.h[2]:=$48;\r
+ Result.h[3]:=$98;\r
+ Result.h[4]:=$48;\r
+ end else begin\r
+ Result.h[0]:=$68;\r
+ Result.h[1]:=$a8;\r
+ Result.h[2]:=$68;\r
+ Result.h[3]:=$aa;\r
+ Result.h[4]:=$68;\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+// obsluga INW, INL, IND, DEW, DEL, DED\r
+ __inwdew:\r
+ begin\r
+\r
+ if High(par)<1 then blad(old,23);\r
+\r
+ Result.l:=0;\r
+\r
+ ile:=TypeToByte(mnemo[3]);\r
+\r
+ mnemo[3]:='C';\r
+\r
+\r
+ if mnemo[1]='I' then begin // INW, INL, IND\r
+\r
+ str:='##INC#DEC'+IntToStr(ora_nr);\r
+\r
+ j:=load_lab(str,false); // odczytujemy wartosc etykiety\r
+\r
+ if j>=0 then\r
+ tryb:=t_lab[j].adr\r
+ else\r
+ tryb:=0;\r
+\r
+ j:=0;\r
+\r
+ while ile>0 do begin\r
+ zm:=mnemo + #32 + tmp + '+' + IntToStr(j);\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ if ile>1 then begin\r
+ zm:='BNE '+IntToStr(tryb);\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+ end;\r
+\r
+ inc(j);\r
+ dec(ile);\r
+ end;\r
+\r
+ save_fake_label(str,old, adres);\r
+\r
+ inc(ora_nr);\r
+\r
+ end else begin // DEW, DEL, DED\r
+\r
+ byt:=0;\r
+\r
+ while byt<ile-1 do begin\r
+\r
+ zm:='LDA ' + tmp + '+' + IntToStr(byt);\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ str:='##INC#DEC'+IntToStr(Int64(ora_nr)+byt);\r
+\r
+ j:=load_lab(str,false); // odczytujemy wartosc etykiety\r
+\r
+ if j>=0 then\r
+ tryb:=t_lab[j].adr\r
+ else\r
+ tryb:=0;\r
+\r
+ zm:='BNE '+IntToStr(tryb);\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ inc(byt);\r
+ end;\r
+\r
+ inc(byt);\r
+\r
+ while byt<>0 do begin\r
+\r
+ if byt<>ile then begin\r
+ str:='##INC#DEC'+IntToStr(Int64(ora_nr)+byt-1);\r
+ save_fake_label(str,old, adres);\r
+ end;\r
+\r
+ zm:='DEC ' + tmp + '+' + IntToStr(Int64(byt)-1);\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ dec(byt);\r
+ end;\r
+\r
+ inc(ora_nr, ile-1);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+// obsluga ADW, SBW\r
+ __adwsbw:\r
+ begin\r
+ if High(par)<2 then blad(old,23);\r
+\r
+ str:=par[1];\r
+ pom:=par[2];\r
+\r
+ test:=false;\r
+ if pom='' then\r
+ pom:=tmp // w POM wynik operacji\r
+ else\r
+ test:=true;\r
+\r
+ if tmp[1]='#' then blad(old,14);\r
+\r
+ mnemo[3] := 'C'; // ADC, SBC\r
+\r
+ if mnemo[1]='S' then\r
+ zm:='SEC'\r
+ else\r
+ zm:='CLC';\r
+\r
+ Result:=asm_mnemo(zm,old);\r
+\r
+ zm:='LDA ' + tmp;\r
+\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ ile:=hlp.h[0];\r
+\r
+ opty:=false;\r
+ if ile=$B1 then opty:=true; // wystepuje LDA(),Y\r
+\r
+\r
+ if not(ile in [$A5,$AD,$B5,$BD]) then\r
+ test:=true; // nie przejdzie krotsza wersja z SCC, SCS\r
+\r
+\r
+ if str[1]='#' then begin\r
+ str[1]:='+';\r
+ branch:=true; // nie relokujemy, testujemy tylko wartosc\r
+ war:=oblicz_wartosc(str,old);\r
+ wartosc(old,war,'A');\r
+\r
+ str[1]:='<';\r
+ zm:=mnemo + #32 + str;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ zm:='STA '+pom;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ if not(test) and (war<256) then begin\r
+\r
+ if mnemo[1]='S' then\r
+ zm:='SCS'\r
+ else\r
+ zm:='SCC';\r
+\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ test_skipa;\r
+\r
+ if mnemo[1]='S' then\r
+ zm:='DEC ' + tmp + '+1'\r
+ else\r
+ zm:='INC ' + tmp + '+1';\r
+\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ end else begin\r
+\r
+ if opty then begin\r
+\r
+ zm:='iny'; // tylko w ten sposob przez ASM_MNEMO\r
+ hlp:=asm_mnemo(zm, old); // inaczej nie bedzie relokowalnosci\r
+ addResult(hlp,Result);\r
+\r
+{ hlp.l:=1;\r
+ hlp.h[0]:=$c8; // $C8 = INY\r
+ addResult(hlp,Result);}\r
+\r
+ add:='';\r
+ end else\r
+ add:='+1';\r
+\r
+ zm:='LDA ' + tmp + add;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ str[1]:='>';\r
+ zm:=mnemo + #32 + str;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ zm:='STA ' + pom + add;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+ end;\r
+\r
+ end else begin\r
+ zm:=mnemo + #32 + str;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ byt:=hlp.h[0];\r
+\r
+ zm:='STA ' + pom;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ if opty then begin\r
+\r
+ zm:='iny';\r
+ hlp:=asm_mnemo(zm, old);\r
+ addResult(hlp,Result);\r
+ \r
+{ hlp.l:=1;\r
+ hlp.h[0]:=$c8; // $C8 = INY\r
+ addResult(hlp,Result);}\r
+\r
+ add:='';\r
+ end else\r
+ add:='+1';\r
+\r
+ \r
+ if byt in [$71,$F1] then begin // $71 = ADC(),Y ; $F1 = SBC(),Y\r
+\r
+ if not(opty) then begin\r
+\r
+ zm:='iny';\r
+ hlp:=asm_mnemo(zm, old);\r
+ addResult(hlp,Result);\r
+\r
+{ hlp.l:=1;\r
+ hlp.h[0]:=$c8; // $C8 = INY\r
+ addResult(hlp,Result);}\r
+\r
+ if (ile in [$b6,$b9,$be]) then add:='';\r
+ end;\r
+\r
+ end else\r
+ if not(opty and (byt=$79)) then str:=str+'+1';\r
+\r
+ zm:='LDA ' + tmp + add;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ zm:=mnemo + #32 + str;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ zm:='STA ' + pom + add;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+ end;\r
+\r
+\r
+ case pom[length(pom)] of\r
+ '+': zm:='iny';\r
+ '-': zm:='dey';\r
+ else\r
+ zm:='';\r
+ end;\r
+\r
+ if zm<>'' then begin\r
+ hlp:=asm_mnemo(zm, old);\r
+ addResult(hlp,Result);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+// obsluga ADB, SBB\r
+ __adbsbb:\r
+ begin\r
+ if High(par)<2 then blad(old,23);\r
+\r
+ str:=par[1];\r
+ pom:=par[2];\r
+\r
+ Result.l:=0;\r
+\r
+ if pom='' then begin\r
+ pom:=tmp;\r
+\r
+ if tmp[1]='#' then\r
+ if str[1]<>'#' then pom:=str;\r
+\r
+ end;\r
+\r
+ if tmp<>'@' then begin\r
+ zm:='LDA ' + tmp;\r
+ Result:=asm_mnemo(zm,old);\r
+ end;\r
+ \r
+ if mnemo[1]='S' then\r
+ zm:='SUB '\r
+ else\r
+ zm:='ADD ';\r
+\r
+ zm:=zm + str;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+\r
+ if pom<>'@' then begin\r
+ zm:='STA ' + pom;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+ end;\r
+ end;\r
+\r
+ \r
+// obsluga ADD, SUB\r
+ __addsub:\r
+ begin\r
+\r
+ if High(par)<1 then blad(old,23);\r
+\r
+ inc(adres);\r
+\r
+ mnemo[2]:=mnemo[3];\r
+ mnemo[3]:='C';\r
+ Result.l:=1;\r
+\r
+ if mnemo[1]='A' then\r
+ Result.h[0]:=$18 // kod dla CLC\r
+ else\r
+ Result.h[0]:=$38; // kod dla SEC\r
+\r
+ zm:=mnemo + #32 + tmp;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+ end;\r
+\r
+\r
+// obsluga MVA, MVX, MVY, MWA, MWX, MWY\r
+ __movaxy:\r
+ begin\r
+\r
+ if High(par)<2 then blad(old,23);\r
+ \r
+ zm:=par[1];\r
+\r
+ op:=tmp[1];\r
+ Result.l:=0;\r
+\r
+ opty:=false;\r
+\r
+ if op='#' then regOpty.blk:=true; // wlaczamy przetwarzanie makro-rozkazow MW?#, MV?#\r
+\r
+ \r
+ if mnemo[2]='W' then begin // MW?\r
+\r
+ if op='#' then begin\r
+\r
+ variable:=false; // domyslnie VARIABLE=FALSE, czyli nie jest to zmienna\r
+\r
+ tmp[1]:='+';\r
+ branch:=true; // nie relokujemy, testujemy tylko wartosc\r
+ war:=oblicz_wartosc(tmp,old);\r
+ wartosc(old,war,'A');\r
+\r
+// if not(dreloc.use) and not(dreloc.sdx) then\r
+ if not(variable) then // jesli nie jest to zmienna to testujemy dalej\r
+ if byte(war)=byte(war shr 8) then opty:=true;\r
+\r
+ tmp[1]:='<';\r
+ end;\r
+\r
+ Result:=moveAXY(mnemo,tmp,zm,old);\r
+ \r
+ test:=false;\r
+\r
+\r
+ if not(opty) then\r
+ if op='#' then\r
+ tmp[1]:='>'\r
+ else // wyj¹tek MWA (ZP),Y ADR\r
+ if Result.h[0]<>$B1 then begin // $B1 = LDA(ZP),Y\r
+\r
+ if Result.tmp=$91 then begin\r
+ if not(Result.h[0] in [$b6,$b9,$be]) then tmp:=tmp+'+1';\r
+ end else\r
+ tmp:=tmp+'+1';\r
+\r
+ end else begin // $C8 = INY\r
+\r
+ if Result.h[Result.l-1]<>$c8 then begin\r
+ pom:='iny'; // tylko w ten sposob przez ASM_MNEMO\r
+ hlp:=asm_mnemo(pom, old); // inaczej nie bedzie relokowalnosci\r
+ addResult(hlp,Result);\r
+ end;\r
+\r
+ test:=true;\r
+ end;\r
+\r
+ if Result.tmp=$91 then begin // $91 = STA(ZP),Y\r
+\r
+ if (Result.h[0]<>$B1) and (Result.h[Result.l-1]<>$c8) then begin\r
+ pom:='iny';\r
+ hlp:=asm_mnemo(pom, old);\r
+ addResult(hlp,Result);\r
+ end;\r
+\r
+ end else\r
+ if test then begin // $96 = STX Z,Y\r
+ if not(Result.tmp in [$96,$99]) then zm:=zm+'+1'; // $99 = STA Q,Y\r
+ end else\r
+ zm:=zm+'+1';\r
+\r
+ end;\r
+\r
+\r
+ if opty then begin\r
+\r
+ tmp:=mnemo + #32 + zm;\r
+ hlp:=asm_mnemo(tmp, old);\r
+\r
+ end else\r
+ hlp:=moveAXY(mnemo,tmp,zm,old); // MV?\r
+\r
+\r
+ addResult(hlp,Result);\r
+\r
+ regOpty.blk:=false; // wylaczamy przetwarzanie makro-rozkazow MWA, MVA itp.\r
+ end;\r
+\r
+\r
+// obsluga JEQ, JNE, JPL, JMI, JCC, JCS, JVC, JVS\r
+ __jskip:\r
+ begin\r
+\r
+ mnemo[1]:='B'; // zamieniamy pseudo rozkaz na mnemonik\r
+ k:=fASC(mnemo); // wyliczamy kod dla mnemonika\r
+\r
+ branch:=true; // nie relokujemy\r
+ war:=oblicz_wartosc(tmp,old);\r
+\r
+ test:=false; war:=war-2-adres;\r
+\r
+ if (war<0) and (abs(war)-128>0) then test:=true;\r
+ if (war>0) and (war-127>0) then test:=true;\r
+\r
+\r
+ if not(test) then begin\r
+\r
+ Result.l:=2;\r
+ Result.h[0]:=kod[k-1] {xor $20}; // kod maszynowy mnemonika w pierwszej adresacji 6502\r
+ Result.h[1]:=byte(war);\r
+\r
+ end else begin\r
+\r
+ inc(adres,2);\r
+\r
+ Result.l:=2;\r
+ Result.h[0]:=kod[k-1] xor $20; // kod maszynowy mnemonika w pierwszej adresacji 6502\r
+ Result.h[1]:=3;\r
+\r
+ zm:='JMP ' + tmp;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp,Result);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+// sprawdzamy czy nie sa to pseudo rozkazy skoku\r
+// req, rne, rpl, rmi, rcc, rcs, rvc, rvs -> b?? skok do tylu\r
+// seq, sne, spl, smi, scc, scs, svc, svs -> b?? skok do przodu\r
+\r
+ __BckSkp:\r
+ begin\r
+\r
+ if mnemo[1]='R' then begin\r
+\r
+ if (pass=pass_end) and skip.xsm then warning(99); // Repeating only the last instruction\r
+\r
+ if t_bck[0]<0 then begin\r
+ if pass=pass_end then blad(old,110); // No instruction to repeat\r
+ war:=0;\r
+ end else\r
+ war:=t_bck[0];\r
+\r
+ end else begin\r
+ if skip.idx+1<=High(t_skp) then war:=t_skp[skip.idx+1] else war:=adres;\r
+\r
+ skip.use:=true;\r
+ skip.cnt:=0;\r
+ end;\r
+\r
+ war:=war-2-adres;\r
+\r
+ if (war<0) and (abs(war)-128>0) then war:=abs(war)-128;\r
+ if (war>0) and (war-127>0) then dec(war, 127); //war:=war-127;\r
+\r
+ mnemo[1]:='B'; // zamieniamy pseudo rozkaz na mnemonik\r
+ k:=fASC(mnemo); // wyliczamy kod dla mnemonika\r
+\r
+ code:=kod[k-1]; // kod maszynowy mnemonika w pierwszej adresacji 6502\r
+\r
+ Result.l := 2;\r
+ Result.h[0] := code;\r
+ Result.h[1] := byte(war);\r
+ inc(adres,2);\r
+ end;\r
+\r
+// CPB, CPW, CPL, CPD \r
+ __cpbcpd:\r
+ begin\r
+\r
+ if High(par)<2 then blad(old,23);\r
+\r
+ pom:=par[1];\r
+\r
+ ile:=TypeToByte(mnemo[3]);\r
+\r
+ Result.l:=0;\r
+\r
+\r
+ str:='##CMP#'+IntToStr(ora_nr);\r
+\r
+ j:=load_lab(str,false); // odczytujemy wartosc etykiety\r
+\r
+ if j>=0 then\r
+ tryb:=t_lab[j].adr\r
+ else\r
+ tryb:=0;\r
+\r
+ test := (tmp[1]='#');\r
+ opty := (pom[1]='#');\r
+\r
+\r
+ if (tmp='@') and (ile<>1) then blad(old,58);\r
+\r
+ \r
+ variable:=false; // domyslnie VARIABLE=FALSE, czyli nie jest to zmienna\r
+\r
+ if opty then begin\r
+ pom[1]:='+';\r
+ branch:=true; // nie relokujemy, testujemy tylko wartosc\r
+ war:=oblicz_wartosc(pom,old);\r
+\r
+ pom[1]:='#'; \r
+ end;\r
+\r
+ isvar:=variable or TestWhileOpt;\r
+\r
+\r
+ while ile>0 do begin\r
+\r
+ if test then\r
+ add:=getByte(tmp, ile, mnemo[3])\r
+ else\r
+ add:='+'+IntToStr(Int64(ile)-1);\r
+ \r
+ if tmp<>'@' then begin\r
+ zm:='LDA '+tmp + add;\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+ end;\r
+\r
+\r
+ if opty then\r
+ add:=getByte(pom, ile, mnemo[3])\r
+ else\r
+ add:='+'+IntToStr(Int64(ile)-1);\r
+\r
+\r
+ zm:='CMP '+pom + add;\r
+ hlp:=asm_mnemo(zm,old);\r
+\r
+ if not(isvar) and (hlp.l=2) and (hlp.h[0]=$c9) and (hlp.h[1]=0) then\r
+ dec(adres, 2) // jesli CMP #0 to anuluj\r
+ else\r
+ addResult(hlp, Result);\r
+\r
+\r
+ if ile>1 then begin\r
+ zm:='BNE '+IntToStr(tryb);\r
+ hlp:=asm_mnemo(zm,old);\r
+ addResult(hlp, Result);\r
+ end;\r
+\r
+ dec(ile);\r
+ end;\r
+\r
+ str:='##CMP#'+IntToStr(ora_nr);\r
+ save_fake_label(str,old, adres);\r
+\r
+ TestWhileOpt:=true;\r
+\r
+ inc(ora_nr);\r
+ end;\r
+\r
+ end;\r
+\r
+ adres := idx;\r
+\r
+ regOpty.use := ( k = __movaxy );\r
+\r
+ mne_used := true; // zostal odczytany jakis mnemonik\r
+ exit; // !!! KONIEC !!! zostal odczytany i zdekodowany makro-rozkaz\r
+end;\r
+\r
+\r
+// sprawdz czy to nazwa makra\r
+ if k=0 then begin\r
+\r
+ idx:=load_lab(mnemo_tmp,false); // poszukaj w etykietach\r
+\r
+ if idx<0 then begin\r
+ if pass=pass_end then blad_und(old,mnemo,35);\r
+ exit;\r
+ end;\r
+\r
+ if t_lab[idx].bnk=__id_ext then // symbol external\r
+ if t_extn[t_lab[idx].adr].prc then begin\r
+\r
+ tmp:='##'+t_extn[t_lab[idx].adr].nam;\r
+\r
+ Result.i:=t_lab[l_lab(tmp)].adr;\r
+ Result.l:=__proc_run;\r
+\r
+ exit;\r
+ end;\r
+\r
+\r
+// if (t_lab[idx].bnk=__id_macro) then begin Result.l:=__nill; exit end;\r
+\r
+ if t_lab[idx].bnk>=__id_macro then begin\r
+ Result.l:=byte(t_lab[idx].bnk);\r
+ Result.i:=t_lab[idx].adr;\r
+ end else\r
+ blad_und(old,mnemo,35);\r
+\r
+ exit;\r
+ end;\r
+\r
+\r
+ dec(k); // !!! koniecznie\r
+\r
+\r
+// znalazl pseudo rozkaz\r
+ if k>=__equ then\r
+ if siz<>' ' then\r
+ blad(old,33)\r
+ else begin\r
+ Result.l:=k; exit\r
+ end;\r
+\r
+\r
+ if first_org and (opt and 1>0) then blad(old,10);\r
+\r
+\r
+// jesli nie przetwarzamy makro-rozkazow MWA, MVA itp. to blokujemy optymalizacje rejestrow\r
+ if not(regOpty.blk) then begin\r
+ regOpty.use:=false;\r
+\r
+ regOpty.reg[0]:=-1;\r
+ regOpty.reg[1]:=-1;\r
+ regOpty.reg[2]:=-1;\r
+ end;\r
+\r
+\r
+//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!//\r
+// na podstawie kodu maszynowego CODE mozna juz okreslic jaki to rozkaz //\r
+// nie trzeba porownywac stringow, czy zamieniac mnemonik na wartosc cyfrowa //\r
+// w celu pozniejszego porownania //\r
+//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!//\r
+\r
+ if (opt and 16>0) then begin\r
+ code:=kod_16[k]; // kody maszynowe 65816 sa z przedzialu <0..91>\r
+ tryb:=ads_16[k]; // kod maszynowy mnemonika w pierwszej adresacji 65816\r
+ end else begin\r
+// if k>55 then blad(a,14); // kody maszynowe 6502 sa z przedzialu <0..55>\r
+ code:=kod[k]; // kod maszynowy mnemonika w pierwszej adresacji 6502\r
+ tryb:=ads[k];\r
+ end;\r
+\r
+\r
+// w .STRUCT i .ARRAY nie ma mozliwosci uzywania rozkazow CPU\r
+// podobnie w bloku EMPTY (.ds) nie moga wystepowac rozkazy CPU\r
+ if struct.use or aray or enum.use or empty then blad(old,58);\r
+\r
+\r
+// jesli mnemonik nie wymaga argumentu to skoncz\r
+ if tryb=0 then begin\r
+\r
+ if siz<>' ' then blad(old,33);\r
+\r
+ test_eol(i,a,a,#0);\r
+\r
+ Result.l:=1; Result.h[0]:=code;\r
+\r
+ mne_used := true; // zostal odczytany jakis mnemonik\r
+\r
+ exit;\r
+ end;\r
+\r
+\r
+// omin spacje i przejdz do argumentu\r
+ omin_spacje(i,a);\r
+\r
+// jesli wystepuja operatory #<, #> to omin pierwszy znak i pozostaw <,>\r
+{ if a[i]='#' then begin // jesli odremowac to zle liczy !!! lda #>dl1^>dl2 !!!\r
+ idx:=i; // !!! tak musi zostac !!!\r
+ __inc(i,a); // lda #> nie moze byc tym samym co\r
+ if not(a[i] in ['<','>','^']) then i:=idx; // lda > ta operacja\r
+ end; }\r
+\r
+\r
+ // pobierz operator argumentu do 'OP'\r
+ // nie dotyczy to rozkazow MVN i MVP (65816)\r
+\r
+// tst:=ord(mnemo[1]) shl 16+ord(mnemo[2]) shl 8+ord(mnemo[3]);\r
+\r
+\r
+// if (mnemo<>'MVN') and (mnemo<>'MVP') then begin\r
+// if (tst<>$4D564E) and (tst<>$4D5650) then begin\r
+\r
+ if not(code in [68,84]) then begin\r
+\r
+ mvnmvp:=false;\r
+ if a[i] in ['#','<','>','^'] then begin\r
+ if not(dreloc.use) then branch:=true; // nie relokuj tego rozkazu\r
+ op:=a[i]; inc(i)\r
+ end else op:=' ';\r
+\r
+ if (a[i]='@') and (_eol(a[i+1])) then begin op:='@'; inc(i) end;\r
+\r
+ if (op='@') then\r
+ if (siz<>' ') then blad(old,33) else test_eol(i,a,a,#0);\r
+ end;\r
+\r
+ omin_spacje(i,a);\r
+\r
+ // wyjatki dla ktorych rozmiar rejestru jest staly\r
+ if (opt and 16>0) and (op='#') then\r
+ case code of\r
+ 98: test_siz(a,siz,'Q',pomin); // PEA #Q\r
+ 254: test_siz(a,siz,'Z',pomin); // COP #Z\r
+ 190: begin test_siz(a,siz,'Z',pomin); mREP:=true end; // REP #Z\r
+ 222: begin test_siz(a,siz,'Z',pomin); mSEP:=true end; // SEP #Z\r
+ end;\r
+\r
+\r
+ zm:=get_dat_noSPC(i,a,';',#0,old);\r
+\r
+ tmp:='';\r
+ \r
+ // jesli brak argumentu przyjmij domyslnie aktualny adres '*'\r
+ // lub operator '@' gdy ASL , ROL , LSR , ROR\r
+ // lub operator '@' dla INC, DEC gdy CPU=65816\r
+ if (zm='') and (op=' ') then begin\r
+\r
+ if (code in [2,34,66,98]) or ((opt and 16>0) and (code in [26,58])) then\r
+ op:='@'\r
+ else begin\r
+ zm:='*';\r
+ if not(klamra_used) then\r
+ if pass=0 then blad(old,23); // 'Default addressing mode' -67- wycofany\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+// jesli jest nawias otwierajacy '(' lub '[' to sprawdz poprawnosc\r
+// i czy nie ma miedzy nimi spacji\r
+ if zm<>'' then begin\r
+ j:=1;\r
+\r
+ if (op=' ') and (zm[1] in ['[','(']) then begin\r
+\r
+ tmp:=get_dat_noSPC(j,zm,',',#0,a);\r
+ \r
+\r
+ if length(tmp)=2 then blad(old,14); // nie bylo argumentu pomiedzy nawiasami\r
+\r
+ // jesli po nawiasie wystapi znak inny niz ',',' ',#0 to BLAD\r
+\r
+ omin_spacje(j,zm);\r
+\r
+ test_eol(j,zm,a,',');\r
+\r
+ // przepisz znak nastepujacy po ',' do 'OP_'\r
+ if zm[j]=',' then begin\r
+\r
+ __inc(j,zm);\r
+\r
+ if test_param(j,zm) then begin Result.l:=__nill; exit end else\r
+ if UpCase(zm[j]) in ['X','Y','S'] then begin\r
+ op_:=op_+UpCase(zm[j]); //zm[j]:=' ';\r
+\r
+ if zm[j+1] in ['+','-'] then begin\r
+\r
+ if UpCase(zm[j])='S' then blad(old,4); // + - nie moze byc dla 'S'\r
+\r
+ incdec:=true;\r
+\r
+ case zm[j+1] of\r
+ '-': //war_roz:=oblicz_wartosc('{de'+zm[j]+'}',a);\r
+ if UpCase(zm[j])='X' then war_roz:=$CA else war_roz:=$88; // dex, dey\r
+ '+': //war_roz:=oblicz_wartosc('{in'+zm[j]+'}',a);\r
+ if UpCase(zm[j])='X' then war_roz:=$E8 else war_roz:=$C8; // inx, iny\r
+ end;\r
+\r
+ test_eol(j+2,zm,a,#0);\r
+ end else test_eol(j+1,zm,a,#0);\r
+\r
+ end else blad(old,14);\r
+ end;\r
+\r
+ // usun z ciagu znaki '()' lub '[]' i przepisz do 'OP_'\r
+ op_:=op_+zm[1];\r
+ zm:=copy(tmp,2,length(tmp)-2);\r
+ j:=1;\r
+ end;\r
+\r
+\r
+ tmp:=get_dat_noSPC(j,zm,',',#0,a);\r
+\r
+\r
+// teraz jesli wystapi znak inny niz ',' to BLAD\r
+ case op of\r
+ '#','<','>','@','^': test_eol(j,zm,a,#0);\r
+ else\r
+ test_eol(j,zm,a,',');\r
+ end;\r
+\r
+\r
+// przepisz znak nastepujacy po ',' do 'OP_', jesli jest to 'XYS'\r
+// w przeciwnym wypadku wylicz wartosc po przecinku\r
+ if zm[j]=',' then\r
+\r
+ if mvnmvp then begin\r
+// inc(j);\r
+ __inc(j,zm);\r
+ str:=get_dat(j,zm,' ',true);\r
+ war_roz:=oblicz_wartosc(str,a);\r
+ op_:=op_+value_code(war_roz,a,true);\r
+\r
+ end else begin\r
+\r
+ __inc(j,zm);\r
+\r
+ if test_param(j,zm) then begin Result.l:=__nill; exit end else\r
+ if UpCase(zm[j]) in ['X','Y','S'] then begin\r
+ op_:=op_+UpCase(zm[j]);\r
+\r
+ if zm[j+1] in ['+','-'] then begin\r
+ if _eol(zm[j+2]) then begin\r
+\r
+ if UpCase(zm[j])='S' then blad(old,4); // + - nie moze byc dla 'S'\r
+\r
+ incdec:=true;\r
+\r
+ case zm[j+1] of\r
+ '-': //war_roz:=oblicz_wartosc('{de'+zm[j]+'}',a);\r
+ if UpCase(zm[j])='X' then war_roz:=$CA else war_roz:=$88; // dex, dey\r
+ '+': //war_roz:=oblicz_wartosc('{in'+zm[j]+'}',a);\r
+ if UpCase(zm[j])='X' then war_roz:=$E8 else war_roz:=$C8; // inx, iny\r
+ end;\r
+\r
+ inc(j,2);\r
+ end else begin\r
+ zwieksz:=true; inc(j);\r
+ war_roz:=___wartosc_noSPC(zm,a,j,#0,'F');\r
+ end;\r
+\r
+ end else inc(j);\r
+\r
+ end else blad(old,14);\r
+ end;\r
+\r
+// end;\r
+ test_eol(j,zm,a,#0);\r
+ end;\r
+\r
+\r
+ // jesli to rozkaz skoku lub PEA to nie relokujemy (BRANCH=TRUE)\r
+\r
+ if ((mnemo[1]='B') and (mnemo[2]<>'I')) or ((mnemo[1]='P') and (mnemo[2]='E') and (mnemo[3]='A') and (op_='') and (op=' ')) then begin\r
+ branch:=true;\r
+\r
+ branch_run:=true;\r
+ end else\r
+ branch_run:=false;\r
+\r
+\r
+ if adres<0 then\r
+ if pass=pass_end then blad(old,10); // adres<0 na pewno nie bylo ORG'a\r
+\r
+\r
+// oblicz wartosc argumentu mnemonika, jesli brak argumentu to 'WAR=0'\r
+ war:=0;\r
+ if not((tmp='') and (op='#')) then\r
+ if op<>'@' then war:=oblicz_wartosc(tmp,old);\r
+\r
+\r
+ if zwieksz then inc(war, war_roz); //war:=war+war_roz;\r
+\r
+ op_:=op_+value_code(war,a,true);\r
+\r
+ if mvnmvp then war:=war_roz + byte(war) shl 8;\r
+\r
+ \r
+(*----------------------------------------------------------------------------*)\r
+(* wyjatki dotycza skokow warunkowych B?? (6502) ; BRA, BRL, PEA (65816) *)\r
+(*----------------------------------------------------------------------------*)\r
+\r
+ if branch_run then begin\r
+\r
+ op_:='B';\r
+\r
+ if siz<>' ' then\r
+ if siz='Q' then op_:='W' else\r
+ if siz<>'Z' then blad(old,31);\r
+\r
+ j:=adrMode(op_); // dowiemy sie ktory to tryb adresowania\r
+\r
+ war:=war-2-adres;\r
+\r
+\r
+ if tryb and maska[j]=2 then\r
+\r
+ idx:=128\r
+\r
+ else begin\r
+\r
+ op_:='W';\r
+\r
+ if siz<>' ' then\r
+ if siz<>'Q' then blad(old,31);\r
+\r
+ dec(war);\r
+\r
+ idx:=65536;\r
+\r
+ end;\r
+\r
+\r
+ test:=false;\r
+\r
+ if (war<0) and (abs(war)-idx>0) then begin war:=abs(war)-idx; test:=true end;\r
+\r
+ if (war>0) and (war-idx+1>0) then begin war:=war-idx+1; test:=true end;\r
+\r
+\r
+ if (pass=pass_end) and test then blad(old,integer(-war));\r
+ end;\r
+\r
+\r
+ // na podstawie 'OP' okresl adresacje 'OP_'\r
+ case op of\r
+ '#','<','>','^': op_:='#';\r
+ '@': op_:='@';\r
+ end;\r
+\r
+\r
+// znajdz obliczona adresacje w tablicy 'adresacja'\r
+// oraz sprawdz czy dla tego mnemonika jest mozliwa ta adresacja\r
+//\r
+// jesli nie znalazl to zmien rodzaj argumentu Z->Q\r
+\r
+ // jesli 65816 to wstaw znak '~'\r
+ if (opt and 16>0) then op_:='~'+op_;\r
+\r
+ len:=length(op_);\r
+ \r
+\r
+// jesli rozkaz relokowalny (RELOC=TRUE) wymus rozmiar 'Q'\r
+ if reloc and not(dreloc.use) then\r
+ if siz='T' then blad(old,12) else\r
+ if not(op in ['<','>','^']) then siz:='Q';\r
+\r
+\r
+// jesli wystapila etykieta external (EXT_USED.USE=TRUE) wymus rozmiar EXT_USED.SIZ\r
+ if ext_used.use and (ext_used.siz in ['B','W','L']) then begin\r
+\r
+ if op='^' then blad(old,85);\r
+\r
+ if op in ['<','>'] then begin\r
+ t_ext[ext_idx-1].typ:=op;\r
+ ext_used.siz:='B';\r
+\r
+ if op='>' then t_ext[ext_idx-1].lsb:=byte(war);\r
+ end; \r
+\r
+\r
+ case ext_used.siz of\r
+ 'B': siz:='Z';\r
+ 'W': siz:='Q';\r
+ 'L': siz:='T';\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+// sprawdz czy wystapilo rozszerzenie mnemonika\r
+// zmodyfikuj wielkosc operandu na podstawie 'SIZ'\r
+ if siz<>' ' then\r
+ case op_[len] of\r
+ 'Q': if siz<>'Z' then\r
+ op_[len]:=siz\r
+ else\r
+ if pass=pass_end then blad(old,31);\r
+\r
+ 'T': if not(siz='T') then\r
+ if pass=pass_end then blad(old,31);\r
+\r
+ '#': if siz='T' then\r
+ blad(old,14)\r
+ else\r
+ if (siz='Z') and (abs(war)>$FF) then blad(old,31);\r
+\r
+ 'Z': op_[len]:=siz;\r
+ end;\r
+\r
+\r
+ j:=adrMode(op_);\r
+\r
+ while (j=0) or (tryb and maska[j]=0) do begin\r
+\r
+ case op_[len] of // zmien rozmiar operandu\r
+ 'Z': op_[len]:='Q';\r
+ 'Q': op_[len]:='T';\r
+ else\r
+\r
+ if pass=pass_end then\r
+ blad(old,14)\r
+ else\r
+ Break;\r
+\r
+ end;\r
+ // sprawdz czy nowy operand nie kloci sie z zadeklarowanym rozmiarem\r
+ if (siz<>' ') and (pass=pass_end) then\r
+ if not(siz=op_[len]) then blad(old,31);\r
+\r
+ j:=adrMode(op_); // sprawdz czy dla nowego rozmiaru operandu istnieje tryb adresowania\r
+ end;\r
+\r
+\r
+\r
+ if opt and 16>0 then begin\r
+ ile:=0;\r
+ for k:=8 downto 1 do\r
+ if ((tryb shr 24) and maska[k]>0) then ile:=byte( (9-k)*23 );\r
+\r
+{ if tryb and $80000000>0 then ile:=23;\r
+ if tryb and $40000000>0 then ile:=2*23;\r
+ if tryb and $20000000>0 then ile:=3*23;\r
+ if tryb and $10000000>0 then ile:=4*23;\r
+ if tryb and $08000000>0 then ile:=5*23;\r
+ if tryb and $04000000>0 then ile:=6*23;\r
+ if tryb and $02000000>0 then ile:=7*23;\r
+ if tryb and $01000000>0 then ile:=8*23;}\r
+\r
+ inc(code, addycja_16[j+ile]) //code:=byte( code+addycja_16[j+ile] )\r
+\r
+ end else\r
+ if (tryb and $80000000>0) then\r
+ inc(code, addycja[j+12]) //code:=code+addycja[j+12]\r
+ else\r
+ inc(code, addycja[j]); //code:=code+addycja[j];\r
+\r
+\r
+// obliczenie wartosci 'WAR' na podstawie 'OP'\r
+// WAR moze byc dowolna wartoscia typu D-WORD\r
+\r
+ help:=war;\r
+ if dreloc.use and rel_used then dec(help,rel_ofs);\r
+\r
+ case op of\r
+ '<': war := byte( wartosc(a,help,'D') );\r
+ '>': begin war := byte( wartosc(a,help,'D') shr 8 ); _sizm( byte(help) ) end;\r
+ '^': begin war := byte( wartosc(a,help,'D') shr 16 ); _sizm( byte(help) ) end;\r
+ end;\r
+\r
+// policz z ilu bajtow sklada sie rozkaz wraz z argumentem\r
+ ile:=1;\r
+\r
+ if not(mvnmvp) then\r
+ if incdec then begin\r
+ inc(ile);\r
+ case op_[len] of\r
+ 'Z': war := war + byte(war_roz) shl 8;\r
+ 'Q': war := war + byte(war_roz) shl 16;\r
+ 'T': war := war + byte(war_roz) shl 24;\r
+ end;\r
+ end;\r
+\r
+ if op_='~ZZ' then inc(ile,2)\r
+ else\r
+ case op_[len] of\r
+ '#': begin\r
+ if siz=' ' then siz:=value_code(war,a,false);\r
+\r
+ case siz of\r
+ 'Z': begin\r
+ war:=wartosc(a,war,'B');\r
+ inc(ile)\r
+ end;\r
+\r
+ 'Q': if (opt and 16=0) then\r
+ blad(old,0)\r
+ else begin\r
+ war:=wartosc(a,war,'A');\r
+ inc(ile,2)\r
+ end;\r
+ end;\r
+\r
+ end;\r
+ 'Z','B': inc(ile);\r
+ 'Q','W': inc(ile,2);\r
+ 'T': inc(ile,3);\r
+ end;\r
+\r
+\r
+// okreslamy rozmiar relokowalnego argumentu B,W,L,<,> \r
+ if dreloc.use and rel_used then begin\r
+\r
+ case op_[len] of\r
+ '#': if (op in ['<','>','^']) then dreloc.siz:=op;\r
+ 'Z','B': dreloc.siz:=relType[1];\r
+ 'Q','W': dreloc.siz:=relType[2];\r
+ 'T': dreloc.siz:=relType[3];\r
+ end;\r
+\r
+ if not(ext_used.use) then dec(war,rel_ofs); // nie wolno modyfikowac argumentu symbolu EXTERNAL\r
+\r
+ _siz(true);\r
+\r
+ rel_used:=false;\r
+ end;\r
+\r
+\r
+ // tutaj przeprowadzamy operacje sledzenia rozmiaru rejestrow A,X,Y\r
+ // modyfikowanych przez rozkazy REP, SEP\r
+ if (opt and $40>0) and (pass=pass_end) and macro_rept_if_test then begin // wlaczona opcja sledzenia rozkazow SEP, REP\r
+\r
+ if mSEP then reg_size( byte(war),true ) else\r
+ if mREP then reg_size( byte(war),false );\r
+\r
+ // sprawdzamy rozmiar rejestrow dla trybu adresowania natychmiastowego '#'\r
+ if not(pomin) then\r
+ if op_[len]='#' then\r
+ case mnemo[3] of\r
+ 'A','C','D','P','R','T': test_reg_size(a,regA,ile); // lda, adc, sbc, and, cmp, ror, bit\r
+ 'X': test_reg_size(a,regX,ile); // ldx\r
+ 'Y': test_reg_size(a,regY,ile); // ldy\r
+ end;\r
+\r
+ end;\r
+\r
+ // preparujemy wynik, rozkaz CPU + argumenty\r
+\r
+ Result.l := ile;\r
+\r
+ Result.h[0] := code;\r
+ Result.h[1] := byte(war);\r
+ Result.h[2] := byte(war shr 8);\r
+ Result.h[3] := byte(war shr 16);\r
+ Result.h[4] := byte(war shr 24);\r
+\r
+ mne_used := true; // zostal odczytany jakis mnemonik\r
+\r
+end;\r
+\r
+\r
+function reserved(var ety: string): Boolean;\r
+var v: byte;\r
+begin\r
+ v:=fASC(ety);\r
+\r
+ Result := (v in [$80..$9f]); // PSEUDO\r
+ if Result then exit;\r
+\r
+ if opt and 16>0 then\r
+ Result := (v in [1..92]) // 65816\r
+ else\r
+ Result := (v in [1..56]); // 6502\r
+\r
+end;\r
+\r
+\r
+procedure reserved_word(var ety, zm: string{; const skip: Boolean});\r
+(*----------------------------------------------------------------------------*)\r
+(* testuj czy nie zostala uzyta zarezerwowana nazwa, np. nazwa pseudorozkazu *)\r
+(* lub czy nazwa zostala juz wczesniej uzyta *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+\r
+ if ety[1]='?' then warning(8);\r
+\r
+ if length(ety)=3 then\r
+ if reserved(ety) then blad_und(zm,ety,9);\r
+\r
+ if rept then blad(zm,51);\r
+ //if skip and proc then blad(zm,17);\r
+ if load_lab(ety,true)>=0 then blad_und(zm,ety,2); // nazwa w uzyciu\r
+\r
+end;\r
+\r
+\r
+procedure create_struct_variable(var zm,ety: string; var mne: int5; const head: Boolean; var adres: integer);\r
+(*----------------------------------------------------------------------------*)\r
+(* wykonaj .STRUCT (np. deklaracja pola struktury za pomoca innej struktury) *)\r
+(* mo¿liwe jest przypisanie pol zdefiniowanych przez strukture nowej zmiennej*)\r
+(*----------------------------------------------------------------------------*)\r
+var indeks, _doo, j, k, idx: integer;\r
+ txt, str: string;\r
+begin\r
+\r
+ indeks:=mne.i;\r
+\r
+ if mne.l=__enum_run then begin\r
+\r
+ save_lst('a');\r
+\r
+ for k:=0 to indeks-1 do save_dst(0);\r
+ inc(adres, indeks);\r
+\r
+ exit;\r
+ end;\r
+\r
+ // sprawdzamy czy struktura nie wywoluje sama siebie\r
+ if t_str[indeks].lab+'.'=lokal_name then blad(zm,57);\r
+\r
+ _doo := adres-struct.adres;\r
+\r
+ if mne.l=__struct_run then\r
+ if struct.use then\r
+ save_lab(ety, _doo, bank, zm) // nowe pole w strukturze\r
+ else\r
+ save_lab(ety, adres, bank, zm); // definicja zmiennej typu strukturalnego\r
+\r
+ save_lst('a');\r
+\r
+ // odczytujemy liczbe pol struktury\r
+ k:=t_str[indeks].ofs;\r
+ inc(indeks);\r
+\r
+ for idx:=indeks to indeks+k-1 do begin\r
+\r
+ txt:=t_str[idx].lab;\r
+\r
+ if mne.l=__struct_run_noLabel then\r
+ str:=txt\r
+ else begin\r
+\r
+ //_odd:=pos('.',txt); //???\r
+ //if _odd>0 then txt:=copy(txt,_odd,length(txt)); //???\r
+\r
+ if txt[1]<>'.' then txt:='.'+txt;\r
+\r
+ str:=ety+txt;\r
+ end;\r
+\r
+ j:=t_str[idx].siz;\r
+\r
+ if struct.use then begin\r
+ k:=t_str[idx].ofs+_doo; // konieczna operacja, bo STRUCT.ADRES nie zostal zwiekszony\r
+\r
+ save_str(str,k,j,1,adres,bank); // tutaj zwiekszony zostaje STRUCT.ADRES\r
+\r
+ save_lab(str,adres-struct.adres,bank,zm); // tutaj operujemy na nowej wartosci STRUCT.ADRES\r
+\r
+ inc(struct.cnt); // zwiekszamy licznik pol w strukturze\r
+ end else begin\r
+\r
+ save_lab(str,adres,bank,zm);\r
+\r
+ if dreloc.use or dreloc.sdx then\r
+ for k:=0 to j-1 do save_dst(0)\r
+ else\r
+ if head then new_DOS_header; // wymuszamy zapis naglowka DOS-a\r
+\r
+ end;\r
+\r
+ inc(adres, j);\r
+ end;\r
+end;\r
+\r
+\r
+procedure create_struct_data(var i: integer; var zm, ety: string; v: byte);\r
+(*----------------------------------------------------------------------------*)\r
+(* dla DTA STRUCT_NAME [EXPRESSION] tworzymy dane typu strukturalnego *)\r
+(*----------------------------------------------------------------------------*)\r
+var _doo, _odd, k, idx: integer;\r
+ war: Int64;\r
+ tmp: string;\r
+begin\r
+ struct_used.use:=false;\r
+\r
+ _odd:=adres; war:=adres;\r
+ _doo:=bank; k:=bank;\r
+\r
+ save_lst('a');\r
+\r
+ if v>=__byte then\r
+ dec(v, __byteValue)\r
+ else\r
+ v:=1;\r
+\r
+ test_skipa;\r
+\r
+ oblicz_dane(i,zm,zm,v);\r
+\r
+ // jesli stworzylismy strukture to odpowiednio zapamietaj\r
+ // jej dane, adres, stworzyciela itp.\r
+ if struct_used.use then begin\r
+\r
+ if ety='' then blad(zm,15);\r
+ if (pass<2) and (ety[1]='?') then warning(8);\r
+\r
+\r
+ idx:=load_lab(ety,true); \r
+\r
+\r
+ // jesli etykieta byla juz zadeklarowana i to jest PASS=0\r
+ // tzn ze mamy blad LABEL DECLARED TWICE\r
+ if (pass=0) and (idx>=0) then blad_und(zm,ety,2);\r
+\r
+\r
+ _doo:=__dta_struct;\r
+\r
+ if t_lab[idx].bnk=__dta_struct then begin\r
+ // wystapila juz ta deklaracja danych strukturalnych\r
+ _odd:=t_lab[idx].adr;\r
+\r
+ t_str[_odd].adr := cardinal( war );\r
+ t_str[_odd].bnk := integer( k );\r
+\r
+ end else begin\r
+\r
+ // w TMP tworzymy nazwe uwzgledniaj¹c¹ lokalnosc 'TMP:= ??? + ETY'\r
+ if run_macro then tmp:=macro_nr+{lokal_name+}ety else\r
+ if proc then tmp:=proc_name+lokal_name+ety else\r
+ tmp:=lokal_name+ety;\r
+\r
+ // nie wystapila jeszcze ta deklaracja danych strukturalnych\r
+ save_str(tmp,struct_used.cnt,0,1, integer(war), integer(k));\r
+\r
+ _odd:=loa_str(tmp, struct.id);\r
+\r
+ t_str[_odd].idx:=struct_used.idx;\r
+ end;\r
+\r
+ end;\r
+\r
+ save_lab(ety,cardinal(_odd),integer(_doo),zm); // zapisujemy etykiete normalnie poza struktur¹\r
+end;\r
+\r
+\r
+procedure oddaj_var;\r
+var i, y, x: integer;\r
+ txt, tmp: string;\r
+ old_run_macro: Boolean;\r
+ mne: int5;\r
+begin\r
+\r
+if var_idx>0 then begin\r
+\r
+ old_run_macro := run_macro;\r
+ run_macro := false;\r
+\r
+ tmp:='';\r
+\r
+ for i:=0 to var_idx-1 do\r
+ if t_var[i].lok = end_idx then begin // zmienne odkladamy w odpowiednim obszarze lokalnym\r
+\r
+ txt := t_var[i].nam; // nazwa zmiennej .VAR\r
+\r
+ if t_var[i].adr>=0 then // zmienne .VAR z okreslonym adresem umiejscowienia\r
+ nul.i:=t_var[i].adr\r
+ else\r
+ nul.i:=adres; // zmienne .VAR alokowane dynamicznie\r
+\r
+ if nul.i<0 then blad(global_name,87); // Undefined variable address\r
+\r
+ save_lst('l');\r
+\r
+ case t_var[i].typ of\r
+ 'V': begin\r
+ save_lab(txt,nul.i,bank,txt);\r
+\r
+ if t_var[i].adr<0 then // T_VAR[I].ADR<0 oznacza brak okreslonej wartosci\r
+ for y:=t_var[i].cnt-1 downto 0 do save_dta(t_var[i].war , tmp , tType[t_var[i].siz] , 0);\r
+ end;\r
+\r
+ 'S': begin\r
+ y:=load_lab(t_var[i].str, false);\r
+\r
+ mne.i:=t_lab[y].adr; // znajdz indeks do struktury\r
+ mne.l:=byte(__struct_run);\r
+\r
+ if t_var[i].zpv or (t_var[i].adr>=0) then begin // jesli .ZPVAR lub okreslony adres\r
+ x:=t_var[i].adr;\r
+ create_struct_variable(txt, txt, mne, false, x);\r
+ end else\r
+ create_struct_variable(txt, txt, mne, true, adres);\r
+\r
+ end;\r
+ end;\r
+\r
+ tmp:=txt; zapisz_lst(txt);\r
+\r
+ t_var[i].lok:=-1;\r
+\r
+ end;\r
+\r
+ nul.i:=0;\r
+ save_lst(' '); // koniecznie musi to tutaj byc\r
+\r
+ run_macro := old_run_macro;\r
+ \r
+end;\r
+\r
+end;\r
+\r
+\r
+procedure add_blok(var a: string);\r
+begin\r
+ inc(blok);\r
+ if blok>$FF then blad(a,45);\r
+end;\r
+\r
+\r
+procedure save_blk(const kod:integer; var a:string; const h:Boolean);\r
+(*----------------------------------------------------------------------------*)\r
+(* BLK UPDATE ADDRESS *)\r
+(*----------------------------------------------------------------------------*)\r
+var x, y, i, j, k: integer;\r
+ hea_fd, hea_fe, ok, tst: Boolean;\r
+ txt: string;\r
+begin\r
+ txt:=a;\r
+\r
+ for k:=blok downto 0 do begin\r
+\r
+ hea_fd:=false; ok:=false;\r
+\r
+// szukaj w glownym bloku\r
+\r
+ for y:=0 to rel_idx-1 do\r
+ if t_rel[y].idx=kod then\r
+ if t_rel[y].blo=0 then\r
+ if t_rel[y].blk=k then begin\r
+\r
+ if not(hea_fd) then begin\r
+ if h then begin\r
+ save_lst('a');\r
+\r
+ save_dstW( $fffd );\r
+ save_dst( byte(K) );\r
+ save_dstW( $0000 );\r
+\r
+ zapisz_lst(txt);\r
+ end;\r
+\r
+ hea_fd:=true; ok:=true;\r
+ end;\r
+\r
+ save_lst('a');\r
+\r
+ save_dst($fd);\r
+ save_dstW( t_rel[y].adr ); // save_dst(byte(t_rel[y].adr shr 8));\r
+\r
+ zapisz_lst(txt);\r
+\r
+ t_rel[y].idx:=-100; // wylacz z poszukiwan\r
+ end;\r
+\r
+// szukaj w blokach relokowalnych\r
+ for x:=1 to blok do begin\r
+\r
+ hea_fe:=false; j:=0; tst:=false;\r
+\r
+ for y:=0 to rel_idx-1 do\r
+ if t_rel[y].idx=kod then\r
+ if t_rel[y].blo=x then\r
+ if t_rel[y].blk=k then begin\r
+\r
+ if not(tst) then begin\r
+ save_lst('a');\r
+ tst:=true;\r
+ end;\r
+\r
+ if not(hea_fe) then begin\r
+ if not(hea_fd) and h then begin\r
+ save_dstW( $fffd );\r
+ save_dst( byte(K) );\r
+ save_dstW( $0000 );\r
+\r
+ hea_fd:=true;\r
+ end;\r
+\r
+ save_dst($fe);\r
+ save_dst(byte(x));\r
+\r
+ hea_fe:=true; ok:=true;\r
+ end;\r
+\r
+ j:=t_rel[y].adr-j;\r
+ if j>=$fa then\r
+ for i:=0 to (j div $fa)-1 do begin\r
+ save_dst($ff);\r
+ dec(j,$fa);\r
+ end;\r
+\r
+ save_dst(byte(j));\r
+ j:=t_rel[y].adr;\r
+\r
+ t_rel[y].idx:=-100; // wylacz z poszukiwan\r
+ end;\r
+\r
+ if tst then zapisz_lst(txt);\r
+ end;\r
+\r
+ if ok then begin\r
+ save_lst('a');\r
+\r
+ save_dst($fc);\r
+\r
+ zapisz_lst(txt);\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function get_pubType(var txt,zm:string; var _odd:integer): byte;\r
+(*----------------------------------------------------------------------------*)\r
+(* odczytujemy typ etykiety public, _ODD = indeks do etykiety w tablicy T_LAB *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+\r
+ Result:=0;\r
+\r
+ _odd:=load_lab(txt,false);\r
+\r
+ if _odd<0 then blad_und(zm,txt,73);\r
+\r
+// symbolami publicznymi nie moga byc etykiety przypisane do\r
+// SMB, STRUCT, PARAM, EXT, MACRO\r
+\r
+ if t_lab[_odd].bnk>=__id_param then begin\r
+ Result := byte( t_lab[_odd].bnk );\r
+ if not( Result in [__proc_run, __array_run, __struct_run]) then blad_und(zm,txt,103);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function get_smb(var i:integer; var zm:string): string;\r
+(*----------------------------------------------------------------------------*)\r
+(* pobieramy 8 znakowy symbol SMB *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+ x: integer;\r
+begin\r
+ txt:=get_string(i,zm,zm,true);\r
+\r
+ if length(txt)>8 then blad(zm,44); // za dluga nazwa etykiety\r
+\r
+ while length(txt)<8 do txt:=txt+' '; // wyrownaj do 8 znakow\r
+\r
+ for x:=1 to 8 do txt[x]:=UpCase(txt[x]);\r
+\r
+ Result:=txt;\r
+end;\r
+\r
+\r
+procedure blk_update_new(var i:integer; var zm:string);\r
+var txt, str: string;\r
+ war, k: integer;\r
+begin\r
+ txt:=zm; zapisz_lst(txt); str:='';\r
+\r
+ omin_spacje(i,zm);\r
+ txt:=get_dat(i,zm,' ',true); if txt='' then blad(zm,23);\r
+\r
+\r
+ if test_symbols then\r
+ for war:=High(t_sym)-1 downto 0 do\r
+ if txt=t_sym[war] then begin blad_und(zm,txt,2); exit end;\r
+\r
+\r
+ war:=l_lab(txt); if war<0 then blad_und(zm,txt,5);\r
+ k:=t_lab[war].blk; if k=0 then blad(zm,53);\r
+\r
+ save_lst('a');\r
+\r
+ // dta a($fffc),b(blk_num),a(smb_off)\r
+ // dta c'SMB_NAME'\r
+ save_dstW( $fffc );\r
+ save_dst(byte(k));\r
+ save_dstW( t_lab[war].adr ); // save_dst(byte(t_lab[war].adr shr 8));\r
+\r
+ zapisz_lst(str);\r
+ save_lst('a');\r
+\r
+ txt:=get_smb(i,zm);\r
+ for k:=1 to 8 do save_dst( ord(txt[k]) );\r
+\r
+ zapisz_lst(txt);\r
+ bez_lst:=true;\r
+end;\r
+\r
+\r
+procedure oddaj_sym;\r
+var txt: string;\r
+ i, k: integer;\r
+begin\r
+\r
+if sym_idx>0 then begin\r
+\r
+ if adres<0 then blad(global_name,10);\r
+\r
+ test_symbols := false;\r
+\r
+ for i:=sym_idx-1 downto 0 do begin\r
+ // preparujemy linie dla NEW SYMBOL\r
+ txt:='BLK UPDATE NEW ' + t_sym[i] + ' ' + '''' + t_sym[i] + '''';\r
+\r
+ save_lst('a');\r
+\r
+ k:=16; blk_update_new(k,txt);\r
+ end;\r
+\r
+end;\r
+\r
+end;\r
+\r
+\r
+procedure blk_empty(const idx: integer; var zm: string);\r
+var indeks, tst: cardinal;\r
+ _doo: integer;\r
+ txt: string;\r
+begin\r
+\r
+ txt:=zm;\r
+ save_lst('a');\r
+\r
+ add_blok(zm);\r
+\r
+ // a($fffe),b(blk_num),b(blk_id)\r
+ // a(blk_off),a(blk_len)\r
+ save_dstW( $fffe );\r
+ save_dst(byte(blok));\r
+ save_dst(memType or $80);\r
+\r
+ save_dstW( adres ); //save_dst(byte(adres shr 8));\r
+ save_dstW( idx ); //save_dst(byte(idx shr 8));\r
+\r
+ // jesli deklaracja etykiet wystapila przed blokiem EMPTY\r
+ // znajdz je i popraw im numer bloku\r
+ indeks:=adres; tst:=adres+idx;\r
+\r
+ for _doo:=0 to High(t_lab)-1 do\r
+ if (t_lab[_doo].adr>=indeks) and (t_lab[_doo].adr<=tst) then\r
+ t_lab[_doo].blk:=blok;\r
+\r
+ zapisz_lst(txt);\r
+end;\r
+\r
+\r
+procedure oddaj_ds;\r
+var zm, txt: string;\r
+begin\r
+ if ds_empty>0 then begin\r
+ dec(adres, ds_empty);\r
+ zm:='BLK EMPTY';\r
+\r
+ if dreloc.sdx then begin // dreloc.sdx BLOK EMPTY\r
+ blk_empty(ds_empty, zm); \r
+ end else begin // dreloc.use BLOK EMPTY\r
+ save_lst('a');\r
+\r
+ save_dstW( __hea_address );\r
+ save_dst( byte('E') );\r
+ save_dstW( 1 ); // word(adres - rel_ofs) );\r
+ save_dstW( ds_empty );\r
+\r
+ txt:=zm; zapisz_lst(txt);\r
+ end;\r
+\r
+ ds_empty:=0;\r
+ end;\r
+end;\r
+\r
+\r
+procedure blk_update_symbol(var zm:string);\r
+var txt: string;\r
+ k: byte;\r
+ _doo: integer;\r
+begin\r
+\r
+ if smb_idx>0 then begin\r
+\r
+ txt:=zm; zapisz_lst(txt);\r
+\r
+ for _doo:=0 to smb_idx-1 do\r
+ if t_smb[_doo].use then begin\r
+\r
+ save_lst('a');\r
+\r
+ // a($fffb),c'SMB_NAME',a(blk_len)\r
+ save_dstW( $fffb );\r
+\r
+ txt:=t_smb[_doo].smb;\r
+ for k:=1 to 8 do save_dst( ord(txt[k]) );\r
+\r
+ save_dstW( $0000 );\r
+\r
+ zapisz_lst(txt);\r
+\r
+ save_blk(_doo,txt,false);\r
+ end;\r
+\r
+ bez_lst:=true;\r
+// smb_idx:=0;\r
+ end;\r
+ \r
+end;\r
+\r
+\r
+procedure blk_update_address(var zm:string);\r
+var txt: string;\r
+ idx, i, _odd: integer;\r
+ v: byte;\r
+ ch: Boolean;\r
+ tst: cardinal;\r
+begin\r
+ if not(dreloc.use) then\r
+\r
+ save_blk(-1,zm,true) // dla bloku Sparta DOS X\r
+\r
+ else begin\r
+\r
+ txt:=zm; zapisz_lst(txt);\r
+\r
+ // naglowek $FFEF, typ, liczba adresow, adresy\r
+\r
+{\r
+ if rel_idx>0 then begin\r
+ Writeln(rel_idx);\r
+ for i:=0 to rel_idx-1 do\r
+ Writeln(hex(t_rel[i].adr,4),',',t_rel[i].bnk,',',t_siz[t_rel[i].idx].siz,',',t_rel[i].idx,',',hex(t_siz[t_rel[i].idx].lsb,2));\r
+ end; }\r
+\r
+ \r
+ for i:=1 to sizeof(relType) do begin // dostepne typy B,W,L,D,<,>,^\r
+\r
+ ch:=false;\r
+ for idx:=0 to rel_idx-1 do\r
+ if t_siz[t_rel[idx].idx].siz=relType[i] then begin ch:=true; Break end;\r
+\r
+ if ch then begin\r
+\r
+ save_lst('a');\r
+\r
+ // A(HEADER = $FFEF)\r
+ save_dstW( __hea_address );\r
+\r
+ // najpierw zapiszemy do bufora aby dowiedziec sie ile ich jest\r
+ // maksymalnie mozemy zapisac $FFFF adresow\r
+ _odd:=0;\r
+// old_case:=false; // jesli bank=0 to FALSE\r
+ for idx:=0 to rel_idx-1 do\r
+ if t_siz[t_rel[idx].idx].siz=relType[i] then begin\r
+\r
+// if t_rel[idx].bnk>0 then old_case:=true; // jesli bank>0 to TRUE\r
+\r
+ tst:= (t_rel[idx].adr and $FFFF) or (t_siz[t_rel[idx].idx].lsb shl 16);\r
+ t_tmp[_odd] := tst;\r
+\r
+ inc(_odd);\r
+ testRange(zm, _odd, 13); // koniecznie blad 13 aby natychmiast zatrzymac\r
+ end;\r
+\r
+ v:=ord(relType[i]); //if old_case then v:=v or $80;\r
+\r
+ save_dst(v); // TYPE //+ MODE\r
+\r
+ zapisz_lst(txt);\r
+ save_lst('a');\r
+\r
+ // zapisujemy informacje o liczbie adresow DATA_LENGTH\r
+ save_dstW( _odd );\r
+\r
+ // teraz zapisujemy informacje o adresach\r
+\r
+ for idx:=0 to _odd-1 do begin\r
+ // bank etykiety external jesli MODE=1\r
+// if old_case then save_dst( byte(t_tmp[idx] shr 16) );\r
+\r
+ // adres do relokacji\r
+ save_dstW( t_tmp[idx] );\r
+\r
+\r
+ case relType[i] of\r
+ '>': save_dst( byte(t_tmp[idx] shr 16) );\r
+ '^': blad(zm,27);\r
+ end;\r
+\r
+ end;\r
+\r
+ zapisz_lst(txt);\r
+\r
+ end; //if ch then begin\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+ bez_lst:=true;\r
+ first_org:=true;\r
+end;\r
+\r
+\r
+procedure blk_update_external(var zm:string);\r
+var txt: string;\r
+ idx, _doo, _odd, i: integer;\r
+ v: byte;\r
+ ch: Boolean;\r
+ tst: cardinal;\r
+\r
+const\r
+ typExt: array [0..2] of char = (#0,'<','>');\r
+\r
+begin\r
+\r
+ if dreloc.sdx then exit;\r
+\r
+ if not(dreloc.use) then blad(zm,53);\r
+\r
+\r
+ if extn_idx>0 then begin\r
+\r
+ txt:=zm; zapisz_lst(txt);\r
+ save_lst('a');\r
+\r
+{\r
+ Writeln(ext_idx);\r
+ for i:=0 to ext_idx-1 do\r
+ Writeln(hex(t_ext[i].adr,4),',',t_extn[t_ext[i].idx].nam);\r
+}\r
+\r
+ for _doo:=0 to extn_idx-1 do begin\r
+\r
+ for i:=0 to 2 do begin\r
+\r
+ ch:=false;\r
+ for idx:=0 to ext_idx-1 do\r
+ if (t_ext[idx].idx=_doo) and (t_ext[idx].typ=typExt[i]) then begin ch:=true; Break end;\r
+\r
+ if ch then begin // czy wystapily w programie odwolania do etykiet external\r
+\r
+ save_lst('a');\r
+\r
+ // A(HEADER = $FFEE),b(TYPE)\r
+ save_dstW( __hea_external );\r
+\r
+ // najpierw zapiszemy do bufora aby dowiedziec sie ile ich jest\r
+ // maksymalnie mozemy zapisac $FFFF adresow i ich numerow bankow\r
+ _odd:=0;\r
+// old_case:=false; // jesli bank=0 to FALSE\r
+\r
+ for idx:=0 to ext_idx-1 do\r
+ if (t_ext[idx].idx=_doo) and (t_ext[idx].typ=typExt[i]) then begin\r
+\r
+// if t_ext[idx].bnk>0 then old_case:=true; // jesli bank>0 to TRUE\r
+\r
+ tst:= (t_ext[idx].adr and $FFFF) or (t_ext[idx].lsb shl 16) {(t_ext[idx].bnk shl 16)};\r
+ t_tmp[_odd] := tst;\r
+\r
+ inc(_odd);\r
+ testRange(zm, _odd, 13); // koniecznie blad 13 aby natychmiast zatrzymac\r
+ end;\r
+\r
+ if typExt[i]=#0 then\r
+ v:=ord(t_extn[_doo].siz) //if old_case then v:=v or $80;\r
+ else\r
+ v:=ord(typExt[i]);\r
+\r
+ save_dst(v); // ext_label TYPE //+ MODE\r
+\r
+ zapisz_lst(txt);\r
+ save_lst('a');\r
+\r
+ // zapisujemy informacje o liczbie adresow\r
+ save_dstW( _odd );\r
+\r
+ // A(EXT_LABEL_LENGTH) , C'EXT_LABEL'\r
+ txt:=t_extn[_doo].nam;\r
+\r
+ save_dstS(txt); // ext_label length, string\r
+\r
+\r
+ // teraz zapisujemy informacje o adresach\r
+\r
+ for idx:=0 to _odd-1 do begin\r
+ // bank etykiety external\r
+// if old_case then save_dst( byte(t_tmp[idx] shr 16) );\r
+\r
+ // adres etykiety external\r
+ save_dstW( t_tmp[idx] );\r
+\r
+ if typExt[i]='>' then save_dst( byte(t_tmp[idx] shr 24) );\r
+ end;\r
+\r
+ zapisz_lst(txt);\r
+\r
+ end; //for i:=0 to 3 do begin\r
+\r
+ end; //if ch then begin\r
+\r
+ end;\r
+\r
+// extn_idx:=0;\r
+ bez_lst:=true;\r
+ end;\r
+end;\r
+\r
+\r
+procedure blk_update_public(var zm:string);\r
+var txt, ety, str, tmp: string;\r
+ x, idx, j, k, indeks, _odd, _doo, i, len, old_rel_idx, old_siz_idx: integer;\r
+ sid, sno, six: integer;\r
+ v, sv: byte;\r
+ ch, tp: char;\r
+ test: Boolean;\r
+ war: Int64;\r
+ old_sizm0, old_sizm1: rSizTab;\r
+begin\r
+\r
+ if dreloc.sdx then exit;\r
+\r
+ if pub_idx>0 then begin\r
+\r
+ txt:=zm; zapisz_lst(txt);\r
+ save_lst('a');\r
+\r
+ _odd:=0;\r
+\r
+ _doo:=-1;\r
+\r
+ // test obecnosci etykiet publicznych oraz test parametrow procedur __pVar\r
+\r
+ for idx:=pub_idx-1 downto 0 do begin\r
+ txt:=t_pub[idx].nam;\r
+\r
+ v := get_pubType(txt,zm, _odd);\r
+\r
+ // dodajemy do upublicznienia parametry procedury __pVar\r
+ // pod warunkiem ze ich wczesniej jeszcze nie upublicznialismy\r
+ if v = __proc_run then\r
+ if t_prc[t_lab[_odd].adr].typ = __pVar then begin\r
+\r
+ k:=t_prc[t_lab[_odd].adr].par; // liczba parametrow\r
+ indeks:=t_prc[t_lab[_odd].adr].str;\r
+\r
+ if k>0 then\r
+ for j:=0 to k-1 do begin\r
+ ety:=t_par[j+indeks];\r
+\r
+ // omijamy pierwszy znak okreslajacy typ parametru\r
+ // i czytamy az nie napotkamy znakow nie nalezacych do nazwy etykiety\r
+\r
+ str:='';\r
+ i:=2;\r
+ len:=length(ety);\r
+\r
+ while i<=len do begin\r
+ if _lab(ety[i]) then str:=str+ety[i] else Break;\r
+ inc(i);\r
+ end;\r
+\r
+// str:=copy(ety,2,length(ety)); // poprawiamy nazwe parametru\r
+\r
+ _doo:=l_lab(str);\r
+\r
+ test:=false;\r
+ for x:=pub_idx-1 downto 0 do\r
+ if t_pub[x].nam=str then begin test:=true; Break end;\r
+\r
+ if (_doo>=0) and not(test) then // dopisujemy do T_PUB jesli nie zostala wczesniej upubliczniona\r
+ if (t_lab[_doo].bnk<>__id_ext) {and not(test)} then save_pub(str,zm);\r
+\r
+ end;\r
+\r
+ if _doo<0 then blad_und(zm,str,5);\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ // okreslamy typ etykiety PUBLIC, czy jest relokowalna\r
+\r
+ branch:=false; // umo¿liwiamy relokowalnosc\r
+\r
+ old_rel_idx := rel_idx;\r
+ old_siz_idx := siz_idx;\r
+ old_sizm0 := t_siz[siz_idx];\r
+ old_sizm1 := t_siz[siz_idx-1];\r
+\r
+ for _odd:=pub_idx-1 downto 0 do begin\r
+ txt:=t_pub[_odd].nam;\r
+\r
+ reloc:=false;\r
+\r
+ oblicz_wartosc(txt,zm);\r
+ t_pub[_odd].typ := reloc;\r
+ end;\r
+\r
+ branch:=true; // blokujemy relokowalnosc\r
+\r
+ rel_idx := old_rel_idx;\r
+ siz_idx := old_siz_idx;\r
+ t_siz[siz_idx] := old_sizm0;\r
+ t_siz[siz_idx-1] := old_sizm1;\r
+\r
+{\r
+ Writeln(pub_idx);\r
+ for x:=0 to pub_idx-1 do Writeln(t_pub[x].nam,',',t_pub[x].typ);\r
+}\r
+\r
+\r
+ // A(HEADER = $FFED) , a(LENGTH)\r
+ save_dstW( __hea_public );\r
+ save_dstW( pub_idx );\r
+\r
+ for idx:=0 to pub_idx-1 do begin\r
+\r
+ txt:=t_pub[idx].nam;\r
+\r
+ ety:=txt;\r
+ save_lst('a');\r
+\r
+ v := get_pubType(txt,zm, _odd); // V to typ, _ODD to indeks do T_LAB\r
+\r
+ case v of\r
+ __proc_run: ch:='P'; // P-ROCEDURE\r
+ __array_run: ch:='A'; // A-RRAY\r
+ __struct_run: ch:='S'; // S-TRUCT\r
+ else\r
+\r
+ if t_pub[idx].typ then\r
+ ch := 'V' // V-ARIABLE\r
+ else\r
+ ch := 'C'; // C-ONSTANT\r
+\r
+ end;\r
+\r
+ tp:='W';\r
+\r
+ if ch='C' then begin // type B-YTE, W-ORD, L-ONG, D-WORD\r
+ war:=t_lab[_odd].adr;\r
+\r
+ tp:=relType [ ValueToType(war) ];\r
+\r
+ save_dst(ord(tp)); // type\r
+\r
+ end else\r
+ save_dst( byte('W') ); // type W-ORD dla V-ARIABLE, P-ROCEDURE, A-RRAY, S-TRUCT\r
+\r
+\r
+ save_dst(ord(ch)); // label_type V-ARIABLE, C-ONSTANT, P-ROCEDURE, A-RRAY, S-TRUCT\r
+\r
+ save_dstS(txt); // label_name [length + atascii]\r
+\r
+ case v of\r
+ __proc_run: k:=t_prc[t_lab[_odd].adr].adr; // PROC address\r
+ __array_run: k:=t_arr[t_lab[_odd].adr].adr; // ARRAY address\r
+ __struct_run: k:=t_str[t_lab[_odd].adr].ofs; // liczba pol STRUCT\r
+ else\r
+ k:=t_lab[_odd].adr; // variable address\r
+ end;\r
+\r
+ if not(ch in ['C','S']) then dec(k,rel_ofs); // wartosci C-ONSTANT i S-TRUCT nie modyfikujemy\r
+\r
+\r
+ for sv:=1 to TypeToByte(tp) do begin\r
+ // wartosc zmiennej, stalej lub procedury\r
+ save_dst( byte(k) ); // o rozmiarze TP (B-YTE, W-ORD, L-ONG, D-WORD)\r
+ k := k shr 8;\r
+ end;\r
+\r
+\r
+ // S-TRUCT\r
+ if v = __struct_run then begin\r
+\r
+ sid:=t_str[t_lab[_odd].adr].id;\r
+ sno:=t_str[t_lab[_odd].adr].ofs;\r
+\r
+ for j:=0 to sno-1 do begin\r
+ six:=loa_str_no(sid, j);\r
+\r
+ txt:=t_str[six].lab;\r
+\r
+ save_dst ( byte( relType[t_str[six].siz] ) );\r
+\r
+ save_dstS ( txt );\r
+\r
+ save_dstW ( word(t_str[six].rpt) );\r
+\r
+ { write(t_str[six].lab); // nazwa struktury\r
+ write(',',t_str[six].ofs); // ofset lub liczba pol struktury\r
+ write(',',t_str[six].siz); // dlugosc calkowita w bajtach\r
+\r
+ write(',',hex(t_str[six].rpt,4));\r
+\r
+ writeln(',',t_str[six].no); }\r
+ end;\r
+\r
+ end else\r
+\r
+ // A-RRAY\r
+ if v = __array_run then begin\r
+\r
+ save_dstW( t_arr[t_lab[_odd].adr].idx ); // maksymalny indeks tablicy\r
+\r
+ save_dst( ord ( relType[t_arr[t_lab[_odd].adr].siz] ) ); // rozmiar pol\r
+\r
+ end else\r
+\r
+ // P-ROCEDURE\r
+ if v = __proc_run then begin\r
+ k:=t_prc[t_lab[_odd].adr].reg;\r
+ save_dst( byte(k) ); // kolejnosc rejestrow\r
+\r
+ ch:=t_prc[t_lab[_odd].adr].typ;\r
+ save_dst( ord(ch) ); // typ procedury ' '__pDef, 'R'__pReg, 'V'__pVar\r
+\r
+\r
+ k:=t_prc[t_lab[_odd].adr].par; // liczba parametrow\r
+\r
+ indeks:=t_prc[t_lab[_odd].adr].str;\r
+\r
+\r
+ if (k>0) and (ch=__pVar) then // jesli __pVar to wliczamy tez dlugosc\r
+ for j:=0 to k-1 do begin // nazw pametrow\r
+ tmp:=t_par[j+indeks];\r
+ inc(k,length(tmp)+2-1);\r
+ end;\r
+\r
+ save_dstW( k ); // liczba danych na temat parametrow\r
+\r
+\r
+ k:=t_prc[t_lab[_odd].adr].par; // liczba parametrow jeszcze raz\r
+\r
+\r
+ if k>0 then // jesli sa parametry to je zapiszemy\r
+ for j:=0 to k-1 do begin\r
+ tmp:=t_par[j+indeks];\r
+ save_dst(ord(tmp[1]));\r
+\r
+ if ch=__pVar then begin // dodatkowo dlugosc i nazwe etykiety jesli to __pVar\r
+ txt:=copy(tmp,2,length(tmp)); // omijamy pierwszy znak typu\r
+\r
+ save_dstS( txt );\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+ zapisz_lst(ety);\r
+ end;\r
+\r
+ bez_lst:=true;\r
+ end;\r
+end;\r
+\r
+\r
+procedure operator_zlozony(var i:integer; var zm,ety:string; const glob:Boolean);\r
+var txt: string;\r
+begin\r
+\r
+ if ety[1]<>'?' then blad(zm,58); // te operacje dotycza etykiet tymczasowych\r
+\r
+ if glob then\r
+ txt:=':'\r
+ else\r
+ txt:='';\r
+\r
+ txt:=txt+ety+zm[i];\r
+\r
+ if if_test then\r
+ if zm[i+1]='=' then begin\r
+ insert(txt,zm,i+2); // modyfikujemy linie np. ?tmp+=3 -> ?tmp=?tmp+3\r
+ delete(zm,i,1)\r
+ end else begin\r
+ zm:=ety+'='+txt+'1'; // modyfikujemy linie ?tmp++ -> ?tmp=?tmp+1\r
+ i:=length(ety)+1 // modyfikujemy linie ?tmp-- -> ?tmp=?tmp-1\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure get_data_array(var i:integer; var zm:string; const max:integer; const typ:byte);\r
+var ety, str: string;\r
+ k, j: integer;\r
+ _odd: integer;\r
+begin\r
+\r
+ save_lst(' ');\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if not(zm[i] in ['[','(']) then begin\r
+\r
+ ety:='['+IntToStr(array_used.max)+']';\r
+\r
+ if zm[i]='=' then __inc(i,zm);\r
+\r
+ end else begin\r
+\r
+ ety:=get_dat_noSPC(i,zm,'=',#0,zm);\r
+ if ety='' then ety:='[0]';\r
+\r
+ if zm[i]<>'=' then\r
+ blad(zm,58)\r
+ else\r
+ __inc(i,zm);\r
+\r
+ end;\r
+ \r
+ str:=get_dat_noSPC(i,zm,'\',#0,zm);\r
+ \r
+ k:=1;\r
+\r
+ while true do begin\r
+ _odd:=integer( oblicz_wartosc_ogr(ety,zm,k) ); // ___wartosc_noSPC(txt,zm,k,#0,'F');\r
+\r
+ subrange_bounds(zm,_odd,max);\r
+\r
+ array_used.idx:=_odd;\r
+ array_used.typ:=tType[ typ ];\r
+\r
+ if not(loop_used) and not(FOX_ripit) and (length(t)+7<32) then t:=t+' ['+hex(cardinal(_odd),4)+']';\r
+\r
+ j:=1; oblicz_dane(j,str,zm,typ);\r
+\r
+ omin_spacje(k,ety);\r
+ if ety[k]<>':' then Break else __inc(k,ety);\r
+\r
+ end;\r
+ \r
+ if k<=length(ety) then blad_ill(zm,ety[k]);\r
+\r
+end;\r
+\r
+\r
+procedure add_proc_nr;\r
+(*----------------------------------------------------------------------------*)\r
+(* zwiekszamy licznik PROC_IDX a przez to i PROC_NR *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ inc(proc_idx);\r
+\r
+ proc_nr:=proc_idx; // PROC_IDX to pierwszy wolny wpis do T_PRC\r
+ // kazdy nowy blok .PROC musi otrzymac nowy niepowtarzalny numer\r
+\r
+ if proc_idx>High(t_prc) then SetLength(t_prc, proc_idx+1);\r
+end;\r
+\r
+\r
+procedure upd_procedure(var ety,zm:string; const a:integer);\r
+(*----------------------------------------------------------------------------*)\r
+(* uaktualniamy wartosc BANK, ADRES i parametry procedury typu ' ' *)\r
+(*----------------------------------------------------------------------------*)\r
+var str, txt, b, tmp, add: string;\r
+ _doo, _odd, idx, i, len: integer;\r
+ tst: cardinal;\r
+ old_bool, old_macro: Boolean;\r
+begin\r
+\r
+ t_prc[proc_nr].bnk:=bank;\r
+ t_prc[proc_nr].adr:=a;\r
+\r
+ t_prc[proc_nr].ofs:=org_ofset;\r
+\r
+ str:=lokal_name+ety;\r
+ zapisz_etykiete(str,a,bank,ety[1]);\r
+\r
+ old_macro := run_macro;\r
+ run_macro := false;\r
+\r
+ old_bool := dreloc.use; // aby parametry procedury nie byly relokowalne\r
+ dreloc.use := false;\r
+\r
+ _doo:=t_prc[proc_nr].par; // liczba zadeklarowanych parametrow w aktualnej procedurze\r
+\r
+ if _doo>0 then\r
+ case t_prc[proc_nr].typ of\r
+\r
+ __pDef: begin\r
+\r
+ // jesli procedura miala zadeklarowane parametry to\r
+ // odczytamy adres dla parametrow zawarty w @PROC_VARS_ADR\r
+ // i zaktualizujemy adresy parametrow procedury\r
+\r
+ tst:=adr_label(2,true); // @proc_vars_adr\r
+\r
+ proc:=true; // PROC=TRUE i PROC_NAME\r
+ proc_name:=ety+'.'; // umozliwia uaktualnienie adresow etykiet\r
+\r
+ // wymus wykonanie makr @PULL 'I'\r
+\r
+// wymus_zapis_lst(zm);\r
+\r
+ zm:=' @PULL ''I'','+IntToStr(t_prc[proc_nr].ile);\r
+\r
+ idx:=t_prc[proc_nr].str;\r
+\r
+ for _odd:=0 to _doo-1 do begin // !!! koniecznie taka kolejnosc petli FOR !!!\r
+ txt:=t_par[idx+_odd];\r
+ str:=copy(txt,2,length(txt));\r
+\r
+ // uaktualnimy adresy etykiet parametrow procedury\r
+ save_lab(str , tst , __id_param , zm);\r
+\r
+ inc( tst , TypeToByte(txt[1]) );\r
+ end;\r
+\r
+ end;\r
+\r
+ __pVar: begin\r
+\r
+ idx:=t_prc[proc_nr].str;\r
+\r
+ for _odd:=_doo-1 downto 0 do begin\r
+ txt:=t_par[idx+_odd];\r
+\r
+\r
+ // wczytamy nazwe parametru, usuwamy pierwszy znak okreslajacy typ\r
+ // oraz znaki ktore nie naleza do nazwy etykiety\r
+\r
+ str:='';\r
+ add:='';\r
+ i:=2;\r
+ len:=length(txt);\r
+\r
+ while i<=len do begin\r
+ if _lab(txt[i]) then str:=str+txt[i] else Break;\r
+ inc(i);\r
+ end;\r
+\r
+ while i<=len do begin\r
+ add:=add+txt[i];\r
+ inc(i);\r
+ end;\r
+ \r
+ b:=lokal_name+ety+'.';\r
+\r
+ tmp:=b+str;\r
+ i:=l_lab(tmp);\r
+\r
+ // szukamy najblizszej sciezki dla parametru \r
+\r
+ while (i<0) and (pos('.',b)>0) do begin\r
+ obetnij_kropke(b);\r
+\r
+ tmp:=b+str;\r
+ i:=l_lab(tmp);\r
+ end;\r
+\r
+ t_par[idx+_odd] := txt[1]+tmp+add;\r
+ end;\r
+\r
+ end;\r
+ \r
+ end;\r
+\r
+\r
+ dreloc.use := old_bool;\r
+\r
+ run_macro := old_macro;\r
+\r
+ save_lst(' ');\r
+\r
+end;\r
+\r
+\r
+function ByteToReg(var a: byte): char;\r
+begin\r
+\r
+ case (a and $c0) of\r
+ $40: Result := 'X';\r
+ $80: Result := 'Y';\r
+ else\r
+ Result := 'A';\r
+ end;\r
+\r
+ a:=byte( a shl 2 );\r
+end;\r
+\r
+\r
+function RegToByte(const a: char): byte;\r
+begin\r
+\r
+ case a of\r
+ 'A': Result := $00;\r
+ 'X': Result := $55;\r
+ 'Y': Result := $aa;\r
+ else\r
+ Result := $ff;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure get_procedure(var ety,nam,zm: string; var i:integer);\r
+(*----------------------------------------------------------------------------*)\r
+(* odczytujemy i zapamietujemy typy i nazwy parametrow w deklaracji .PROC *)\r
+(* w zaleznosci od sposobu przekazywania parametrow zwiekszana jest liczba *)\r
+(* przebiegow asemblacji PASS_END *)\r
+(*----------------------------------------------------------------------------*)\r
+type _typBool = array [0..2] of Boolean;\r
+\r
+var k, l, nr_param, j: integer;\r
+ txt, str: string;\r
+ ch, ptype: char;\r
+ v: byte;\r
+ old_bool: Boolean;\r
+ \r
+ treg: _typBool;\r
+ all : _typStrREG;\r
+\r
+begin\r
+ reserved_word(ety,zm{, true}); // sprawdz czy nazwa .PROC jest dozwolona\r
+\r
+ old_bool := run_macro;\r
+ run_macro := false;\r
+\r
+ save_lab(ety,proc_nr,__id_proc,zm); // aktualny indeks do T_PRC = PROC_NR\r
+\r
+ run_macro := old_bool;\r
+\r
+ old_bool := dreloc.use; // koniecznie aby parametry procedury\r
+ dreloc.use := false; // nie byly relokowalne\r
+\r
+ t_prc[proc_nr].nam := nam; // wlasciwa nazwa procedury\r
+ t_prc[proc_nr].bnk := bank; // zapisanie banku procedury\r
+ t_prc[proc_nr].adr := adres; // zapisanie adresu procedury\r
+\r
+ t_prc[proc_nr].typ := __pDef; // domyslny typ procedury 'D'\r
+\r
+ t_prc[proc_nr].str := High(t_par); // indeks do T_PAR, beda tam parametry procedury\r
+\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ k:=0; nr_param:=0;\r
+\r
+\r
+ str:=zm[i];\r
+ \r
+ if not(test_char(i,zm,'(',#0)) then blad_und(zm,str,8);\r
+\r
+ // odczytujemy deklaracje parametrow ograniczonych nawiasami ( )\r
+ if zm[i] = '(' then begin\r
+\r
+ all:=''; // tutaj zapiszemy kombinacje rejestrow CPU\r
+// fillchar(treg,sizeof(treg),false);\r
+\r
+ treg[0]:=false;\r
+ treg[1]:=false;\r
+ treg[2]:=false;\r
+\r
+ proc:=true;\r
+ proc_name:=ety+'.';\r
+\r
+ // sprawdzamy poprawnosc nawiasow, usuwamy poczatkowy i koncowy nawias\r
+\r
+ txt:=ciag_ograniczony(i,zm,true);\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ ptype := __pDef; // domyslny typ procedury __pDef\r
+\r
+ // sprawdzamy czy jest okreslony typ procedury .REG\r
+ if zm[i]='.' then begin\r
+ //str:=get_datUp(i,zm,#0,false);\r
+ str:=get_directive(i,zm);\r
+ \r
+ v := fCRC16(str);\r
+\r
+ if not(v in [__reg, __var]) then blad_und(zm,str,68);\r
+\r
+ ptype := str[2];\r
+ t_prc[proc_nr].typ := ptype;\r
+ end;\r
+\r
+ if ptype=__pVar then\r
+ if pass_end<3 then pass_end:=3; // jesli sa parametry .VAR to musza byc conajmniej 3 przebiegi\r
+\r
+ // sprawdzamy obecnosc deklaracji dla programowego stosu MADS'a\r
+ \r
+ if ptype=__pDef then begin\r
+ adr_label(0,true); // @stack_pointer, test obecnosci deklaracji etykiety\r
+ adr_label(1,true); // @stack_address, test obecnosci deklaracji etykiety\r
+ adr_label(2,true); // @proc_vars_adr, test obecnosci deklaracji etykiety\r
+ end;\r
+\r
+\r
+ j:=1;\r
+ ch:=' '; // jesli ch=' ' to odczytuj typ parametru\r
+\r
+ while j<=length(txt) do begin\r
+\r
+ if ch=' ' then begin\r
+ v:=get_type(j,txt,zm,true);\r
+ ch:=relType[ v ]; // typ parametru 'B', 'W', 'L', 'D' z relType\r
+ end;\r
+\r
+\r
+ // odczytujemy nazwe parametru lub !!! wyrazenie !!! (np. label+1)\r
+ // parametry mo¿emy rozdzielac znakiem przecinka\r
+ // spacja sluzy do okreslenia nowego typu parametru\r
+\r
+ omin_spacje(j,txt);\r
+ str:=get_dat(j,txt,',',true); // parametr lub wyrazenie\r
+ if str='' then blad(zm,15);\r
+\r
+\r
+ // jesli .REG to nazwy parametrow sa 1-literowe A,X,Y lub 2-literowe AX, AY itp.\r
+ // nazwy parametrow moga powtorzyc sie tylko raz\r
+ // dla .REG dopuszczalne sa tylko parametry typu .BYTE, .WORD, .LONG\r
+ if ptype=__pReg then begin\r
+\r
+ if not(TypeToByte(ch)=length(str)) then blad_und(zm,str,41);\r
+\r
+ for l:=1 to length(str) do begin\r
+\r
+ v:=RegToByte(UpCase(str[l])) and 3;\r
+\r
+ if v=3 then\r
+ blad_und(zm,str[l],61) // CPU doesn't have register ?\r
+ else\r
+ if treg[v] then\r
+ blad(zm,11) // CPU doesn't have so many registers\r
+ else\r
+ treg[v]:=true;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+ omin_spacje(j,txt);\r
+\r
+ // wstepnie zapamietujemy etykiety parametrow jako wartosc NR_PARAM dla __pDef\r
+\r
+ case ptype of\r
+ __pDef: save_lab(str , nr_param , __id_param , zm);\r
+ __pReg: all:=all+str;\r
+// __pVar: str:=proc_name+lokal_name+str; // potem poszukamy "sciezki" do nazwy parametru\r
+ end;\r
+\r
+ str:=ch+str; save_par(str);\r
+\r
+ inc(k); // zwiekszamy licznik odczytanych parametrow procedury\r
+\r
+ inc( nr_param , TypeToByte(ch) ); // zwiekszamy NR_PARAM o dlugosc danych\r
+\r
+ if txt[j]<>',' then\r
+ ch:=' '\r
+ else\r
+ inc(j);\r
+\r
+ end; // while\r
+\r
+ end; // if zm[i] = '('\r
+\r
+\r
+ if t_prc[proc_nr].typ = __pReg then begin\r
+ // maksymalnie 3 bajty mozna przekazac za pomoca rejestrow\r
+ if nr_param>3 then blad(zm,11);\r
+\r
+ // zapisujemy kolejnosc rejestrow\r
+ t_prc[proc_nr].reg := (RegToByte(all[1]) and $c0) or (RegToByte(all[2]) and $30) or (RegToByte(all[3]) and $0c);\r
+ end;\r
+\r
+ t_prc[proc_nr].par := k;\r
+ t_prc[proc_nr].ile := nr_param;\r
+\r
+ dreloc.use := old_bool;\r
+end;\r
+\r
+\r
+procedure test_wyjscia(var zm:string; const wyjscie:Boolean);\r
+(*----------------------------------------------------------------------------*)\r
+(* testowanie zakonczenia asemblacji pliku *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+\r
+ if not(wyjscie) then \r
+ if not(run_macro) and not(icl_used) then\r
+ if ifelse<>0 then blad(zm,1) else\r
+ if proc or macro then blad(zm,17) else // !!! koniecznie !!! ... or macro\r
+ if struct.use then blad(zm,56) else\r
+ if aray then blad(zm,60) else\r
+ if rept then blad(zm,43) else\r
+ if lokal_nr>0 then blad(zm,29) else\r
+ if pag_idx>0 then blad(zm,65) else\r
+ if whi_idx>0 then blad(zm,89) else\r
+ if test_idx>0 then blad(zm,96);\r
+end;\r
+\r
+\r
+function fgetB(var i:integer): byte;\r
+begin\r
+ Result := t_lnk[i];\r
+ inc(i);\r
+end;\r
+\r
+function fgetW(var i:integer): integer;\r
+begin\r
+ Result := t_lnk[i] + t_lnk[i+1] shl 8;\r
+ inc(i,2);\r
+end;\r
+\r
+function fgetL(var i:integer): cardinal;\r
+begin\r
+ Result := t_lnk[i] + t_lnk[i+1] shl 8 + t_lnk[i+2] shl 16;\r
+ inc(i,3);\r
+end; \r
+\r
+function fgetD(var i:integer): cardinal;\r
+begin\r
+ Result := t_lnk[i] + t_lnk[i+1] shl 8 + t_lnk[i+2] shl 16 + t_lnk[i+3] shl 24;\r
+ inc(i,4);\r
+end;\r
+\r
+function fgetS(var i:integer): string;\r
+var x, y: integer;\r
+begin\r
+ Result:='';\r
+\r
+ x:=fgetW(i);\r
+\r
+ for y:=x-1 downto 0 do Result:=Result+chr( fgetB(i) );\r
+end;\r
+\r
+\r
+procedure flush_link;\r
+var j, k: integer;\r
+begin\r
+ k:=dlink.len;\r
+\r
+ save_lst('a');\r
+\r
+ if k>0 then\r
+ for j:=0 to k-1 do save_dst(t_ins[j]);\r
+\r
+ inc(adres,k);\r
+\r
+ if dlink.emp>0 then begin\r
+ save_hea; org:=true;\r
+ inc(adres,dlink.emp);\r
+ dlink.emp:=0;\r
+ end;\r
+ \r
+end;\r
+\r
+\r
+procedure get_address(var i:integer; var zm:string);\r
+// nowy adres asemblacji dla .PROC lub .LOCAL\r
+var txt: string;\r
+begin\r
+ t_end[end_idx].old:=adres;\r
+\r
+ // sprawdzamy czy jest nowy adres asemblacji dla .PROC lub .LOCAL\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if zm[i]=',' then begin\r
+ __inc(i,zm);\r
+ txt:=get_dat(i,zm,'(',true);\r
+\r
+ blokuj_zapis:=true; // wymuszamy zapis ORG-a jesli wystapil wczesniej\r
+ save_dst(0);\r
+ blokuj_zapis:=false;\r
+\r
+ org_ofset := adres;\r
+\r
+ adres := integer( oblicz_wartosc(txt,zm) );\r
+\r
+ org_ofset := adres - org_ofset;\r
+\r
+ omin_spacje(i,zm);\r
+ end;\r
+end;\r
+\r
+\r
+procedure get_address_update;\r
+begin\r
+\r
+ dec(adres, t_end[end_idx-1].adr);\r
+ inc(adres, t_end[end_idx-1].old);\r
+\r
+ dec(end_idx);\r
+end;\r
+\r
+\r
+procedure save_extLabel(k:integer; var ety,zm:string; v:byte);\r
+var txt: string;\r
+ len: byte;\r
+ isProc: Boolean;\r
+begin\r
+\r
+ omin_spacje(k,zm);\r
+\r
+ if v=__proc then begin // etykieta external deklaruje procedure\r
+\r
+ proc_nr:=proc_idx; // koniecznie przez ADD_PROC_NR\r
+\r
+ if pass=0 then begin\r
+ txt:='##'+ety; // zapisujemy etykiete ze znakami ##\r
+ get_procedure(txt,ety,zm,k); // odczytujemy parametry\r
+\r
+ proc:=false; // koniecznie wylaczamy PROC\r
+ proc_name:=''; // i koniecznie PROC_NAME:=''\r
+ end;\r
+\r
+ add_proc_nr; // zwiekszamy numer koniecznie\r
+\r
+ save_lab(ety,extn_idx,__id_ext,zm);\r
+\r
+ len:=2; // typu .WORD\r
+ isProc:=true;\r
+\r
+ end else begin\r
+\r
+ dec(v, __byteValue); // normalna etykieta external\r
+\r
+ save_lab(ety, extn_idx, __id_ext, zm);\r
+\r
+ len:=v;\r
+ isProc:=false;\r
+\r
+ end;\r
+\r
+ t_extn[extn_idx].nam:=ety; // SAVE_EXTN\r
+ t_extn[extn_idx].siz:=relType[len]; //\r
+ t_extn[extn_idx].prc:=isProc; //\r
+\r
+ inc(extn_idx);\r
+\r
+ if extn_idx>High(t_extn) then SetLength(t_extn,extn_idx+1);\r
+end;\r
+\r
+\r
+procedure get_maeData(var zm:string; var i:integer; const typ:char);\r
+var _odd, _doo, idx, j, tmp: integer;\r
+ txt, hlp: string;\r
+ v, war: byte;\r
+\r
+ par: _strArray;\r
+begin\r
+\r
+ save_lst('a');\r
+\r
+ get_parameters(i,zm,par,true, '.',':');\r
+\r
+ _doo:=High(par);\r
+\r
+ if _doo>0 then begin\r
+\r
+ _odd:=0;\r
+ war:=0;\r
+\r
+ if (typ in ['B','S']) and (_doo>1) then begin\r
+\r
+ txt:=par[0]; // mozliwa wartosc, ktora bedziemy dodawac do reszty ciagu\r
+ // pod warunkiem ze ciag liczy wiecej niz 1 element\r
+\r
+ if txt[1] in ['+','-'] then begin\r
+ j:=1; war:=byte( ___wartosc_noSPC(txt,zm,j,#0,'B') );\r
+ inc(_odd);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ for idx:=_odd to _doo-1 do begin // wlasciwe dekodowanie ciagu\r
+ txt:=par[idx];\r
+\r
+ if txt[1] in ['''','"'] then begin\r
+\r
+ j:=1; hlp:=get_string(j,txt,zm,true);\r
+\r
+ omin_spacje(j,txt);\r
+\r
+ if length(txt)>=j then\r
+ if not(txt[j] in ['*','+','-']) then blad_ill(zm,txt[j]);\r
+\r
+ v:=war;\r
+ \r
+ inc(v, test_string(j,txt,'F'));\r
+\r
+ if typ='S' then\r
+ save_dta(0,hlp,'D', v)\r
+ else\r
+ save_dta(0,hlp,'C', v);\r
+\r
+ end else\r
+\r
+ case typ of\r
+ 'B', 'H', 'S':\r
+ begin\r
+ if typ='H' then txt:='$'+txt;\r
+\r
+ j:=1; v := byte( ___wartosc_noSPC(txt,zm,j,#0,'B') );\r
+\r
+ if typ='S' then v:=ata2int(v);\r
+\r
+ inc(v, war); //v:=v + war;\r
+\r
+ save_dst(v);\r
+ inc(adres);\r
+ end;\r
+\r
+ 'W': begin\r
+ j:=1; tmp := integer( ___wartosc_noSPC(txt,zm,j,#0,'A') );\r
+ save_dstW( tmp );\r
+ inc(adres,2);\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function asm_test(var lar,rar,old, jump:string; const typ,op:byte): int5;\r
+(*----------------------------------------------------------------------------*)\r
+(* generujemy kod testujacy warunek dla .WHILE, .TEST *)\r
+(*----------------------------------------------------------------------------*)\r
+var hlp: int5;\r
+ txt: string;\r
+ adr: integer;\r
+begin\r
+\r
+ adr:=adres;\r
+\r
+ if lar[1]='#' then blad(old,58); // argument nierealny :)\r
+\r
+ case typ of\r
+ 1: txt:='CPB';\r
+ 2: txt:='CPW';\r
+ 3: txt:='CPL';\r
+ else\r
+ txt:='CPD';\r
+ end;\r
+\r
+ TestWhileOpt:=not(op in [0,4]); // krótszy kod jesli operator '=', '<>'\r
+\r
+ txt:=txt+#32+lar+#32+rar;\r
+ Result:=asm_mnemo(txt, old);\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* 0 <> 4 = xor 4 *)\r
+(* 1 >= 5 < *)\r
+(* 2 <= 6 > *)\r
+(*----------------------------------------------------------------------------*)\r
+\r
+ case op of\r
+ 0: txt:='JNE'; // <>\r
+ 1: txt:='JCS'; // >=\r
+ 2: txt:='JCC '+jump; // <=\r
+ 4: txt:='JEQ'; // =\r
+ 5: txt:='JCC'; // <\r
+ 6: txt:='SEQ'; // >\r
+ end;\r
+\r
+\r
+ if op in [2,6] then begin\r
+\r
+ hlp:=asm_mnemo(txt,old);\r
+ addResult(hlp,Result);\r
+\r
+ if op=2 then\r
+ txt:='JEQ'\r
+ else begin\r
+ test_skipa;\r
+ txt:='JCS';\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ txt:=txt+#32+jump;\r
+ hlp:=asm_mnemo(txt,old);\r
+ addResult(hlp,Result);\r
+\r
+ adres := adr; // przywracamy poczatkowa wartosc ADRES\r
+end;\r
+\r
+\r
+procedure create_long_test(const _v, _r:byte; var long_test, _lft, _rgt:string);\r
+var txt: string;\r
+begin\r
+\r
+ case _v xor 4 of\r
+ 0: txt:='<>';\r
+ 1: txt:='>=';\r
+ 2: txt:='<=';\r
+ 4: txt:='=';\r
+ 5: txt:='<';\r
+ 6: txt:='>';\r
+ end;\r
+\r
+ if long_test<>'' then long_test:=long_test+'\';\r
+\r
+ long_test:=long_test+'.TEST '+mads_param[_r]+_lft+txt+_rgt+'\ LDA:SNE#1\.ENDT\ LDA#0';\r
+\r
+ long_test:=long_test+'\.IF .GET[?I-1]=41\ AND EX+?J-2+1\ STA EX+?J-2+1\ ?I--\ ELS\ STA EX+?J+1\ ?J+=2\ EIF\';\r
+\r
+end;\r
+\r
+\r
+procedure wyrazenie_warunkowe(var i:integer; var long_test, zm,left,right:string; var v,r:byte; const strend: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* generowanie kodu dla warunku .WHILE, .TEST *)\r
+(*----------------------------------------------------------------------------*)\r
+var str, txt, _lft, _rgt, kod: string;\r
+ k, j : integer;\r
+ _v, _r: byte;\r
+begin\r
+\r
+ if zm='' then blad(zm,23);\r
+\r
+ r:=get_type(i,zm,zm,true);\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ str:=get_dat(i,zm,#0, false);\r
+\r
+ k:=1;\r
+\r
+ right:='';\r
+ left:=''; // czytamy do LEFT dopóki nie napotkamy operatorów '=', '<', '>', '!'\r
+\r
+ if str<>'' then\r
+ while not(_ope(str[k])) and not(test_char(k,str,#0,#0)) do begin\r
+\r
+ if str[k] in ['[','(','{'] then\r
+ left:=left + ciag_ograniczony(k,str,false)\r
+ else begin\r
+ if str[k]<>' ' then left:=left + str[k];\r
+ inc(k);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ omin_spacje(k,str);\r
+\r
+\r
+ v:=$ff;\r
+\r
+ if left<>'' then begin\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* 0 <> 4 = xor 4 *)\r
+(* 1 >= 5 < *)\r
+(* 2 <= 6 > *)\r
+(*----------------------------------------------------------------------------*)\r
+ \r
+ case str[k] of // szukamy znanej kombinacji operatorów\r
+\r
+ #0: v:=$80; // koniec ci¹gu\r
+\r
+ '=': case str[k+1] of\r
+ '=': begin\r
+ v:=4; // ==\r
+ inc(k);\r
+ end;\r
+ else\r
+ v:=4; // =\r
+ end;\r
+\r
+ '!': case str[k+1] of\r
+ '=': v:=0; // !=\r
+ end;\r
+\r
+ '<': case str[k+1] of\r
+ '>': v:=0; // <>\r
+ '=': v:=2; // <=\r
+ else\r
+ v:=5; // <\r
+ end;\r
+\r
+ '>': case str[k+1] of\r
+ '=': v:=1; // >=\r
+ else\r
+ v:=6; // >\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+\r
+ if v<$80 then begin\r
+\r
+ if v<4 then\r
+ inc(k,2)\r
+ else\r
+ inc(k);\r
+\r
+ if _ope(str[k]) then blad_ill(zm, str[k]);\r
+\r
+ v:=v xor 4;\r
+\r
+ omin_spacje(k,str);\r
+\r
+ right:=get_dat(k,str,#0,true); //get_dat_noSPC(k,str,#0,#0,zm);\r
+\r
+ end else\r
+ if v=$80 then begin // dla pustego ciagu domyslna operacja '<>0'\r
+ v:=4;\r
+ right:='#0';\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ // V = $FF oznacza brak operatora\r
+\r
+ if (left='') or (right='') or (v=$ff) then begin\r
+ blad(zm,58); koniec(2);\r
+ end;\r
+\r
+\r
+ // jesli wystêpuj¹ operatory .OR, .AND to generujemy specjalny kod\r
+\r
+ omin_spacje(k,str);\r
+\r
+ kod:='';\r
+\r
+ if not(test_char(k,str,#0,#0)) then begin\r
+\r
+ txt:=get_dat(k,str,#0,true);\r
+\r
+ if txt='.OR' then\r
+ kod:='9'\r
+ else\r
+ if txt='.AND' then\r
+ kod:='41';\r
+{ else\r
+ blad(zm,58);}\r
+\r
+ end;\r
+\r
+\r
+ if kod<>'' then begin\r
+\r
+ if long_test='' then long_test:=long_test+'.LOCAL\.PUT[0]=0\?I=1\?J=0';\r
+\r
+ omin_spacje(k,str);\r
+ txt:=get_dat(k,str,#0,false);\r
+\r
+ j:=1; wyrazenie_warunkowe(j, long_test, txt,_lft,_rgt, _v, _r, '.PUT[?I]='+kod+'\ ?I++');\r
+ end;\r
+\r
+\r
+ if (long_test<>'') then begin\r
+ create_long_test(v, r, long_test, left, right);\r
+ long_test:=long_test+strend;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function BCD(const l,r:char): byte;\r
+begin\r
+ Result:=byte( (ord(l)-ord('0')) shl 4 + (ord(r)-ord('0')) );\r
+end;\r
+\r
+\r
+procedure save_fl(var a,old:string);\r
+(*----------------------------------------------------------------------------*)\r
+(* zapisujemy liczbe real w formacie FP Atari *)\r
+(*----------------------------------------------------------------------------*)\r
+var i, c, e: integer;\r
+ fl, tmp: string;\r
+ x: real;\r
+ v: byte;\r
+begin\r
+\r
+ val(a, x,i);\r
+ if i>0 then blad_ill(old,a[i]);\r
+\r
+ str(x, fl);\r
+\r
+ tmp:=copy(fl,pos('E',fl)+1,length(fl)); // odczytujemy wartosc E\r
+ e:=integer( StrToInt(tmp) );\r
+\r
+ c:=pos('.',fl); // pozycja znaku '.'\r
+\r
+ if e and 1<>0 then // jesli E jest nieparzyste to modyfikujemy\r
+ while c<>4 do begin\r
+\r
+ if c<4 then begin\r
+ fl[c]:=fl[c+1]; // przesuwamy w prawo\r
+ fl[c+1]:='.';\r
+ dec(e);\r
+ inc(c);\r
+ end else begin\r
+ fl[c]:=fl[c-1]; // przesuwamy w lewo\r
+ fl[c-1]:='.';\r
+ inc(e);\r
+ dec(c);\r
+ end;\r
+\r
+ end;\r
+\r
+ e:=e div 2;\r
+\r
+ if (c>4) or (abs(e)>64) then blad(old,0); // przekroczony zakres FP Atari\r
+\r
+ v:=byte(64+e);\r
+ if fl[1]='-' then v:=v or $80;\r
+\r
+ save_dst(v);\r
+\r
+ if c=4 then // dwie cyfry\r
+ v:=BCD(fl[2],fl[3])\r
+ else // jedna cyfra\r
+ v:=BCD('0',fl[2]);\r
+\r
+ save_dst(v);\r
+\r
+ i:=c+1;\r
+\r
+ v:=BCD(fl[i], fl[i+1]); inc(i,2); save_dst(v);\r
+ v:=BCD(fl[i], fl[i+1]); inc(i,2); save_dst(v);\r
+ v:=BCD(fl[i], fl[i+1]); inc(i,2); save_dst(v);\r
+ v:=BCD(fl[i], fl[i+1]); save_dst(v);\r
+\r
+ inc(adres,6); // zapisalismy 6 bajtow\r
+\r
+end;\r
+\r
+\r
+function getMemType(var i: integer; var zm: string): byte;\r
+begin\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ Result := 0;\r
+ case UpCase(zm[i]) of\r
+ 'M': Result:=0; // M[ain]\r
+ 'E': Result:=2; // E[xtended]\r
+ else\r
+ blad(zm,23);\r
+ end;\r
+\r
+ memType := Result;\r
+end;\r
+\r
+\r
+\r
+function directive(var zm:string; const kod:byte): byte;\r
+(*----------------------------------------------------------------------------*)\r
+(* odczyt dyrektywy lub innego ciagu znakowego i obliczenie kodu *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+ z: string;\r
+ old_case, space: Boolean;\r
+ label LOOP;\r
+begin\r
+ Result:=0;\r
+\r
+LOOP:\r
+ \r
+ if zm<>'' then begin\r
+\r
+ i:=1;\r
+ omin_spacje(i,zm);\r
+\r
+ space:=i<>1; // sprawdzamy czy wystepuja spacje ("biale znaki")\r
+\r
+ old_case := case_used; // zapamietujemy poprzednia wartosc CASE_USED\r
+ case_used := false; // wymuszamy duze litery CASE_USED = FALSE\r
+\r
+ z:=get_lab(i,zm,false);\r
+\r
+ case_used := old_case;\r
+\r
+\r
+ if space or labFirstCol then begin\r
+ Result:=fASC(z);\r
+ if Result<>0 then exit;\r
+ end;\r
+\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if zm[i]='{' then begin\r
+\r
+ if end_idx>0 then begin\r
+ if t_end[end_idx-1].sem then blad(zm,58);\r
+ t_end[end_idx-1].sem:=true;\r
+\r
+ wymus_zapis_lst(zm);\r
+\r
+ zm:=copy(zm, i+1, length(zm));\r
+\r
+ goto LOOP;\r
+ end else\r
+ blad(zm,58);\r
+\r
+ end else\r
+\r
+ if zm[i]='}' then begin\r
+\r
+ if end_idx>0 then\r
+ if t_end[end_idx-1].sem then begin\r
+ __inc(i,zm);\r
+ if not(test_char(i,zm,#0,#0)) then blad(zm,58);\r
+ Result:=__dend;\r
+ end else\r
+ blad(zm,58);\r
+ \r
+ end else\r
+\r
+ if i<length(zm) then\r
+ if _dir_first(zm[i]) then begin\r
+ z:=get_directive(i,zm);\r
+ Result:=fCRC16(z);\r
+ end else begin\r
+ z:=get_datUp(i,zm,#0,false);\r
+ Result:=fASC(z);\r
+ end;\r
+\r
+\r
+ if (Result=__dend) and (end_idx>0) then begin\r
+ if t_end[end_idx-1].kod = kod then Result:=kod;\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function dirMACRO(var zm:string): byte;\r
+(*----------------------------------------------------------------------------*)\r
+(* odczyt makra zdefiniowanego przez dyrektywy .MACRO, .ENDM [.MEND] *)\r
+(* !!! wyjatkowo dyrektywa .END nie mo¿e koñczyc definicji makra !!! *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ save_lst(' '); // .MACRO\r
+\r
+ Result:=directive(zm, __endm);\r
+\r
+ if (Result=__macro) and macro then blad(zm,17);\r
+\r
+ if Result=__endm then macro := false;\r
+\r
+ if (pass=0) and if_test then save_mac(zm); // !!! makra zapisujemy tylko w 1 przebiegu !!!\r
+\r
+ zapisz_lst(zm);\r
+end;\r
+\r
+\r
+procedure dirENDR(var zm,a,old_str:string; var rept_nr,rept_ile:integer);\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDR - wykonanie petli .REPT *)\r
+(*----------------------------------------------------------------------------*)\r
+var tmp, lntmp: integer;\r
+ txt: string;\r
+ old_if_test: Boolean;\r
+begin\r
+\r
+ if if_test then\r
+ if not(rept) then blad(zm,51) else begin\r
+\r
+ wymus_zapis_lst(zm);\r
+\r
+ rept := false;\r
+ rept_run := true;\r
+\r
+ tmp := ___rept_ile;\r
+\r
+ lntmp := line_add;\r
+\r
+\r
+ ___rept_ile := StrToInt(t_mac[rept_nr]);\r
+\r
+ line_add := StrToInt(t_mac[rept_nr+1]);\r
+\r
+ old_if_test := if_test;\r
+\r
+\r
+ if not(run_macro) then begin\r
+ txt := 'REPT';\r
+ put_lst(show_full_name(txt,false,true));\r
+ end;\r
+\r
+\r
+ analizuj_mem__(rept_nr+2,High(t_mac), zm,a,old_str, 0,rept_ile, true);\r
+\r
+\r
+ rept_run := false;\r
+\r
+ if not(run_macro) and not(rept) then put_lst(show_full_name(a,full_name,true));\r
+\r
+\r
+ line_add := lntmp;\r
+\r
+ if_test := old_if_test;\r
+\r
+ ___rept_ile := tmp;\r
+\r
+ SetLength(t_mac, rept_nr+1);\r
+\r
+ dec_end(zm, __endr);\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure reptLine(var txt: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* podstawianie parametrow w bloku .REPT *)\r
+(*----------------------------------------------------------------------------*)\r
+var ety, tmp: string;\r
+ j, k, war: integer;\r
+begin\r
+ j:=1;\r
+ while j<=length(txt) do\r
+ if test_param(j,txt) then begin\r
+\r
+ k:=j;\r
+ if txt[j]=':' then inc(j) else inc(j,2);\r
+\r
+ ety:='';\r
+ while _dec(txt[j]) do begin ety:=ety+txt[j]; inc(j) end;\r
+\r
+ war:=StrToInt(ety);\r
+\r
+ \r
+ if war<High(reptPar) then begin\r
+\r
+ delete(txt,k,j-k); dec(j,j-k);\r
+\r
+ tmp:=reptPar[war];\r
+\r
+ war:=oblicz_wartosc(tmp, txt);\r
+\r
+ tmp:=IntToStr(war);\r
+\r
+{ if tmp[1]='#' then\r
+ tmp:=IntToStr(___rept_ile)\r
+ else\r
+ if (tmp[1]='"') and (tmp[length(tmp)]='"') then tmp:=copy(tmp,2,length(tmp)-2);\r
+}\r
+ insert(tmp,txt,k);\r
+ inc(j,length(tmp));\r
+ end;\r
+\r
+ end else inc(j);\r
+\r
+end;\r
+\r
+\r
+function dirREPT(var zm: string): byte; \r
+(*----------------------------------------------------------------------------*)\r
+(* analiza linii gdy wystapilo .REPT *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ save_lst(' ');\r
+\r
+ Result:=directive(zm, __endr);\r
+\r
+ if (Result=__rept) and rept then blad(zm,43);\r
+\r
+ if Result<>__endr then begin\r
+ if if_test then save_mac(zm);\r
+ zapisz_lst(zm);\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function get_vars_type(var i:integer; var zm:string; var typ:char; var i_str: integer; var n_str: string): integer;\r
+(*----------------------------------------------------------------------------*)\r
+(* odczytujemy typ dla zmiennych .BYTE, .WORD, .LONG, .DWORD, .STRUCT|.ENUM *)\r
+(*----------------------------------------------------------------------------*)\r
+var txt: string;\r
+ k, x: integer;\r
+begin\r
+\r
+ omin_spacje(i,zm); \r
+\r
+ Result:=0;\r
+ k:=i;\r
+\r
+ if zm[i]='.' then begin\r
+\r
+ txt:=get_directive(i,zm);\r
+ Result:=fCRC16(txt);\r
+\r
+ if Result in [__byte..__dword] then\r
+ dec(Result, __byteValue)\r
+ else begin\r
+ Result:=0; // to nie jest dyrektywa okreslajaca typ danych !!! V=0 !!!\r
+ i:=k; // przywracamy poprzednie wartosci\r
+ end;\r
+\r
+ end else begin\r
+\r
+ txt:=get_lab(i,zm, true); // zatrzyma sie jesli brak etykiety\r
+\r
+ x:=load_lab(txt, true);\r
+\r
+ if x<0 then\r
+ i:=k // etykieta nie zostala zdefiniowana\r
+ else\r
+ case t_lab[x].bnk of\r
+\r
+ __id_enum:\r
+ begin\r
+ Result:=t_lab[x].adr;\r
+\r
+ n_str := txt;\r
+\r
+// typ:='E';\r
+ end;\r
+\r
+ __id_struct:\r
+ begin\r
+ Result:=t_str[t_lab[x].adr].siz;\r
+\r
+ i_str := t_lab[x].adr;\r
+ n_str := txt;\r
+\r
+ typ:='S';\r
+ end;\r
+\r
+ else\r
+ i:=k;\r
+ end;\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure get_vars(var i:integer; var zm:string; var par:_strArray; const mne: byte);\r
+(*----------------------------------------------------------------------------*)\r
+(* .VAR .TYPE v0 [=expression], v1 [=expression] .TYPE v3 [=expression] v4 *)\r
+(* .VAR v0 [=expression] .TYPE v1 [=expression] v2 .TYPE [=address] *)\r
+(* *)\r
+(* odczyt parametrow dla dyrektywy .VAR *)\r
+(*----------------------------------------------------------------------------*)\r
+var idx, _doo, _odd, k, v, i_str: integer;\r
+ txt, str, n_str: string;\r
+ tst: Int64;\r
+ typ: char;\r
+begin\r
+\r
+ i_str:=0;\r
+ n_str:='';\r
+\r
+ typ:='V';\r
+\r
+ v:=get_vars_type(i,zm, typ, i_str, n_str);\r
+\r
+ get_parameters(i,zm,par,false, '.',':');\r
+\r
+ idx:=1;\r
+\r
+ if zm[i]=':' then begin // liczba powtorzen\r
+ inc(i);\r
+ txt:=get_dat(i,zm,',',true);\r
+ idx:=integer( oblicz_wartosc(txt,zm) );\r
+ testRange(zm, idx, 0);\r
+ end;\r
+\r
+ _doo:=High(par);\r
+\r
+ if _doo=0 then blad(zm,23); // brak zmiennych - Unexpected end of line\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if v=0 then\r
+ if zm[i]='.' then\r
+\r
+ v:=get_type(i,zm,zm,true) // typ zmiennej\r
+\r
+ else begin\r
+ txt:=par[_doo-1];\r
+\r
+ k:=1;\r
+ v:=get_vars_type(k,txt,typ, i_str, n_str);\r
+\r
+ if v=0 then\r
+ blad_und(zm,txt,50) // nie zostal okreslony typ zmiennej "Missing type label"\r
+ else begin\r
+ par[_doo-1]:=copy(txt,k,length(txt));\r
+\r
+ dec(_doo); // udalo sie, ostatni element pomijamy\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ for _odd:=0 to _doo-1 do begin\r
+ txt:=par[_odd];\r
+\r
+ k:=1; str:=get_lab(k, txt, true); // sprawdzamy czy etykieta posiada poprawne znaki\r
+\r
+ //if str='' then blad_ill(zm,txt[1]); // pierwszy znak etykiety jest niewlasciwy\r
+\r
+\r
+ tst:=0;\r
+\r
+ if txt[k]='=' then begin // czy zmienna jest inicjowana ('=')\r
+\r
+ if (mne=__zpvar) and (pass=pass_end) then warning(114);\r
+\r
+ txt:=copy(txt,k+1,length(txt));\r
+\r
+ tst:=oblicz_wartosc(txt,zm);\r
+\r
+ if ValueToType(tst) > v then blad(zm,0);\r
+\r
+ end else\r
+ if not(test_char(k,txt,#0,#0)) then blad_ill(zm,txt[k]); // wystapil niedozwolony znak\r
+\r
+\r
+ if proc then // SAVE_VAR\r
+ t_var[var_idx].lok := proc_lokal //\r
+ else //\r
+ t_var[var_idx].lok := end_idx; //\r
+ //\r
+ if proc and (lokal_name<>'') then //\r
+ t_var[var_idx].nam := lokal_name+str //\r
+ else //\r
+ t_var[var_idx].nam := str; //\r
+ //\r
+ t_var[var_idx].siz := v; //\r
+ t_var[var_idx].cnt := idx; //\r
+ t_var[var_idx].war := cardinal (tst); //\r
+ //\r
+ t_var[var_idx].adr := -1; //\r
+ //\r
+ t_var[var_idx].id := var_id; //\r
+ t_var[var_idx].typ := typ; //\r
+ t_var[var_idx].idx := i_str; //\r
+ t_var[var_idx].str := n_str; //\r
+\r
+ inc(var_idx);\r
+\r
+ if var_idx>High(t_var) then SetLength(t_var,var_idx+1);\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure opt_h_minus;\r
+begin\r
+ opt:=opt and $fe;\r
+end;\r
+\r
+\r
+procedure upd_structure(var ety, zm: string);\r
+var idx: integer;\r
+ txt: string;\r
+begin\r
+ struct.cnt := 0;\r
+\r
+ txt:=lokal_name+ety; // pelna nazwa struktury .STRUCT\r
+\r
+ // sprawdzamy czy mamy juz zapamietana ta strukture\r
+ idx:=loa_str(txt, struct.id);\r
+\r
+ // nie znalazl ofsetu do tablicy (idx = -1)\r
+ if idx<0 then begin\r
+\r
+ save_str(txt,adres,0,1,adres,bank); // dopisz do tablicy T_STR nowa strukture\r
+\r
+ struct.idx:=loa_str(txt, struct.id);\r
+\r
+ save_lab(ety,struct.idx, __id_struct,zm);\r
+\r
+ end else begin\r
+ // znalazl ofset do tablicy\r
+ struct.idx:=idx;\r
+\r
+ save_lab(ety,struct.idx, __id_struct,zm);\r
+ end;\r
+\r
+ if pass_end<3 then pass_end:=3; // jesli sa struktury to musza byc conajmniej 3 przebiegi\r
+\r
+end;\r
+\r
+\r
+\r
+procedure search_comment_block(var i:integer; var zm,txt:string);\r
+var k: integer;\r
+begin\r
+\r
+ if (zm<>'') and (i<length(zm)) then begin\r
+\r
+ k:=i;\r
+\r
+ if (zm[i]='/') and (zm[i+1]='*') then begin\r
+ komentarz:=true; inc(i,2);\r
+ end;\r
+\r
+ while komentarz and (i<=length(zm)) do\r
+ if (zm[i]='*') and (zm[i+1]='/') then begin\r
+ inc(i,2);\r
+ txt:=txt+copy(zm,k,i-k);\r
+\r
+ komentarz:=false; Break\r
+ end else\r
+ inc(i);\r
+\r
+ end;\r
+\r
+end;\r
+\r
+\r
+\r
+procedure wypisz(var i: integer; var zm: string);\r
+var txt: string;\r
+begin\r
+ // save_lst(' ');\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if not(test_char(i,zm,#0,#0)) then begin\r
+\r
+ pisz := true;\r
+ branch := true; // dla .PRINT nie istnieje relokowalnosc\r
+\r
+ txt:=end_string; end_string:='';\r
+\r
+ oblicz_dane(i,zm,zm,4);\r
+\r
+ pisz := false;\r
+\r
+ save_lst(' ');\r
+ justuj;\r
+ put_lst(t+zm);\r
+\r
+ save_lst(' ');\r
+\r
+ zm:=end_string; // !!! aby umiescil tekst w listingu !!!\r
+\r
+ end_string := txt + end_string + #13#10;\r
+\r
+ end;\r
+end;\r
+\r
+\r
+procedure analizuj_linie (var zm,a,old_str:string; var rept_nr,rept_ile,nr:integer; var end_file,wyjscie:Boolean);\r
+var g: file;\r
+ f: textfile;\r
+ v, r, opt_tmp: byte;\r
+ ch, rodzaj, typ: char;\r
+ i, k, j, m, _odd, _doo, idx, idx_get, rpt, old_ifelse, old_rept, indeks: integer;\r
+ old_loopused, old_icl_used, old_case, old_run_macro, old_komentarz: Boolean;\r
+ ety, txt, str, tmp, old_macro_nr, long_test, tmpZM: string;\r
+ war: Int64;\r
+ tst, vtmp: cardinal;\r
+\r
+ reloc_value: relVal;\r
+\r
+ mne: int5;\r
+ par: _strArray;\r
+\r
+ label JUMP, LOOP, JUMP_2;\r
+begin\r
+\r
+ i:=1;\r
+\r
+ if not(struct.use) and not(enum.use) then label_type:='V';\r
+ \r
+ overflow:=false;\r
+\r
+ mne.l:=0; rpt:=0;\r
+\r
+ data_out:=false;\r
+\r
+ reloc_value.use:=false; reloc_value.cnt:=0; rel_used:=false;\r
+\r
+ m:=i; // zapamietujemy poczatkowa wartosc 'i'\r
+\r
+\r
+ if zm='' then begin\r
+\r
+ mne_used := false; // nie zostal odczytany mnemonik (!!! koniecznie w tym miejscu !!!)\r
+\r
+ save_lst(' ');\r
+ put_lst(t);\r
+\r
+ exit;\r
+ end;\r
+\r
+\r
+LOOP:\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* odczytujemy etykiete z lewej strony, od pierwszego znaku w linii *)\r
+(* jesli jest zakonczona dwukropkiem to pomijamy dwukropek *)\r
+(*----------------------------------------------------------------------------*)\r
+ ety:=get_lab(i,zm, false);\r
+ if (zm[i]=':') and (_eol(zm[i+1])) then inc(i);\r
+\r
+ omin_spacje(i,zm);\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* a moze jest jakas etykieta poprzedzona bialymi spacjami i zakonczona ':' *)\r
+(*----------------------------------------------------------------------------*)\r
+ if ety='' then begin\r
+ k:=i;\r
+ txt:=get_lab(i,zm, false);\r
+\r
+ if txt<>'' then\r
+ if ((zm[i]=':') and (_eol(zm[i+1]))) or struct.use or enum.use then begin\r
+ ety:=txt;\r
+ __inc(i,zm);\r
+ end else\r
+ i:=k;\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* etykiety moga byc rozkazami CPU lub pseudo rozkazami jesli labFirstCol=true*)\r
+(* etykiet w stylu MAE to nie dotyczy, one sa rozpoznawane klasycznie *)\r
+(* nie dotyczy to takze etykiet deklarowanych w .STRUCT *)\r
+(*----------------------------------------------------------------------------*)\r
+ if (length(ety)=3) and not(struct.use) and not(mae_labels) and labFirstCol then\r
+ if reserved(ety) then begin\r
+ i:=m;\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* pierwszymi znakami moga byc tylko znaki poczatkujace nazwe etykiety, *)\r
+(* znaki konca linii oraz '.', ':', '*', '+', '-', '=' *)\r
+(* dopuszczalne sa instrukcje generujace kod 6502 #IF #WHILE #END *)\r
+(*----------------------------------------------------------------------------*)\r
+// if not(aray) and not(struct.use) and not(enum.use) then\r
+ if not(_first_char(zm[i])) and not(test_char(i,zm,#0,#0)) then\r
+\r
+ case zm[i] of\r
+\r
+ '#': begin\r
+ tmp:=get_directive(i,zm);\r
+\r
+ mne.l:=fCRC16(tmp);\r
+ if not(mne.l in [__test, __while, __dend, __telse]) then blad(zm,12);\r
+\r
+ goto JUMP_2;\r
+\r
+ end;\r
+\r
+ '{': if end_idx>0 then begin\r
+\r
+ if t_end[end_idx-1].sem then blad(zm,58);\r
+ \r
+ t_end[end_idx-1].sem:=true;\r
+ inc(i);\r
+\r
+ goto LOOP;\r
+ \r
+ end else\r
+ blad(zm,12);\r
+\r
+ '}': if end_idx>0 then\r
+ if t_end[end_idx-1].sem then begin\r
+ __inc(i,zm);\r
+\r
+ if not(test_char(i,zm,#0,#0)) then blad(zm,58);\r
+\r
+ mne.l:=t_end[end_idx-1].kod;\r
+ end else\r
+ blad(zm,12);\r
+\r
+ else\r
+ if (mne.l=0) and not(aray) and not(struct.use) and not(enum.use) then blad(zm,12);\r
+ end;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy czy wystapila deklaracja lokalna etykiety *)\r
+(* znak '=' moze zastepowac EQU, nie musi byc poprzedzony "bialymi spacjami" *)\r
+(* znaki '+=' , '-=' zastepuja dodawanie i odejmowanie wartosci od etykiety *)\r
+(* znaki '--' , '++' zastepuja zmniejszanie i zwiekszanie wartosci etykiety *)\r
+(*----------------------------------------------------------------------------*)\r
+ tmpZM:=zm;\r
+\r
+ if zm[i] in ['+','-'] then\r
+ if (ety<>'') and (zm[i+1] in ['+','-','=']) then\r
+ operator_zlozony(i,zm,ety, false)\r
+ else\r
+ blad(zm,4);\r
+\r
+ if (zm[i]='=') and not(aray) and not(struct.use) and not(enum.use) then begin\r
+ mne.l:=__addEqu; __inc(i,zm); // wymuszamy wykonanie __addEQU\r
+\r
+ save_lst(' ');\r
+\r
+ goto JUMP;\r
+ end;\r
+\r
+\r
+ if ifelse>0 then save_lst(' ');\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* znak okreslajacy liczbe powtorzen linii ':' *)\r
+(*----------------------------------------------------------------------------*)\r
+ if (zm[i]=':') then begin\r
+ save_lst('a');\r
+\r
+ inc(i);\r
+ loop_used:=true;\r
+\r
+ txt:=get_dat(i,zm,',',true);\r
+ _doo:=integer( oblicz_wartosc(txt,zm) );\r
+ testRange(zm, _doo, 0);\r
+\r
+\r
+ old_rept := ___rept_ile;\r
+ ___rept_ile := 0;\r
+\r
+\r
+ // test obecnosci czegokolwiek\r
+ k:=i; txt:=get_datUp(i,zm,#0,true); i:=k;\r
+\r
+ if struct.use then begin\r
+\r
+ rpt:=_doo;\r
+ omin_spacje(i,zm);\r
+\r
+ end else begin\r
+\r
+ old_case := FOX_ripit;\r
+ FOX_ripit := true; // zwracamy wartosc licznika petli dla '#'\r
+\r
+ indeks := line_add;\r
+\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ idx:=High(t_mac);\r
+\r
+ txt:=get_dat(i,zm,'\',false);\r
+ save_mac(txt);\r
+\r
+ line_add:=line-1;\r
+\r
+ _odd := idx+1;\r
+ analizuj_mem__(idx,_odd, zm,a,old_str, 0,_doo, false);\r
+\r
+\r
+ loop_used := false;\r
+\r
+ FOX_ripit := old_case;\r
+\r
+ line_add := indeks;\r
+\r
+\r
+ SetLength(t_mac,idx+1);\r
+\r
+ mne.l:=__nill;\r
+ ety:='';\r
+ end;\r
+\r
+ ___rept_ile := old_rept;\r
+\r
+ // FOX_ripit := false;\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* sprawdzamy czy to dyrektywa, tylko niektore dyrektywy moga byc petlone: *)\r
+(* .PRINT, .BYTE, .WORD, .LONG, .DWORD, .GET, .PUT, .HE, .BY, .WO, .SB, .FL *)\r
+(* innych dyrektyw nie mozemy powtarzac *)\r
+(*----------------------------------------------------------------------------*)\r
+ if zm[i]='.' then begin\r
+\r
+ tmp:=get_directive(i,zm);\r
+\r
+ mne.l:=fCRC16(tmp);\r
+\r
+ if not(mne.l in [__macro..__over]) then\r
+ blad_und(zm,tmp,68)\r
+ else\r
+ if loop_used then\r
+ if not(mne.l in [__byte..__dword, __print, __sav, __get, __put, __he, __by, __wo, __sb, __fl]) then blad(zm,36);\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* zamiana IFT ELS EIF ELI na ich odpowiedniki .IF .ELSE .ENDIF .ELSEIF *)\r
+(* zostala zrealizowane przez modyfikacje tablicy HASH *)\r
+(* podobnie dyrektywy .DB i .DW wskazuja na .BYTE i .WORD *)\r
+(* !!! koniecznie tylko w tym miejscu, w innym kod nie zostanie wykonany !!! *)\r
+(*----------------------------------------------------------------------------*)\r
+ if UpCase(zm[i]) in ['E','I'] then begin\r
+\r
+ j:=i;\r
+ txt:=get_datUp(i,zm,#0,false);\r
+ v:=fASC(txt); \r
+\r
+ if length(txt)<>3 then\r
+ i:=j\r
+ else\r
+ if not(v in [__if,__else,__endif,__elseif]) then\r
+ i:=j\r
+ else\r
+ mne.l:=v;\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* zamiana dyrektywy .OR na pseudo rozkaz ORG *)\r
+(* obsluga dyrektywy .NOWARN *)\r
+(*----------------------------------------------------------------------------*)\r
+ case mne.l of\r
+\r
+ __or: mne.l:=__org;\r
+\r
+ __nowarn: begin\r
+ noWarning:=true;\r
+ mne.l:=0;\r
+\r
+// omin_spacje(i,zm); // !!! tutaj omijanie spacji niedopuszczalne !!!\r
+ goto LOOP\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+\r
+ if not(skip.hlt) then test_skipa;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* odczytaj mnemonik *)\r
+(*----------------------------------------------------------------------------*)\r
+ if (mne.l=0) and if_test and not(enum.use) then\r
+ if i<=length(zm) then mne:=oblicz_mnemonik(i,zm,zm);\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* odczyt etykiet wystepujacych w bloku .ENUM *)\r
+(*----------------------------------------------------------------------------*)\r
+ if enum.use then\r
+ if (ety<>'') and (mne.l=0) then begin\r
+\r
+ i:=1;\r
+\r
+ get_parameters(i,zm,par,false, '.',':');\r
+\r
+ old_case := dreloc.use; // deklaracje etykiet w bloku .RELOC nie moga byc relokowalne\r
+ dreloc.use := false;\r
+\r
+ if High(par)>1 then begin\r
+ save_lst(' ');\r
+ justuj;\r
+ put_lst(t+zm);\r
+ end;\r
+\r
+ for _odd:=0 to High(par)-1 do begin\r
+ txt:=par[_odd];\r
+\r
+ k:=1; ety:=get_lab(k, txt, false); // sprawdzamy czy etykieta posiada poprawne znaki\r
+ if ety='' then blad_ill(zm,txt[1]); // pierwszy znak etykiety jest niewlasciwy\r
+\r
+ if txt[k]='=' then begin\r
+ str:=copy(txt,k+1,length(txt));\r
+\r
+ enum.val:=oblicz_wartosc(str,zm);\r
+ end else\r
+ if not(test_char(k,txt,#0,#0)) then blad_ill(zm,txt[k]); // wystapil niedozwolony znak\r
+\r
+\r
+ label_type:='C';\r
+\r
+ branch:=true; // dla etykiet .ENUM nie ma relokowalnosci\r
+\r
+ save_lab(ety, enum.val, bank, zm);\r
+\r
+ bez_lst:=true;\r
+\r
+ if enum.val>enum.max then enum.max:=enum.val; // MAX dla okreslenia rozmiaru ENUM\r
+\r
+ nul.i:=integer( enum.val );\r
+ save_lst('l');\r
+\r
+ if High(par)=1 then\r
+ zapisz_lst(zm)\r
+ else\r
+ zapisz_lst(ety);\r
+\r
+ inc(enum.val);\r
+ end;\r
+\r
+ dreloc.use := old_case;\r
+\r
+ nul.i:=0;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* dodatkowy test dla etykiet w bloku .STRUCT *)\r
+(*----------------------------------------------------------------------------*)\r
+ if struct.use then\r
+ if (ety<>'') and (mne.l=0) then begin\r
+\r
+ idx:=l_lab(ety);\r
+\r
+ if idx<0 then begin\r
+ if pass=pass_end then blad(zm,58)\r
+ end else\r
+ if t_lab[idx].bnk=__id_struct then begin\r
+ mne.l := __struct_run_noLabel;\r
+ mne.i := t_lab[idx].adr;\r
+ end else\r
+ if pass=pass_end then blad(zm,58);\r
+\r
+ end;\r
+\r
+ \r
+JUMP_2:\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .END *)\r
+(* zastepuje inne dyrektywy .END? *)\r
+(*----------------------------------------------------------------------------*)\r
+ if mne.l=__dend then\r
+ if end_idx=0 then\r
+ blad(zm,72)\r
+ else\r
+ mne.l:=t_end[end_idx-1].kod;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* specjalna forma definicji wartosci etykiety tymczasowej za pomoca znakow *)\r
+(* '=' , '+=' , '-=' , '++' , '--' *)\r
+(*----------------------------------------------------------------------------*)\r
+ if mne.l=__addEqu then begin\r
+ ety:=get_lab(i,zm, true);\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ tmpZM:=zm;\r
+\r
+ if UpCase(zm[i])='E' then\r
+ inc(i,2)\r
+ else\r
+ if zm[i] in ['+','-'] then operator_zlozony(i,zm,ety, false);\r
+\r
+ __inc(i,zm);\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* laczenie mnemonikow za pomoca znaku ':', w stylu XASM'a *)\r
+(*----------------------------------------------------------------------------*)\r
+ if mne.l=__xasm then begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ if (pass=pass_end) and skip.use then warning(98); // Skipping only the first instruction\r
+\r
+ save_lst('a');\r
+\r
+ loop_used := true;\r
+\r
+ old_case := case_used; // nie mozemy zamieniac na duze litery\r
+ case_used := true; // zachowujemy ich oryginalna wielkosc (CASE_USED=TRUE)\r
+\r
+ skip.hlt := true; \r
+\r
+\r
+ k:=mne.i;\r
+ ety:=get_dat(k,zm,'\',false); // odczytujemy argumenty\r
+\r
+ case_used := old_case; // przywracamy stara wartosc CASE_USED\r
+\r
+ line_add:=line-1; // numer linii aktualnie przetwarzanej\r
+ // przyda sie jesli wystapi blad\r
+\r
+ idx:=High(t_mac); // indeks do wolnego wpisu w T_MAC\r
+\r
+ while true do begin // petla bez konca ;)\r
+\r
+ old_case := case_used; // tutaj takze musimy zachowac wielkosc liter\r
+ case_used := true; // dlatego wymuszamy CASE_USED=TRUE\r
+\r
+ txt:=get_dat(i,zm,':',true); // odczytujemy mnemonik rozdzielony znakiem ':'\r
+\r
+ case_used := old_case; // przywracamy stara wartosc CASE_USED\r
+\r
+ str:=' '+txt+ety; // preparujemy nowa linie do analizy\r
+ t_mac[idx]:=str; // zapisujemy ja w T_MAC[IDX]\r
+\r
+ test_skipa;\r
+\r
+ _odd := idx+1;\r
+ analizuj_mem__(idx,_odd, zm,a,old_str, 0,1, false);\r
+\r
+ if zm[i]=':' then inc(i) else Break; // tutaj konczymy petle jesli brak ':'\r
+ end;\r
+\r
+ wymus_zapis_lst(zm);\r
+\r
+ line_add:=0; // koniecznie zerujemy LINE_ADD\r
+\r
+ if not(FOX_ripit) then bez_lst := true;\r
+\r
+ loop_used := false;\r
+\r
+ skip.hlt := false;\r
+\r
+ skip.xsm := true; // wystapilo laczenie mnemonikow przez ':'\r
+\r
+ mne.l:=__nill;\r
+ ety:='';\r
+ end else\r
+ if not(mne.l in [0,__nill]) then skip.xsm:=false; // nie wystapilo laczenie mnemonikow przez ':' (default)\r
+\r
+ \r
+JUMP:\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* jesli mamy uruchomione makro to zapisz jego zawartosc do pliku LST *)\r
+(* puste linie nie sa zapisywane, !!! w tej postaci dziala najlepiej !!! *)\r
+(*----------------------------------------------------------------------------*)\r
+ if run_macro and if_test then\r
+ if ety<>'' then data_out:=true;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* BLK (kody __blkSpa, __blkRel, __blkEmp) *)\r
+(*----------------------------------------------------------------------------*)\r
+ if mne.l=__blk then\r
+ if ety<>'' then blad(zm,38) else\r
+ if loop_used then blad(zm,36) else begin\r
+\r
+ empty:=false;\r
+\r
+ txt:=get_datUp(i,zm,#0,true);\r
+\r
+ case UpCase(txt[1]) of\r
+ //BLK D[os] a\r
+ 'D': mne.l := __org;\r
+\r
+ //BLK S[parta] a\r
+ 'S': mne.l := __blkSpa;\r
+\r
+ //BLK R[eloc] M[ain]|E[xtended]\r
+ 'R': mne.l := __blkRel;\r
+\r
+ //BLK E[mpty] a M[ain]|E[xtended]\r
+ 'E': begin mne.l := __blkEmp; empty:=true end;\r
+\r
+ //BLK N[one] a\r
+ 'N': begin mne.l := __org; opt_h_minus end;\r
+\r
+ //BLK U[pdate] A[ddress]\r
+ //BLK U[pdate] E[xternal]\r
+ //BLK U[pdate] S[ymbols]\r
+ //BLK U[pdate] N[ew] address text\r
+ 'U':\r
+ if pass=pass_end then begin\r
+\r
+ oddaj_var;\r
+\r
+ oddaj_ds;\r
+\r
+ txt:=get_datUp(i,zm,#0,true);\r
+\r
+ save_lst('a');\r
+\r
+ _doo:=0; // liczba adresow do relokacji\r
+ _odd:=0; // liczba symboli do relokacji\r
+\r
+ for idx:=0 to rel_idx-1 do\r
+ if t_rel[idx].idx>=0 then inc(_odd) else\r
+ if t_rel[idx].idx=-1 then inc(_doo);\r
+\r
+ case UpCase(txt[1]) of\r
+\r
+ 'A': begin // A[ddress]\r
+ if not(blkupd.adr) then\r
+ if (_doo>0) or dreloc.use then blk_update_address(zm);\r
+ blkupd.adr:=true;\r
+ end;\r
+\r
+ 'E': begin // E[xternal]\r
+ if not(blkupd.ext) then blk_update_external(zm);\r
+ blkupd.ext:=true;\r
+ end;\r
+\r
+ 'P': begin // P[ublic]\r
+ if not(blkupd.pub) then blk_update_public(zm);\r
+ blkupd.pub:=true;\r
+ end;\r
+\r
+ 'S': begin // S[ymbol]\r
+ if not(blkupd.sym) then\r
+ if _odd>0 then blk_update_symbol(zm);\r
+ blkupd.sym:=true;\r
+ end;\r
+\r
+ 'N': begin // N[ew]\r
+ test_symbols := true;\r
+ blk_update_new(i,zm);\r
+ end;\r
+\r
+ else\r
+ blad(zm,23);\r
+ end;\r
+\r
+ end;\r
+\r
+ else\r
+ blad(zm,0);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .DS expression *)\r
+(* rezerwujemy "expression" bajtow bez ich inicjalizowania *)\r
+(*----------------------------------------------------------------------------*)\r
+ if (mne.l=__ds) and (macro_rept_if_test) then begin\r
+\r
+ // po zmianie adresu asemblacji bloku .PROC, .LOCAL nie ma mo¿liwosci u¿ywania dyrektywy .DS\r
+\r
+ if (org_ofset>0) then blad(zm,71);\r
+\r
+ nul.i:=integer( adres );\r
+ save_lst('l');\r
+\r
+ branch:=true;\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ _doo:=integer( oblicz_wartosc_noSPC(zm,zm,i,#0,'A') );\r
+\r
+ if dreloc.sdx or dreloc.use then begin\r
+ empty:=true;\r
+ inc(ds_empty, _doo);\r
+\r
+ inc(adres, _doo);\r
+ end else begin\r
+\r
+ txt:=zm; // !!! tylko tutaj wymuszamy zapis do LST !!!\r
+ zapisz_lst(txt);\r
+\r
+ NoAllocVar:=true; // dla .DS nie ma alokacji zmiennych .VAR \r
+ mne.l:=__org; // teraz mozemy wymusic ORG *+\r
+\r
+ zm:='*+'+IntToStr(_doo);\r
+ i:=1;\r
+\r
+ bez_lst:=true; \r
+ end;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* [label] .ALIGN N[,fill] *)\r
+(*----------------------------------------------------------------------------*)\r
+ if (mne.l=__align) and (macro_rept_if_test) then begin\r
+\r
+ if loop_used then blad(zm,36);\r
+\r
+ save_lst('a');\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if test_char(i,zm,#0,#0) then\r
+ _doo:=$100\r
+ else\r
+ _doo:=integer( oblicz_wartosc_noSPC(zm,zm,i,',','A') );\r
+\r
+\r
+ _odd:=-1;\r
+\r
+ if zm[i]=',' then begin\r
+ __inc(i,zm);\r
+\r
+ _odd:=integer( oblicz_wartosc_noSPC(zm,zm,i,',','B') );\r
+ end;\r
+\r
+\r
+ if _doo>0 then\r
+ idx:=(adres div _doo)*_doo\r
+ else\r
+ idx:=adres;\r
+\r
+ if idx<>adres then inc(idx, _doo);\r
+\r
+\r
+ if _odd>=0 then begin\r
+\r
+ if pass=pass_end then begin\r
+ while idx>adres do begin save_dst(byte(_odd)); inc(adres) end;\r
+ end else\r
+ adres:=idx;\r
+\r
+ end else begin // wymuszenie ORG\r
+\r
+ justuj;\r
+ put_lst(t+zm);\r
+\r
+ bez_lst:=true;\r
+\r
+ zm:='$'+hex(idx,4);\r
+\r
+ NoAllocVar:=true; // dla .ALIGN nie ma alokacji zmiennych .VAR\r
+ mne.l:=__org;\r
+\r
+ i:=1;\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* NMB [adres] *)\r
+(* RMB [adres] *)\r
+(* LMB #expression [,adres] *)\r
+(*----------------------------------------------------------------------------*)\r
+ if macro_rept_if_test then begin\r
+\r
+ ch:=' '; // CH bedzie zawieral znak dyrektywy 'N'MB, 'R'MB, 'L'MB\r
+\r
+ case mne.l of\r
+\r
+ __nmb: begin\r
+ inc(bank); // zwiekszamy licznik bankow MADS'a\r
+\r
+ ch:='N';\r
+ end;\r
+\r
+ __rmb: begin\r
+ bank:=0; // zerujemy licznik bankow MADS'a\r
+\r
+ ch:='R';\r
+ end;\r
+\r
+ __lmb: begin // ustawiamy licznik bankow MADS'a\r
+ omin_spacje(i,zm);\r
+// if zm[i] in ['<','>'] then else // znaki '<', '>' sa akceptowane\r
+ if zm[i]<>'#' then blad(zm,14) else __inc(i,zm); // pozostale znaki inne niz '#' to blad\r
+\r
+ txt:=get_dat_noSPC(i,zm,' ',#0,zm);\r
+ k:=1; j:=integer( ___wartosc_noSPC(txt,zm,k,',','B') ); // wartosc licznika bankow = 0..255\r
+\r
+ bank:=integer( j );\r
+\r
+ ch:='L';\r
+ end;\r
+\r
+ end;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* wymuszamy wykonanie makra @BANK_ADD (gdy OPT B+) dla LMB, NMB, RMB *)\r
+(*----------------------------------------------------------------------------*)\r
+ if ch<>' ' then begin\r
+\r
+ if dreloc.use or dreloc.sdx then blad(zm,71);\r
+ if first_org then blad(zm,10);\r
+\r
+ save_lst('i');\r
+\r
+ if opt and $80>0 then begin\r
+\r
+ omin_spacje(i,zm);\r
+ if zm[i]=',' then __inc(i,zm);\r
+\r
+ str:=get_dat_noSPC(i,zm,' ',#0,zm);\r
+ if str<>'' then str:=','+str;\r
+\r
+ wymus_zapis_lst(zm);\r
+\r
+ txt:='@BANK_ADD '''+ch+''''+str;\r
+ i:=1; mne:=oblicz_mnemonik(i,txt,zm);\r
+ zm:=txt;\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* wykonaj .PROC gdy PASS>0 *)\r
+(* wymus wykonanie makra @CALL jesli procedura miala parametry *)\r
+(* jesli procedura zostaje wywolana z poziomu innej procedury zapamietaj *)\r
+(* parametry procedury na stosie nie modyfikujac wskaznika stosu, *)\r
+(* a po powrocie przywroc je takze nie modyfikujac wskaznika stosu *)\r
+(*----------------------------------------------------------------------------*)\r
+ if mne.l=__proc_run then\r
+ if macro_rept_if_test then begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ indeks:=mne.i;\r
+\r
+ idx:=t_prc[indeks].par; // liczba parametrow\r
+\r
+ if idx>0 then begin\r
+ \r
+ wymus_zapis_lst(zm);\r
+\r
+ ety:='';\r
+ str:='';\r
+\r
+\r
+ // jesli nastepuje wywolanie procedury typu T_PRC[].TYP=__pDef, ktora posiada parametry (IDX>0)\r
+ // z ciala aktualnie przetwarzanej procedury PROC_NR-1\r
+ // to odlozymy na stos parametry procedury aktualnej, a po powrocie przywrocimy je\r
+\r
+ if proc and (t_prc[indeks].typ=__pDef) then begin\r
+ _doo:=t_prc[proc_nr-1].ile; // liczba bajtow przypadajaca na parametry\r
+\r
+ if _doo>0 then begin\r
+ //str:=copy(proc_name,1,length(proc_name)-1); // obcinamy ostatnia kropke w nazwie aktualnej procedury\r
+ str:=proc_name;\r
+ SetLength(str,length(proc_name)-1);\r
+\r
+ ety:=' @PUSH ''I'','+IntToStr(_doo)+' \ ';\r
+ str:=' \ @PULL ''J'','+IntToStr(_doo);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ rodzaj := t_prc[indeks].typ; // rodzaj procedury, sposobu przekazywania parametrow\r
+ \r
+ get_parameters(i,zm,par,false, '.',':');\r
+\r
+\r
+ // sprawdzamy liczbe przekazanych parametrow, jesli ich liczba sie nie zgadza to\r
+ // wystapi blad 'Improper number of actual parameters'\r
+ // w przypadku procedur typu __pReg, __pVar moze byc mniej parametrow, ale nie wiecej\r
+\r
+ _doo:=High(par);\r
+\r
+ for _odd:=_doo-1 downto 0 do begin\r
+\r
+ txt:=par[_odd];\r
+\r
+ if txt='' then\r
+ if rodzaj=__pDef then\r
+ blad(zm,40)\r
+ else\r
+ txt:=';'; // dla __pReg mozemy pomijac parametry\r
+\r
+ if (txt[1]='"') and (length(txt)>2) then txt:=copy(txt,2,length(txt)-2);\r
+\r
+ par[_odd]:=txt;\r
+ end;\r
+\r
+\r
+ // sprawdz typ parametrow i wymus wykonanie makra @CALL_INIT, @CALL, @CALL_END\r
+ // parametrem @CALL_INIT jest liczba bajtow zajmowanych przez parametry procedury\r
+\r
+ case rodzaj of\r
+ __pDef: begin\r
+ if _doo<>idx then blad(zm,40);\r
+ ety:=ety+' @CALL '+#39+'I'+#39+','+IntToStr(t_prc[indeks].ile);\r
+ end;\r
+\r
+ __pReg, __pVar:\r
+ begin\r
+ if _doo>idx then\r
+ blad(zm,40)\r
+ else\r
+ if (pass=pass_end) and (_doo<idx) then warning(40);\r
+\r
+ ety:=ety+' ';\r
+ end;\r
+ end;\r
+\r
+\r
+ idx:=t_prc[indeks].str; // indeks do nazw parametrow w T_PAR\r
+\r
+\r
+ if _doo>0 then\r
+ for k:=0 to _doo-1 do\r
+ if par[k][1]<>';' then begin\r
+\r
+ txt:=par[k];\r
+\r
+ case rodzaj of\r
+ __pDef: ety:=ety+' \ @CALL ';\r
+ end;\r
+\r
+ ch:=' ';\r
+ v:=byte(' ');\r
+\r
+ if txt='@' then begin\r
+// ety:=ety+#39+'@'+#39+',';\r
+ v:=byte('@');\r
+ war:=0;\r
+ ch:='Z';\r
+ end else\r
+ if txt[1]='#' then begin\r
+// ety:=ety+#39+'#'+#39+',';\r
+ v:=byte('#');\r
+ branch:=true;\r
+ tmp:=copy(txt,2,length(txt));\r
+ war:=oblicz_wartosc(tmp,zm);\r
+ ch:=value_code(war,zm,true);\r
+ end;\r
+\r
+ // typ parametru w deklaracji procedury (B,W,L,D)\r
+ // funkcja VALUE_CODE zwrocila typ parametru (Z,Q,T,D)\r
+ tmpZM:=copy(t_par[idx+k],2,length(t_par[idx+k]));\r
+\r
+ if ch<>' ' then\r
+ case t_par[idx+k][1] of\r
+ 'B': if ch<>'Z' then blad_und(zm,tmpZM,41);\r
+ 'W': if (ch in ['T','D']) or (txt='@') then blad_und(zm,tmpZM,41); \r
+ end;\r
+\r
+\r
+ if rodzaj<>__pVar then\r
+ if txt[1]='#' then txt[1]:=' ';\r
+\r
+\r
+ case rodzaj of\r
+ __pDef: ety:=ety+#39+chr(v)+#39+',';\r
+\r
+ __pReg: case chr(v) of\r
+ '#': case t_par[idx+k][1] of // przez wartosc\r
+ 'B': ety:=ety+'LD'+t_par[idx+k][2]+'#'+txt;\r
+ 'W': ety:=ety+'LD'+t_par[idx+k][2]+'>'+txt + '\ LD'+t_par[idx+k][3]+'<'+txt;\r
+ 'L': ety:=ety+'LD'+t_par[idx+k][2]+'^'+txt + '\ LD'+t_par[idx+k][3]+'>'+txt + '\ LD'+t_par[idx+k][4]+'<'+txt;\r
+ end;\r
+\r
+ ' ': case t_par[idx+k][1] of // przez adres\r
+ 'B': ety:=ety+'LD'+t_par[idx+k][2]+' '+txt;\r
+ 'W': ety:=ety+'LD'+t_par[idx+k][2]+' '+txt + '+1\ LD'+t_par[idx+k][3]+' '+txt;\r
+ 'L': begin\r
+ ety:=ety+'LD'+t_par[idx+k][2]+' '+txt + '+2\ LD'+t_par[idx+k][3]+' '+txt + '+1\ LD'+t_par[idx+k][4]+' '+txt;\r
+ if dreloc.use then warning(86); // typ 'L' nie jest relokowalny\r
+ end;\r
+ end;\r
+\r
+ '@': if t_par[idx+k][2]<>'A' then ety:=ety+'TA'+t_par[idx+k][2];\r
+ end;\r
+\r
+ __pVar: case chr(v) of\r
+ '#',' ': case t_par[idx+k][1] of // przez wartosc '#' lub wartosc spod adresu ' '\r
+ 'B': ety:=ety+'MVA '+txt+' '+tmpZM;\r
+ 'W': ety:=ety+'MWA '+txt+' '+tmpZM;\r
+ 'L': case chr(v) of\r
+ '#': begin\r
+ txt[1]:='('; txt:='#'+txt+')';\r
+ ety:=ety+' MWA '+txt+'&$FFFF '+tmpZM+'\';\r
+ ety:=ety+' MVA '+txt+'>>16 '+tmpZM+'+2\';\r
+ end;\r
+\r
+ ' ': begin\r
+ ety:=ety+' MWA '+txt+' '+tmpZM+'\';\r
+ ety:=ety+' MVA '+txt+'+2 '+tmpZM+'+2';\r
+ end;\r
+ end;\r
+ 'D': case chr(v) of\r
+ '#': begin\r
+ txt[1]:='('; txt:='#'+txt+')';\r
+ ety:=ety+' MWA '+txt+'&$FFFF '+tmpZM+'\';\r
+ ety:=ety+' MWA '+txt+'>>16 '+tmpZM+'+2\';\r
+ end;\r
+\r
+ ' ': begin\r
+ ety:=ety+' MWA '+txt+' '+tmpZM+'\';\r
+ ety:=ety+' MWA '+txt+'+2 '+tmpZM+'+2';\r
+ end;\r
+ end;\r
+ end;\r
+\r
+ '@': ety:=ety+'STA '+tmpZM;\r
+ end;\r
+ end;\r
+\r
+\r
+ if rodzaj=__pDef then begin\r
+ ety:=ety+#39+t_par[idx+k][1]+#39+',';\r
+ if txt[1] = '@' then ety:=ety+'0' else ety:=ety+'"'+txt+'"';\r
+ end else ety:=ety+'\ ';\r
+\r
+ end;\r
+\r
+ if rodzaj=__pDef then\r
+ txt:=ety+' \ @CALL '+#39+'X'+#39+','+t_prc[indeks].nam + ' \ @EXIT '+IntToStr(t_prc[indeks].ile) + str\r
+ else\r
+ txt:=ety+'JSR '+t_prc[indeks].nam;\r
+\r
+ k:=line_add;\r
+\r
+ line_add:=line-1;\r
+\r
+ _odd:=High(t_mac); // procedura z parametrami\r
+ t_mac[_odd]:=txt; // wymuszamy wykonanie wiêkszej liczby linii\r
+ _doo:=_odd+1;\r
+ analizuj_mem__(_odd,_doo, zm,a,old_str, 0,1, false);\r
+\r
+ line_add:=k;\r
+\r
+ bez_lst:=true;\r
+\r
+ end else begin\r
+ txt:='JSR '+ t_prc[indeks].nam; // procedura bez parametrow\r
+ i:=1; mne:=oblicz_mnemonik(i,txt,zm); // wymuszamy wykonanie jednej linii z JSR\r
+ end;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ERROR [ERT] 'text' | .ERROR [ERT] expression *)\r
+(*----------------------------------------------------------------------------*)\r
+ if (mne.l in [__error,__ert]) and macro_rept_if_test then\r
+ if pass=pass_end then begin\r
+\r
+ save_lst(' ');\r
+\r
+ txt:=get_string(i,zm,txt,true);\r
+\r
+ if txt<>'' then begin\r
+\r
+ if not(run_macro) then\r
+ writeln(zm)\r
+ else\r
+ writeln(old_str);\r
+\r
+ str:=end_string; end_string:='';\r
+\r
+ wypisz(i,zm); // !!! modyfikowana jest zmienna ZM !!!\r
+\r
+ txt:=txt+end_string;\r
+\r
+ end_string:=str;\r
+\r
+ blad(txt,34);\r
+\r
+ end else begin\r
+\r
+ branch := true; // tutaj nie ma mowy o relokowalnosci\r
+ war:=___wartosc_noSPC(zm,zm,i,',','F');\r
+\r
+ if war<>0 then begin\r
+\r
+ if not(run_macro) then\r
+ writeln(zm)\r
+ else\r
+ writeln(old_str);\r
+\r
+ str:=end_string; end_string:='';\r
+\r
+ wypisz(i,zm); // !!! modyfikowana jest zmienna ZM !!!\r
+\r
+ if end_string='' then\r
+ txt:=load_mes(30+1) // User error\r
+ else\r
+ txt:=end_string;\r
+\r
+ end_string:=str;\r
+\r
+ blad(txt,34);\r
+ end;\r
+\r
+ end;\r
+\r
+ end else\r
+ mne.l:=__nill;\r
+\r
+ \r
+(*----------------------------------------------------------------------------*)\r
+(* .EXIT *)\r
+(*----------------------------------------------------------------------------*)\r
+ if (mne.l=__exit) and macro_rept_if_test then\r
+ if not(run_macro) then blad(zm,58) else begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+ save_lst(' ');\r
+\r
+ wymus_zapis_lst(zm);\r
+\r
+ run_macro:=false;\r
+\r
+ wyjscie:=true;\r
+\r
+ ety:='';\r
+\r
+ exit;\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDP *)\r
+(*----------------------------------------------------------------------------*)\r
+ if (mne.l=__endp) and macro_rept_if_test then \r
+ if ety<>'' then blad(zm,38) else\r
+ if not(proc) then blad(zm,39) else begin\r
+\r
+ save_lst(' ');\r
+\r
+ oddaj_var;\r
+\r
+ oddaj_lokal(zm);\r
+\r
+ t_prc[proc_nr-1].len := cardinal(adres) - t_prc[proc_nr-1].adr;\r
+\r
+\r
+ proc_nr := t_prc[proc_nr-1].pnr; // !!! koniecznie ta kolejnosc inaczej zawsze PROC_NR=0 !!!\r
+\r
+ get_address_update;\r
+\r
+ proc := t_prc[proc_nr].prc;\r
+ org_ofset := t_prc[proc_nr].oof;\r
+ proc_name := t_prc[proc_nr].pnm;\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* label .PROC [label] *)\r
+(* jesli wystepuja parametry ograniczone nawiasami '()' to zapamietaj je *)\r
+(*----------------------------------------------------------------------------*)\r
+ if (mne.l=__proc) and macro_rept_if_test then\r
+ if adres<0 then blad(zm,10) else \r
+ begin\r
+\r
+ if ety='' then ety:=get_lab(i,zm, true);\r
+\r
+ save_lst('a');\r
+ txt:=zm; zapisz_lst(txt);\r
+ bez_lst:=true;\r
+ \r
+ label_type:='P';\r
+\r
+ if not(proc) then\r
+ ety:=lokal_name+ety\r
+ else\r
+ ety:=proc_name+ety;\r
+\r
+ zapisz_lokal;\r
+ lokal_name:='';\r
+\r
+\r
+ t_prc[proc_idx].prc := proc;\r
+ t_prc[proc_idx].pnr := proc_nr;\r
+ t_prc[proc_idx].oof := org_ofset;\r
+ t_prc[proc_idx].pnm := proc_name;\r
+\r
+ proc_nr:=proc_idx; // koniecznie przez ADD_PROC_NR\r
+\r
+\r
+ get_address(i,zm); // pobieramy nowy adres asemblacji dla .PROC\r
+\r
+\r
+ save_end(__endp);\r
+\r
+ \r
+ proc_lokal:=end_idx; // koniecznie po SAVE_END, nie wczesniej\r
+\r
+ save_lst('a'); proc_name:='';\r
+\r
+ if (pass=pass_end) and not(exclude_proc) and not(dreloc.use) then\r
+ if not(t_prc[proc_nr].use) then blad_und(zm,ety,69);\r
+\r
+\r
+ txt:=zm; // jesli TXT<>ZM to UPD_PROCEDURE zmodyfikowala ZM jakims makrem \r
+\r
+ if pass=0 then\r
+ get_procedure(ety,ety,zm ,i) // zapamietujemy parametry procedury\r
+ else\r
+ upd_procedure(ety,zm,adres); // uaktualniamy adresy procedury\r
+\r
+\r
+ add_proc_nr; // nowa wartosc PROC_NR, PROC_IDX\r
+\r
+\r
+ if (txt<>zm) and proc {and (pass>0)} then begin\r
+ save_lst(' ');\r
+ i:=1; mne:=oblicz_mnemonik(i,zm,zm);\r
+ end;\r
+\r
+ proc := true;\r
+\r
+ proc_name := ety+'.';\r
+\r
+ ety:=''\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* wykonaj .STRUCT (np. deklaracja pola struktury za pomoca innej struktury) *)\r
+(* mo¿liwe jest przypisanie pol zdefiniowanych przez strukture nowej zmiennej*)\r
+(*----------------------------------------------------------------------------*)\r
+ if mne.l in [__struct_run, __struct_run_noLabel, __enum_run] then\r
+ if ety='' then blad(zm,15) else\r
+ if macro_rept_if_test then begin\r
+\r
+ if (mne.l=__enum_run) and struct.use then\r
+ mne.l:=__byteValue+mne.i // typ wyliczeniowy na rozmiar w bajtach\r
+ else begin\r
+ create_struct_variable(zm, ety, mne, true, adres);\r
+ ety:='';\r
+ end;\r
+\r
+ end;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(*----------------------------------------------------------------------------*)\r
+(*----------------------------------------------------------------------------*)\r
+\r
+\r
+ case mne.l of\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* wykonaj .MACRO gdy PASS>0 *)\r
+(*----------------------------------------------------------------------------*)\r
+ __macro_run:\r
+// if macro then halt {inc(macro_nr)} else\r
+ if if_test then begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ if not(FOX_ripit) then save_lst('i');\r
+\r
+ txt:=zm;\r
+ zapisz_lst(txt);\r
+\r
+ indeks:=mne.i;\r
+\r
+ old_komentarz:=komentarz;\r
+\r
+ // zapamietujemy aktualne makro w 'OLD_MACRO_NR'\r
+\r
+ old_macro_nr:=macro_nr;\r
+ \r
+ txt:=t_mac[indeks+1];\r
+ str:='Macro: '+txt+' [Source: '+t_mac[indeks+0]+']';\r
+\r
+ // !!! nazwa obszaru LOCAL powtorzy sie 2x - KONIECZNIE !!!\r
+ if macro_nr='' then\r
+ macro_nr:=macro_nr+lokal_name+proc_name+txt+t_mac[indeks+3]+'.'\r
+ else\r
+ macro_nr:=macro_nr+proc_name+txt+t_mac[indeks+3]+'.';\r
+\r
+ omin_spacje(i,zm); SetLength(par,2);\r
+ // na pozycji par[0] zostanie wpisana liczba parametrow\r
+\r
+ k:=ord(t_mac[indeks+2][1]); // tryb pracy\r
+ ch:=t_mac[indeks+2][2]; // separator\r
+\r
+\r
+ while not(test_char(i,zm,#0,#0)) do begin\r
+\r
+ txt:=get_dat(i,zm,ch,true); \r
+\r
+ // jesli to licznik petli FOX_RIPIT '#' (lub .R) to wyliczymy wartosc\r
+ if (txt='#') or (txt='.R') then begin\r
+ war:=oblicz_wartosc(txt,zm);\r
+ txt:=IntToStr(war);\r
+ end;\r
+\r
+ // jesli przekazywany parametr jest miedzy apostrofami " " to jest to ciag znakowy\r
+ if txt<>'' then\r
+ if (txt[1]='"') and (txt[length(txt)]='"') then txt:=copy(txt,2,length(txt)-2);\r
+\r
+ _odd:=High(par);\r
+\r
+ if k=byte('''') then begin\r
+ par[_odd]:=txt;\r
+ SetLength(par,_odd+2);\r
+ end else begin\r
+\r
+ if txt[1]='#' then begin\r
+ par[_odd]:='''#''';\r
+ txt:=copy(txt,2,length(txt));\r
+ end else\r
+ if txt[1] in ['<','>'] then begin\r
+ par[_odd]:='''#''';\r
+ war:=oblicz_wartosc(txt,zm);\r
+ txt:=IntToStr(war);\r
+ end else par[_odd]:=''' ''';\r
+\r
+ SetLength(par,_odd+3);\r
+ par[_odd+1]:=txt;\r
+ end;\r
+\r
+// omin_spacje(i,zm);\r
+ if zm[i] in [',',' ',#9] then __next(i,zm);\r
+\r
+ if ch<>' ' then\r
+ if zm[i]=ch then __inc(i,zm); // else Break;\r
+\r
+ end;\r
+\r
+ // zapisujemy liczbe parametrow dla :0\r
+ par[0]:=IntToStr(Int64(High(par))-1);\r
+\r
+\r
+ // zwiekszamy numer wywolania makra T_MAC[indeks+3], T_MAC[indeks+5]\r
+ // !!! koniecznie w tym miejscu !!!\r
+\r
+ _doo:=integer( StrToInt(t_mac[indeks+3]) );\r
+ t_mac[indeks+3]:=IntToStr(Int64(_doo)+1);\r
+\r
+ _doo:=integer( StrToInt(t_mac[indeks+5]) );\r
+ t_mac[indeks+5]:=IntToStr(Int64(_doo)+1);\r
+\r
+ // !!! zabezpieczenie przed rekurencja bez konca !!!\r
+ // zatrzymujemy wykonanie makra jesli liczba wywolan przekroczy 255\r
+\r
+ if _doo>255 then blad(zm,66);\r
+\r
+\r
+ _doo:=integer( StrToInt(t_mac[indeks+4]) ); // numer linii\r
+\r
+ txt:=t_mac[indeks]; // nazwa pliku z aktualnie wykonywanym makrem\r
+\r
+ inc(wyw_idx);\r
+ if wyw_idx>High(t_wyw) then SetLength(t_wyw,wyw_idx+1);\r
+\r
+ t_wyw[wyw_idx].zm := zm; // jesli wystapi blad to te dane pomoga go zlokalizowac\r
+ t_wyw[wyw_idx].pl := txt;\r
+ t_wyw[wyw_idx].nr := _doo;\r
+\r
+\r
+ // zapamietujemy aktualny indeks do T_MAC w _ODD\r
+ // odczytujemy makro z T_MAC[indeks], podstawiamy parametry i zapisujemy do T_MAC\r
+ // potem zwolnimy miejsce na podstawie wczesniej zapamietanego indeksu w _ODD\r
+\r
+ _odd:=High(t_mac);\r
+\r
+ while true do begin\r
+ txt:=t_mac[indeks+6];\r
+\r
+ j:=1;\r
+\r
+ ety:=get_datUp(j,txt,#0,false); // wczytujemy nieznany ciag duzych liter\r
+\r
+ if not(fCRC16(ety)=__endm) then begin // aby odnalezc wpis .ENDM, .MEND\r
+\r
+ j:=1;\r
+ while j<=length(txt) do\r
+ if test_param(j,txt) then begin\r
+\r
+ k:=j;\r
+ if txt[j]=':' then inc(j) else inc(j,2);\r
+\r
+ ety:='';\r
+ while _dec(txt[j]) do begin ety:=ety+txt[j]; inc(j) end;\r
+\r
+ war:=StrToInt(ety);\r
+\r
+ delete(txt,k,j-k); dec(j,j-k);\r
+ if war>Int64(High(par))-1 then begin\r
+ insert('$FFFFFFFF',txt,k); inc(j,9); // musi koniecznie wpisac ciag $FFFFFFFF\r
+ end else begin\r
+ insert(par[war],txt,k);\r
+ inc(j,length(par[war]));\r
+ end;\r
+\r
+ end else inc(j);\r
+\r
+ save_mac(txt);\r
+ end else Break;\r
+\r
+ inc(indeks);\r
+ end;\r
+\r
+\r
+ if not(FOX_ripit) and not(rept_run) then put_lst(str);\r
+\r
+ // zapamietaj w zmiennych lokalnych\r
+\r
+ indeks := line_add;\r
+ line_add := 0;\r
+\r
+ old_rept := ___rept_ile;\r
+\r
+ par := reptPar;\r
+\r
+ old_case := rept_run;\r
+ rept_run := false;\r
+\r
+ old_run_macro := run_macro;\r
+ old_ifelse := ifelse;\r
+ old_loopused := loop_used;\r
+\r
+\r
+ komentarz := old_komentarz;\r
+\r
+ run_macro := true;\r
+\r
+ loop_used := false;\r
+\r
+ _doo:=High(t_mac);\r
+\r
+// for idx:=_odd to _doo-1 do writeln(t_mac[idx],' | '); halt;\r
+\r
+ analizuj_mem__(_odd,_doo, zm,a,old_str, idx,idx+1, false);\r
+\r
+ if not(FOX_ripit) then bez_lst:=true;\r
+\r
+ \r
+ if run_macro and (old_ifelse<>ifelse) then blad(zm,1);\r
+\r
+\r
+ run_macro := old_run_macro;\r
+\r
+\r
+ t_mac[mne.i+5]:='0';\r
+\r
+\r
+ loop_used := old_loopused;\r
+\r
+ rept_run := old_case;\r
+\r
+ ifelse := old_ifelse;\r
+ macro_nr := old_macro_nr;\r
+\r
+ ___rept_ile := old_rept;\r
+\r
+ reptPar := par;\r
+\r
+ line_add := indeks;\r
+\r
+ if not(lst_off) and not(FOX_ripit) and not(rept_run) then put_lst(show_full_name(a,full_name,true));\r
+\r
+ dec(wyw_idx);\r
+\r
+ SetLength(t_mac,_odd+1);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* label .MACRO [label] *)\r
+(* wystapienie dyrektywy .MACRO oznacza conajmniej 3 przebiegi asemblacji *) \r
+(*----------------------------------------------------------------------------*)\r
+ __macro:\r
+ begin\r
+ if ety='' then ety:=get_lab(i,zm, true);\r
+\r
+ if (pass=0) and if_test then begin\r
+\r
+// Konop postulowal aby przywrocic makra z blokow PROC \r
+// if proc then t_prc[proc_nr-1].use:=true; // jesli makro w .PROC to takie .PROC zawsze w uzyciu\r
+\r
+ reserved_word(ety,zm{, false});\r
+ save_lab(ety,High(t_mac),__id_macro,zm);\r
+\r
+ str:=show_full_name(a,full_name,false); save_mac(str); // zapisanie nazwy pliku z makrem\r
+ str:={lokal_name+}ety; save_mac(str); // zapisanie nazwy makra\r
+\r
+ ety:=''''; ch:=',';\r
+\r
+ omin_spacje(i,zm);\r
+ if zm[i] in ['''','"'] then begin\r
+ // wczytujemy i sprawdzamy poprawnosc\r
+ ety:=zm[i];\r
+ str:=get_string(i,zm,zm,true);\r
+\r
+ if str<>'' then ch:=str[1];\r
+\r
+// if length(txt)>1 then blad(zm,3) else\r
+// if txt='' then txt:=',';\r
+ end;\r
+\r
+ omin_spacje(i,zm);\r
+ if not(test_char(i,zm,#0,#0)) then blad(zm,4);\r
+\r
+ str:=ety+ch; save_mac(str); // separator i tryb dzialania\r
+ str:='0'; save_mac(str); // numer wywolania makra\r
+ str:=IntToStr(line); save_mac(str); // numer linii z makrem\r
+\r
+ str:='0'; save_mac(str); // licznik wywolan dla testu 'infinite loop'\r
+\r
+ if pass_end<3 then pass_end:=3; // jesli sa makra to musza byc conajmniej 3 przebiegi\r
+ end;\r
+\r
+ macro := true;\r
+\r
+ save_lst(' ');\r
+\r
+// save_end(__endm);\r
+\r
+ ety:=''\r
+ end;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .IF [IFT] expression *)\r
+(*----------------------------------------------------------------------------*)\r
+ __if, __ifndef, __ifdef:\r
+ begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+ \r
+\r
+ txt:=zm; // TXT = ZM, w celu pozniejszej modyfikacji TXT\r
+\r
+ if mne.l in [__ifndef, __ifdef] then begin\r
+\r
+ insert('.DEF',txt,i);\r
+\r
+ if mne.l=__ifndef then insert('.NOT ',txt,i);\r
+\r
+ end;\r
+\r
+\r
+ if_stos[ifelse].old_iftest := if_test;\r
+\r
+\r
+ inc(ifelse);\r
+ if ifelse>High(if_stos) then SetLength(if_stos,ifelse+1);\r
+\r
+\r
+ if_stos[ifelse]._okelse:=$7FFFFFFF; // zablokowany .ELSE\r
+\r
+ if if_test then begin\r
+ save_lst(' ');\r
+\r
+ if_stos[ifelse]._else := false;\r
+\r
+ if_stos[ifelse]._okelse := ifelse;\r
+\r
+ branch := true; // tutaj nie ma mowy o relokowalnosci\r
+ war:=___wartosc_noSPC(txt,zm,i,#0,'F');\r
+\r
+ if_test := (war<>0);\r
+ end;\r
+\r
+ if_stos[ifelse]._if_test := if_test;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDIF [EIF] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __endif:\r
+ if ety<>'' then blad(zm,38) else\r
+ if ifelse>0 then begin\r
+\r
+ dec(ifelse);\r
+\r
+// if_test := if_stos[ifelse]._if_test;\r
+// else_used := if_stos[ifelse]._else;\r
+\r
+ if_test := if_stos[ifelse].old_iftest;\r
+\r
+ end else\r
+ blad(zm,37);\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDM *)\r
+(*----------------------------------------------------------------------------*)\r
+ __endm: dec_end(zm, __endm);\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ELSE [ELS] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __else:\r
+ if ety<>'' then blad(zm,38) else\r
+ if if_stos[ifelse]._okelse=ifelse then begin\r
+\r
+ if if_stos[ifelse]._else then blad(zm,1);\r
+ if ifelse=0 then blad(zm,37);\r
+\r
+ if_stos[ifelse]._else:=true;\r
+\r
+ if_test := not(if_stos[ifelse]._if_test);\r
+ end;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .PRINT 'string' [,string2...] [,expression1,expression2...] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __print:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if pass=pass_end then begin\r
+\r
+ wypisz(i,zm);\r
+\r
+ end;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ELSEIF [ELI] expression *)\r
+(*----------------------------------------------------------------------------*)\r
+ __elseif:\r
+ if ety<>'' then blad(zm,38) else\r
+ if if_stos[ifelse]._okelse=ifelse then begin // !!! konieczny warunek\r
+\r
+ if if_stos[ifelse]._else then blad(zm,1);\r
+ if ifelse=0 then blad(zm,37);\r
+\r
+ if_test := not(if_stos[ifelse]._if_test);\r
+\r
+ if if_test then begin\r
+\r
+ save_lst(' ');\r
+\r
+ branch:=true; // tutaj nie ma mowy o relokowalnosci\r
+ war:=___wartosc_noSPC(zm,zm,i,#0,'F');\r
+\r
+ if_test := (war<>0);\r
+\r
+ if_stos[ifelse]._if_test := if_test; // !!! koniecznie zapisz IF_TEST\r
+ end;\r
+\r
+ end;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* label .LOCAL [label] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __local:\r
+ if macro_rept_if_test then begin\r
+\r
+ if ety='' then begin\r
+ omin_spacje(i,zm);\r
+ ety:=get_lab(i,zm, false);\r
+ end;\r
+\r
+ // jesli brak nazwy obszaru .LOCAL to przyjmij domyslna nazwe\r
+ if ety='' then begin\r
+ ety:='L@C?L?'+IntToStr(lc_nr);\r
+ inc(lc_nr);\r
+ end;\r
+\r
+ if pass=0 then if ety[1]='?' then warning(8);\r
+\r
+\r
+ t_loc[lokal_nr].ofs := org_ofset;\r
+\r
+\r
+ get_address(i,zm); // nowy adres asemblacji dla .LOCAL\r
+\r
+\r
+ if not(test_char(i,zm,#0,#0)) then blad(zm,4);\r
+\r
+\r
+ new_local:=true;\r
+ save_lab(ety, adres, bank, zm);\r
+ new_local:=false;\r
+\r
+ save_lst('a');\r
+\r
+ t_loc[lokal_nr].adr := adres;\r
+\r
+\r
+ idx:=load_lab(ety, true); // !!! TRUE\r
+ t_loc[lokal_nr].idx := idx;\r
+\r
+\r
+ save_end(__endl);\r
+\r
+ zapisz_lokal;\r
+ lokal_name:=lokal_name+ety+'.';\r
+\r
+ ety:='';\r
+ end;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDL *)\r
+(*----------------------------------------------------------------------------*)\r
+ __endl:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if lokal_nr>0 then begin\r
+\r
+ save_lst(' ');\r
+\r
+ if not(proc) then oddaj_var;\r
+\r
+ oddaj_lokal(zm);\r
+\r
+ if t_loc[lokal_nr].idx>=0 then begin\r
+ t_lab[t_loc[lokal_nr].idx].lln:=adres-t_loc[lokal_nr].adr;\r
+ t_lab[t_loc[lokal_nr].idx].lid:=true;\r
+ end;\r
+\r
+ org_ofset := t_loc[lokal_nr].ofs;\r
+\r
+// dec(end_idx);\r
+\r
+ get_address_update;\r
+\r
+ end else\r
+ blad(zm,28);\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .REPT expression *)\r
+(*----------------------------------------------------------------------------*)\r
+ __rept:\r
+ if if_test then\r
+ if rept then blad(zm,43) else begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+ save_lst(' ');\r
+\r
+ save_end(__endr);\r
+\r
+ get_parameters(i,zm, reptPar, false, #0,#0);\r
+\r
+ if High(reptPar)=0 then blad(zm,23); // Unexpected end of line\r
+\r
+\r
+ rept_ile:=oblicz_wartosc(reptPar[0],zm); // REPT_ILE\r
+\r
+ if rept_ile<0 then blad(zm, 0); // !!! mozliwa wartosc powyzej $ffff !!!\r
+\r
+// testRange(zm, rept_ile, 0);\r
+\r
+ reptPar[0]:=IntToStr(Int64(High(reptPar))-1); // liczba parametrów przekazana do .REPT\r
+\r
+\r
+ rept_nr := High(t_mac); // zapamietujemy indeks do T_MAC\r
+ rept := true;\r
+\r
+ \r
+ ety:=IntToStr(___rept_ile); // zapisujemy aktualna wartosc ___REPT_ILE\r
+ save_mac(ety); // !!! koniecznie po zapamietaniu indeksu !!!\r
+\r
+ ety:=IntToStr(line); // zapisujemy numer wiersza z dyrektywa .REPT\r
+ save_mac(ety);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDR *)\r
+(*----------------------------------------------------------------------------*)\r
+ __endr:\r
+ begin\r
+\r
+ dirENDR(zm,a,old_str,rept_nr,rept_ile);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* label .STRUCT [label] *)\r
+(* wystapienie dyrektywy .STRUCT oznacza conajmniej trzy przebiegi asemblacji*)\r
+(*----------------------------------------------------------------------------*)\r
+ __struct:\r
+ if macro_rept_if_test then\r
+ if struct.use then blad(zm,56) else begin\r
+\r
+ if ety='' then ety:=get_lab(i,zm, true);\r
+\r
+ if pass=0 then reserved_word(ety,zm{, false});\r
+\r
+ omin_spacje(i,zm);\r
+ if not(test_char(i,zm,#0,#0)) then blad(zm,4);\r
+\r
+ label_type:='C';\r
+\r
+ struct.drelocUSE := dreloc.use;\r
+ struct.drelocSDX := dreloc.sdx;\r
+\r
+ dreloc.use := false;\r
+ dreloc.sdx := false;\r
+\r
+\r
+ upd_structure(ety, zm);\r
+\r
+\r
+ zapisz_lokal;\r
+ lokal_name:=lokal_name+ety+'.';\r
+\r
+ struct.use := true;\r
+\r
+ // zapamietujemy adres, aby oddac go po .ENDS\r
+ struct.adres := adres;\r
+\r
+ save_lst('a');\r
+\r
+ save_end(__ends);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDS *)\r
+(* zapisujemy w tablicy 'T_STR' dlugosc i liczbe pol struktury *)\r
+(*----------------------------------------------------------------------------*)\r
+ __ends:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if not(struct.use) then blad(zm,55) else begin\r
+\r
+ save_lst(' ');\r
+\r
+ oddaj_lokal(zm);\r
+\r
+ struct.use := false;\r
+\r
+ t_str[struct.idx].siz := adres - struct.adres; // zapisujemy dlugosc struktury\r
+\r
+ t_str[struct.idx].ofs := struct.cnt; // i liczbe pol struktury\r
+\r
+ adres := struct.adres; // zwracamy stary adres asemblacji\r
+\r
+ inc(struct.id); // zwiekszamy identyfikator struktury (liczba struktur)\r
+\r
+ struct.cnt := -1;\r
+\r
+// dec(end_idx);\r
+ dec_end(zm, __ends);\r
+\r
+ dreloc.use := struct.drelocUSE;\r
+ dreloc.sdx := struct.drelocSDX;\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENUM *)\r
+(*----------------------------------------------------------------------------*)\r
+ __enum:\r
+ if macro_rept_if_test then\r
+ if enum.use then blad(zm,56) else begin\r
+\r
+ if ety='' then ety:=get_lab(i,zm, true);\r
+\r
+ if pass=0 then reserved_word(ety,zm{, false});\r
+\r
+ omin_spacje(i,zm);\r
+ if not(test_char(i,zm,#0,#0)) then blad(zm,4);\r
+\r
+ label_type:='C';\r
+\r
+ enum.drelocUSE := dreloc.use;\r
+ enum.drelocSDX := dreloc.sdx;\r
+\r
+ dreloc.use:=false;\r
+ dreloc.sdx:=false;\r
+\r
+ save_lab(ety, 0, __id_enum, zm);\r
+ \r
+\r
+ zapisz_lokal;\r
+ lokal_name:=lokal_name+ety+'.';\r
+\r
+ enum.use := true;\r
+ enum.val := 0;\r
+ enum.max := 0;\r
+\r
+ save_lst('a');\r
+\r
+ save_end(__ende);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDE *)\r
+(*----------------------------------------------------------------------------*)\r
+ __ende:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if not(enum.use) then blad(zm,55) else begin\r
+\r
+ txt:=lokal_name;\r
+ SetLength(txt, length(txt)-1);\r
+ idx:=load_lab(txt,false);\r
+\r
+ t_lab[idx].adr:=ValueToType(enum.max);\r
+ \r
+ save_lst(' '); \r
+\r
+ oddaj_lokal(zm);\r
+\r
+ enum.use := false;\r
+\r
+// dec(end_idx);\r
+ dec_end(zm,__ende);\r
+\r
+ dreloc.use := enum.drelocUSE;\r
+ dreloc.sdx := enum.drelocSDX;\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* zapisujemy wartosc do tablicy .ARRAY *)\r
+(*----------------------------------------------------------------------------*)\r
+ __array_run:\r
+ if ety<>'' then blad(zm,38) else begin\r
+\r
+ get_data_array(i,zm, t_arr[array_idx-1].idx, t_arr[array_idx-1].siz);\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ARRAY *)\r
+(* tablica ze zdefiniowanymi wartosciami *)\r
+(*----------------------------------------------------------------------------*)\r
+ __array:\r
+ if aray then blad(zm,60) else\r
+ if macro_rept_if_test then begin\r
+\r
+ if ety='' then ety:=get_lab(i,zm, true);\r
+\r
+ if pass=0 then reserved_word(ety,zm{, true});\r
+\r
+ save_lab(ety, array_idx, __id_array, zm);\r
+ save_lst('a');\r
+\r
+ save_arr(adres, bank); // tutaj ARRAY_IDX zostaje zwiekszone o 1\r
+\r
+ omin_spacje(i,zm); // od tego momentu uzywamy ARRAY_IDX-1\r
+\r
+ if zm[i]<>'.' then begin\r
+ txt:=get_dat(i,zm,' ',true);\r
+ idx := integer( oblicz_wartosc(txt,zm) );\r
+\r
+ t_arr[array_idx-1].def:=true; // okreslony rozmiar tablicy\r
+ end else begin\r
+ idx:=$FFFF;\r
+ t_arr[array_idx-1].def:=false; // brak rozmiaru tablicy\r
+ end;\r
+\r
+ array_used.max:=0;\r
+\r
+ t_arr[array_idx-1].idx:=idx;\r
+\r
+ r:=get_type(i,zm,zm,true);\r
+\r
+ t_arr[array_idx-1].siz := r;\r
+\r
+ if not(t_arr[array_idx-1].def) then idx:=idx div r;\r
+\r
+ t_arr[array_idx-1].len := (idx+1)*r;\r
+\r
+ //if (idx<0) or (t_arr[array_idx-1].len>$FFFF) then blad(zm,62);\r
+ testRange(zm, idx, 62);\r
+\r
+ if t_arr[array_idx-1].len-1>$FFFF then blad(zm,62);\r
+\r
+ array_used.typ := tType[ t_arr[array_idx-1].siz ];\r
+\r
+ war:=0; // dopuszczalna maksymalna wartosc typu D-WORD\r
+\r
+ omin_spacje(i,zm);\r
+ if zm[i]='=' then begin\r
+ __inc(i,zm);\r
+ war:=oblicz_wartosc_noSPC(zm,zm,i,#0,tType[r]);\r
+ end;\r
+\r
+ omin_spacje(i,zm);\r
+ if not(test_char(i,zm,#0,#0)) then blad(zm,4);\r
+\r
+ \r
+ for j:=0 to idx do t_tmp[j]:=cardinal(war); // FILLCHAR wypelnia tylko bajtami\r
+\r
+ aray := true;\r
+\r
+ save_end(__enda);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDA *)\r
+(*----------------------------------------------------------------------------*)\r
+ __enda:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if not(aray) then blad(zm,59) else begin\r
+\r
+ aray := false;\r
+\r
+ v := t_arr[array_idx-1].siz;\r
+\r
+\r
+ if t_arr[array_idx-1].def then // okreslony rozmiar tablicy\r
+\r
+ _doo := t_arr[array_idx-1].idx+1 \r
+\r
+ else begin\r
+ _doo := array_used.max ; // rozmiar tablicy na podstawie ilosci danych\r
+\r
+ t_arr[array_idx-1].idx := _doo-1;\r
+ t_arr[array_idx-1].len := _doo*v;\r
+\r
+ if t_arr[array_idx-1].len-1>$FFFF then blad(zm,62);\r
+ end;\r
+\r
+\r
+ for idx:=0 to _doo-1 do save_dta(t_tmp[idx],zm, tType[v],0);\r
+\r
+ t:=''; save_lst(' ');\r
+\r
+// dec(end_idx);\r
+ dec_end(zm,__enda);\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* label EXT type *)\r
+(*----------------------------------------------------------------------------*)\r
+ __ext:\r
+ if ety='' then blad(zm,15) else\r
+ if macro_rept_if_test then\r
+ if loop_used then blad(zm,36) else begin\r
+\r
+ v := get_typeExt(i,zm);\r
+\r
+ save_extLabel(i,ety,zm,v);\r
+\r
+ nul.i:=0;\r
+ save_lst('l');\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .EXTRN label .PROC (par1, par2, ...) [.var]|[.reg] *)\r
+(* .EXTRN label1, label2, label3 ... type *)\r
+(* rozbudowany odpowiednik pseudo rozkazu EXT *)\r
+(*----------------------------------------------------------------------------*)\r
+ __extrn:\r
+ if macro_rept_if_test then begin\r
+// if loop_used then blad(zm,36) else begin\r
+\r
+ nul.i:=0;\r
+ save_lst('l');\r
+ v:=0;\r
+\r
+ if ety='' then begin // jesli .EXTRN nie poprzedza etykieta\r
+\r
+ while true do begin\r
+\r
+ get_parameters(i,zm,par,false, '.',':');\r
+ v:=get_typeExt(i,zm);\r
+\r
+ _doo:=High(par);\r
+ if _doo=0 then blad(zm,15);\r
+\r
+ for _odd:=_doo-1 downto 0 do begin\r
+ txt:=par[_odd];\r
+\r
+ if txt<>'' then\r
+ save_extLabel(i,txt,zm,v)\r
+ else\r
+ blad(zm,15);\r
+ \r
+ end;\r
+\r
+ omin_spacje(i,zm);\r
+ if (v=__proc) or (test_char(i,zm,#0,#0)) then Break;\r
+ end;\r
+\r
+ end else begin // jesli .EXTRN poprzedza etykieta\r
+ v := get_typeExt(i,zm);\r
+ save_extLabel(i,ety,zm,v);\r
+ end;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .VAR label1, label2, label3 ... TYPE [=address] *)\r
+(* .VAR TYPE label1, label2 .... *)\r
+(* .ZPVAR label1, label2, label3 ... TYPE [=address] *)\r
+(* .ZPVAR TYPE label1, label2 .... *)\r
+(*----------------------------------------------------------------------------*)\r
+ __var, __zpvar:\r
+ if ety<>'' then blad(zm,38) else\r
+ if (pass>0) and macro_rept_if_test then\r
+// if (adres<0) and (mne.l=__var) then blad(zm,10) else \r
+ if rept_run then blad(zm,36) else begin\r
+\r
+// nul.i:=0;\r
+ save_lst('a');\r
+\r
+ if pass_end<3 then pass_end:=3; // !!! potrzebne conajmniej 3 przebiegi !!!\r
+\r
+ while true do begin\r
+ get_vars(i,zm,par, mne.l);\r
+\r
+ omin_spacje(i,zm);\r
+ if test_char(i,zm,#0,'=') then Break;\r
+ end;\r
+\r
+ txt:=zm;\r
+\r
+ // sprawdz czy zostal okreslony adres umiejscowienia zmiennych '= ADDRESS'\r
+ idx:=-1;\r
+\r
+ if High(par)>var_idx then begin // deklaracja typu przez .STRUCT lub .ENUM\r
+ i:=1;\r
+ txt:=par[var_idx];\r
+ end;\r
+\r
+\r
+ if txt<>'' then\r
+ if txt[i]='=' then begin // nowy adres alokacji\r
+ inc(i);\r
+ idx:=integer( oblicz_wartosc_noSPC(txt,zm,i,#0,'A') );\r
+\r
+ testRange(zm,idx,87);\r
+ end;\r
+\r
+\r
+ if mne.l=__zpvar then begin\r
+\r
+ if idx>=0 then zpvar:=idx;\r
+\r
+ for _doo:=0 to var_idx-1 do\r
+ if t_var[_doo].id=var_id then begin\r
+\r
+ t_var[_doo].adr:=zpvar;\r
+ t_var[_doo].zpv:=true;\r
+\r
+ if zpvar+t_var[_doo].cnt*t_var[_doo].siz>256 then\r
+ blad(zm,0)\r
+ else\r
+ for k:=0 to t_var[_doo].cnt*t_var[_doo].siz-1 do begin\r
+\r
+ if (pass=pass_end) and t_zpv[zpvar] then warning(109);\r
+\r
+ t_zpv[zpvar]:=true;\r
+\r
+ inc(zpvar);\r
+ end; \r
+\r
+ end;\r
+\r
+ end else begin\r
+\r
+ if idx>=0 then\r
+ for _doo:=0 to var_idx-1 do\r
+ if t_var[_doo].id=var_id then begin\r
+ t_var[_doo].adr:=idx;\r
+ t_var[_doo].zpv:=false;\r
+ inc(idx, t_var[_doo].cnt*t_var[_doo].siz);\r
+ end;\r
+\r
+ end;\r
+\r
+ inc(var_id);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .BY [+byte] bytes and/or ASCII *)\r
+(* .WO words *)\r
+(* .HE hex bytes *)\r
+(*----------------------------------------------------------------------------*)\r
+ __by, __wo, __he, __sb:\r
+ if (mne.l<>__he) and (dreloc.use or dreloc.sdx) then blad(zm,71) else\r
+ if macro_rept_if_test then begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ case mne.l of\r
+ __by: get_maeData(zm,i,'B');\r
+ __wo: get_maeData(zm,i,'W');\r
+ __he: get_maeData(zm,i,'H');\r
+ __sb: get_maeData(zm,i,'S');\r
+ end;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .WHILE .TYPE ARG1 OPERAND ARG2 [.AND|.OR .TYPE ARG3 OPERAND ARG4] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __while:\r
+ if macro_rept_if_test then begin\r
+// if loop_used then blad(zm,36) else begin\r
+\r
+// if ety='' then ety:=get_lab(i,zm, true);\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+ save_lst('a');\r
+\r
+ if while_name='' then while_name:=lokal_name;\r
+ while_name:=while_name+IntToStr(while_nr)+'.'; // sciezka dostepu do WHILE\r
+\r
+ long_test:='';\r
+ wyrazenie_warunkowe(i, long_test, zm,txt,tmp,v,r, '\EX LDA#0\:?J/2-1 ORA#0\.ENDL');\r
+\r
+// if long_test<>'' then begin\r
+// create_long_test(v, r, long_test, txt, tmp);\r
+// long_test:=long_test+'\EX LDA#0\:?J/2-1 ORA#0\.ENDL';\r
+// end;\r
+\r
+\r
+ save_end(__endw);\r
+\r
+\r
+ ety:=__while_label+while_name; // poczatek .WHILE\r
+\r
+ save_fake_label(ety,zm,adres);\r
+\r
+\r
+ ety:=__endw_label+while_name; // koniec WHILE\r
+\r
+\r
+ if long_test='' then\r
+ mne := asm_test(txt,tmp,zm, ety, r,v)\r
+ else begin\r
+\r
+ idx:=High(t_mac); _odd:=idx+1;\r
+\r
+ t_mac[idx]:=long_test+'\ JEQ '+ety;\r
+\r
+ line_add:=line-1;\r
+\r
+ save_lst('i');\r
+ txt:=zm;\r
+ zapisz_lst(txt);\r
+\r
+ opt_tmp:=opt;\r
+ opt:=opt and (not(4));\r
+\r
+ code6502:=true;\r
+\r
+\r
+ analizuj_mem__(idx,_odd, zm,a,old_str, 0,1, false);\r
+\r
+\r
+ code6502:=false;\r
+\r
+ line_add:=0;\r
+\r
+ opt:=opt_tmp;\r
+\r
+ bez_lst:=true;\r
+ end;\r
+ \r
+\r
+ inc(whi_idx);\r
+\r
+ inc(while_nr);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDW *)\r
+(*----------------------------------------------------------------------------*)\r
+ __endw:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if whi_idx>0 then begin\r
+// if loop_used then blad(zm,36) else begin\r
+\r
+ save_lst('a');\r
+\r
+ dec(whi_idx);\r
+\r
+\r
+ ety:=__while_label+while_name;\r
+\r
+ war:=load_lab(ety,false); // odczytujemy wartosc etykiety poczatku petli WHILE ##B\r
+ if war>=0 then begin\r
+ tst:=t_lab[war].adr;\r
+\r
+ save_relAddress(integer(war), reloc_value);\r
+\r
+ if pass=pass_end then\r
+ if t_lab[war].bnk<>bank then warning(70); // petla .WHILE musi znajdowac sie w obszarze tego samego banku\r
+ end else\r
+ tst:=0;\r
+\r
+\r
+ txt:='JMP '+IntToStr(tst);\r
+ k:=1; mne:=oblicz_mnemonik(k,txt,zm);\r
+\r
+\r
+ ety:=__endw_label+while_name;\r
+\r
+ idx := adres + 3; // E## = aktualny adres + 3 bajty (JMP)\r
+\r
+ save_fake_label(ety,zm,idx);\r
+\r
+\r
+ obetnij_kropke(while_name);\r
+\r
+// dec(end_idx);\r
+ dec_end(zm,__endw);\r
+\r
+ ety:='';\r
+ end else blad(zm,88);\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .TEST .TYPE ARG1 OPERAND ARG2 [.AND|.OR .TYPE ARG3 OPERAND ARG4] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __test:\r
+ if macro_rept_if_test then begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+ save_lst('a');\r
+\r
+ if test_name='' then test_name:=lokal_name;\r
+ test_name:=test_name+IntToStr(test_nr)+'.'; // sciezka dostepu do TEST\r
+\r
+ long_test:='';\r
+ wyrazenie_warunkowe(i, long_test,zm,txt,tmp,v,r, '\EX LDA#0\:?J/2-1 ORA#0\.ENDL');\r
+\r
+// if long_test<>'' then begin\r
+// create_long_test(v, r, long_test, txt, tmp);\r
+// long_test:=long_test+'\EX LDA#0\:?J/2-1 ORA#0\.ENDL';\r
+// end;\r
+\r
+\r
+ save_end(__endt);\r
+\r
+\r
+ ety:=__test_label+test_name; // poczatek #IF __TEST_LABEL\r
+\r
+ save_fake_label(ety,zm,adres);\r
+\r
+\r
+ ety:=__telse_label+test_name; // sprawdzamy czy wystapilo #ELSE\r
+ if load_lab(ety,false)<0 then\r
+ ety:=__endt_label+test_name; // jesli nie bylo #ELSE to skok do #END\r
+\r
+\r
+ if long_test='' then\r
+ mne := asm_test(txt,tmp,zm, ety, r,v)\r
+ else begin\r
+\r
+ idx:=High(t_mac); _odd:=idx+1;\r
+\r
+ t_mac[idx]:=long_test+'\ JEQ '+ety;\r
+\r
+ line_add:=line-1;\r
+\r
+ save_lst('i');\r
+ txt:=zm;\r
+ zapisz_lst(txt);\r
+\r
+ opt_tmp:=opt;\r
+ opt:=opt and (not(4));\r
+\r
+\r
+ code6502:=true;\r
+\r
+ analizuj_mem__(idx,_odd, zm,a,old_str, 0,1, false);\r
+\r
+ code6502:=false;\r
+\r
+\r
+ line_add:=0;\r
+\r
+ opt:=opt_tmp;\r
+\r
+ bez_lst:=true;\r
+ end;\r
+\r
+\r
+ t_els[test_idx]:=false;\r
+\r
+ inc(test_idx);\r
+\r
+ if test_idx>High(t_els) then SetLength(t_els, test_idx+1);\r
+\r
+\r
+ inc(test_nr);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .TELSE *)\r
+(*----------------------------------------------------------------------------*)\r
+ __telse:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if test_idx>0 then begin\r
+\r
+ if t_els[test_idx-1] then blad(zm,95);\r
+\r
+ txt:='JMP '+__endt_label+test_name;\r
+ mne:=asm_mnemo(txt, zm);\r
+\r
+ t_els[test_idx-1]:=true;\r
+\r
+ ety:=__telse_label+test_name; // adres #ELSE __TELSE_LABEL\r
+ save_fake_label(ety,zm,adres);\r
+\r
+\r
+ dec(adres, mne.l);\r
+\r
+\r
+ ety:='';\r
+ end else blad(zm,95);\r
+\r
+ \r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDT *)\r
+(*----------------------------------------------------------------------------*)\r
+ __endt:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if test_idx>0 then begin\r
+// if loop_used then blad(zm,36) else begin\r
+\r
+ save_lst('a');\r
+\r
+ dec(test_idx);\r
+\r
+\r
+ ety:=__test_label+test_name;\r
+\r
+ war:=load_lab(ety,false); // adres #IF __TEST_LABEL\r
+ if war>=0 then\r
+ if pass=pass_end then\r
+ if t_lab[war].bnk<>bank then warning(70); // TEST musi znajdowac sie w obszarze tego samego banku\r
+\r
+\r
+ ety:=__endt_label+test_name; // adres #END dla bloku #IF __ENDT_LABEL\r
+ save_fake_label(ety,zm,adres);\r
+\r
+\r
+ obetnij_kropke(test_name);\r
+\r
+// dec(end_idx);\r
+ dec_end(zm,__endt);\r
+\r
+ ety:='';\r
+ end else blad(zm,95);\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .DEF label *)\r
+(*----------------------------------------------------------------------------*)\r
+ __def:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then begin\r
+\r
+ idx:=adres;\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ label_type:='V';\r
+\r
+\r
+ if zm[i]=':' then begin\r
+ old_case:=true; // zostal uzyty znak ':' w nazwie etykiety\r
+ inc(i);\r
+ end else\r
+ old_case:=false; // znak ':' nie zostal uzyty w nazwie etykiety\r
+\r
+ ety:=get_lab(i,zm,true);\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ txt:=zm; // podstawiamy ZM pod TXT\r
+\r
+ if txt[i] in ['+','-'] then\r
+ if txt[i+1] in ['+','-','='] then operator_zlozony(i,txt,ety, old_case);\r
+\r
+\r
+ if txt[i]='=' then begin\r
+ __inc(i,txt);\r
+\r
+ variable:=false;\r
+\r
+ idx:=oblicz_wartosc_noSPC(txt,zm,i,#0,'W');\r
+\r
+ if not(variable) then label_type:='C';\r
+ \r
+ end else\r
+ if not(test_char(i,txt,#0,#0)) then blad(zm,58);\r
+\r
+\r
+ nul.i:=idx;\r
+ save_lst('l');\r
+ data_out := true; // wymus pokazanie w pliku LST podczas wykonywania makra\r
+ // !!! jesli wystapila dyrektywa .IFNDEF to nie pokaze !!!\r
+\r
+ old_run_macro := run_macro;\r
+ run_macro := false;\r
+\r
+// old_loopused := dreloc.use;\r
+// dreloc.use := false;\r
+\r
+ mne_used := true;\r
+\r
+\r
+ if old_case then\r
+ s_lab(ety,idx,bank,zm,ety[1]) // etykieta globalna\r
+ else\r
+ save_lab(ety,idx,bank,zm); // etykieta w aktualnym zasiegu\r
+\r
+\r
+ run_macro := old_run_macro;\r
+\r
+// dreloc.use := old_loopused;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .USING label [,label2...] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __using:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then begin\r
+\r
+ save_lst('i');\r
+\r
+ get_parameters(i,zm,par,false, '.',':');\r
+\r
+ if pass>0 then\r
+ for k:=High(par)-1 downto 0 do begin\r
+\r
+ txt:=par[k];\r
+\r
+ _odd:=load_lab(txt, false);\r
+ if _odd<0 then blad_und(zm,txt,5);\r
+\r
+ t_usi[usi_idx].lok:=end_idx;\r
+ t_usi[usi_idx].lab:=txt;\r
+\r
+ if proc then\r
+ t_usi[usi_idx].nam:=proc_name\r
+ else\r
+ t_usi[usi_idx].nam:=lokal_name;\r
+\r
+ inc(usi_idx);\r
+\r
+ SetLength(t_usi, usi_idx+1);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .FL *)\r
+(*----------------------------------------------------------------------------*)\r
+ __fl:\r
+ if macro_rept_if_test then begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ save_lst('a');\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ while not(test_char(i,zm,#0,#0)) do begin\r
+ txt:=get_dat(i,zm,',',true);\r
+ save_fl(txt, zm);\r
+ if zm[i] in [',',' ',#9] then __next(i,zm) else Break;\r
+ end;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* label EQU [=] expression *)\r
+(*----------------------------------------------------------------------------*)\r
+ __equ,__smb,__addEqu:\r
+ if ety='' then blad(zm,15) else\r
+ if macro_rept_if_test then\r
+ if loop_used then blad(zm,36) else begin\r
+\r
+ if dreloc.use then\r
+ if mne.l in [__equ,__smb] then blad(zm,71);\r
+\r
+ label_type:='C';\r
+\r
+ old_case := dreloc.use; // deklaracje etykiet w bloku .RELOC nie moga byc relokowalne\r
+ dreloc.use := false;\r
+\r
+\r
+ if mne.l=__smb then begin // SMB\r
+\r
+ txt:=get_smb(i,zm);\r
+\r
+ // wymuszamy relokowalnosc dla tej etykiety\r
+ // jesli BLOK>1 to zaznaczy jako etykiete relokowalna\r
+ k:=blok; blok:=$FFFF;\r
+ save_lab(ety,smb_idx,__id_smb,zm);\r
+ blok:=k;\r
+\r
+\r
+ // zapisujemy etykiete symbolu SMB w tablicy T_SMB\r
+ t_smb[smb_idx].smb:=txt; // SAVE_SMB\r
+ inc(smb_idx); //\r
+ if smb_idx>High(t_smb) then SetLength(t_smb,smb_idx+1); //\r
+\r
+\r
+ war:=__rel;\r
+\r
+ end else begin // EQU, addEQU\r
+\r
+ branch:=true; // dla EQU i addEQU nie ma relokowalnosci\r
+\r
+ // nie mozna przypisac wartosci etykiety EXTERNAL, SMB (BLOCKED = TRUE)\r
+ blocked := true;\r
+\r
+ // sprawdzamy czy deklaracja etykiety powiodla sie (UNDECLARED = FALSE)\r
+ // procedura OBLICZ_WARTOSC zmodyfikuje UNDECLARED na TRUE jesli wystapi\r
+ // proba odwolania do niezdefiniowanej etykiety\r
+\r
+ undeclared:=false;\r
+\r
+ \r
+ variable:=false;\r
+\r
+ war:=___wartosc_noSPC(zm,zm,i,#0,'F');\r
+\r
+ if variable then label_type:='V';\r
+\r
+\r
+ blocked := false; // !!! koniecznie przywracamy BLOCKED = FALSE !!!\r
+\r
+ mne_used:=true; // konieczny test dla zmieniajacych sie wartosci etykiet\r
+\r
+\r
+ save_lab(ety,cardinal(war),bank,zm);\r
+\r
+ _odd:=load_lab(ety, true); // !!! TRUE\r
+\r
+ if _odd>=0 then t_lab[_odd].sts := undeclared;\r
+\r
+\r
+ undeclared:=false; // !!! koniecznie przywracamy UNDECLARED = FALSE !!!\r
+\r
+ data_out := true; // wymus pokazanie w pliku LST podczas wykonywania makra\r
+\r
+ mne_used := false;\r
+\r
+ end;\r
+\r
+\r
+ nul.i:=integer( war );\r
+ save_lst('l');\r
+\r
+\r
+ if mne.l=__addEqu then begin\r
+ zapisz_lst(tmpZM);\r
+ zm:='';\r
+ end;\r
+\r
+\r
+ dreloc.use := old_case;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* OPT holscmtb?f +- *)\r
+(*----------------------------------------------------------------------------*)\r
+(* bit *)\r
+(* 0 - Header default = yes 'h+' *)\r
+(* 1 - Object file default = yes 'o+ *)\r
+(* 2 - Listing default = no 'l-' *)\r
+(* 3 - Screen (listing on screen) default = no 's-' *)\r
+(* 4 - CPU 8bit/16bit default = 6502 'c-' *)\r
+(* 5 - visible macro default = no 'm-' *)\r
+(* 6 - track sep rep default = no 't-' *)\r
+(* 7 - banked mode default = no 'b-' *)\r
+(*----------------------------------------------------------------------------*)\r
+ __opt:\r
+ if macro_rept_if_test then begin\r
+\r
+ txt:=get_dat_noSPC(i,zm,',',#0,zm); // pomijamy spacje\r
+\r
+ j:=1;\r
+\r
+ while j<=length(txt) do begin\r
+\r
+ ch:=txt[j+1];\r
+\r
+ opt_tmp:=opt;\r
+\r
+ tst:=0;\r
+\r
+ case UpCase(txt[j]) of\r
+ 'F': raw.use:= (ch='+');\r
+ 'H': tst:=1;\r
+ 'O': tst:=2;\r
+ 'L': tst:=4;\r
+ 'S': tst:=8;\r
+ 'C': tst:=16;\r
+ 'M': tst:=32;\r
+ 'T': tst:=64;\r
+ 'B': tst:=128;\r
+ '?': mae_labels:= (ch='+'); \r
+ 'R': regAXY_opty:= (ch='+');\r
+ else\r
+ blad(zm,16);\r
+ end;\r
+\r
+ case ch of\r
+ '+': opt:=opt or tst;\r
+ '-': opt:=opt and (not(tst));\r
+ else\r
+ blad(zm,16);\r
+ end;\r
+\r
+ if (opt_tmp and 1)<>(opt and 1) then // OPT H-\r
+ if (opt and 1)=0 then save_hea; \r
+\r
+ inc(j,2);\r
+ end;\r
+\r
+ data_out:=true;\r
+\r
+ save_lst(' ');\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* ORG adres [,adres2] *)\r
+(* RUN adres *)\r
+(* INI adres *)\r
+(* BLK *)\r
+(*----------------------------------------------------------------------------*)\r
+ __org, __run, __ini, __blkSpa, __blkRel, __blkEmp:\r
+ if if_test then\r
+ if loop_used or rept then blad(zm,36) else\r
+ if dreloc.use then blad(zm,71) else\r
+ if first_org and (ety<>'') then blad(zm,10) else begin\r
+\r
+\r
+ if (org_ofset>0) and ((lokal_name<>'') or proc) then blad(zm,71);\r
+\r
+\r
+ if hea_ofs.adr>=0 then\r
+ raw.old := hea_ofs.adr+(adres-hea_ofs.old)\r
+ else\r
+ raw.old := adres;\r
+\r
+\r
+ label_type:='V';\r
+\r
+ data_out:=true;\r
+\r
+ save_lst('a');\r
+\r
+ branch:=true; // relokowalnosc tutaj niemozliwa\r
+\r
+ rel_ofs:=0; {org_ofs:=0;}\r
+ idx:=-$FFFF; hea_ofs.adr:=-1; _odd:=-1;\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ r := mne.l; // !!! koniecznie V := MNE.L !!! aby zadzialalo RUN, INI\r
+ // !!! RUN, INI modyfikuja MNE.L !!!\r
+\r
+ case r of\r
+\r
+ // BLK SPARTA a\r
+ __blkSpa:\r
+ begin\r
+ dreloc.sdx:=true;\r
+\r
+ blok:=0;\r
+\r
+ opt_tmp:=opt;\r
+ opt_h_minus;\r
+\r
+ // a($fffa),a(str_adr),a(end_adr)\r
+ save_dstW( $fffa );\r
+\r
+ idx:=integer( ___wartosc_noSPC(zm,zm,i,',','A') );\r
+\r
+ opt:=opt_tmp;\r
+ end;\r
+\r
+\r
+ //BLK R[eloc] M[ain]|E[xtended]\r
+ __blkRel:\r
+ begin\r
+ dreloc.sdx:=true;\r
+\r
+ ds_empty:=0;\r
+\r
+ opt_tmp:=opt;\r
+ opt_h_minus;\r
+\r
+ v := getMemType(i,zm);\r
+\r
+ add_blok(zm);\r
+\r
+ // a($fffe),b(blk_num),b(blk_id)\r
+ // a(blk_off),a(blk_len)\r
+ save_dstW( $fffe );\r
+ save_dst(byte(blok));\r
+ save_dst(memType);\r
+\r
+ if blok=1 then\r
+ idx:=__rel\r
+ else begin\r
+ rel_ofs:=adres-__rel;\r
+ _odd:=adres; idx:=adres;\r
+ end;\r
+\r
+ opt:=opt_tmp;\r
+ end;\r
+\r
+\r
+ //BLK E[mpty] a M[ain]|E[xtended]\r
+ __blkEmp:\r
+ begin\r
+ opt_tmp := opt;\r
+ opt_h_minus;\r
+\r
+ _odd:=integer( ___wartosc_noSPC(zm,zm,i,' ','A') ); // !!! koniecznie znak spacji ' ' !!!\r
+ // blk empty empend-tdbuf extended\r
+ v := getMemType(i,zm);\r
+\r
+ blk_empty(_odd, zm);\r
+\r
+ idx:=adres + _odd;\r
+\r
+ opt := opt_tmp;\r
+\r
+ if ds_empty>0 then blad(zm,57); // albo .DS albo BLK EMPTY, nie mozna obu naraz\r
+ end;\r
+\r
+\r
+ // ORG\r
+ __org: begin\r
+\r
+ if dreloc.sdx then blad(zm,71);\r
+\r
+ if not(NoAllocVar) and not(proc) and (lokal_nr=0) then oddaj_var;\r
+\r
+ NoAllocVar:=false;\r
+\r
+ if zm[i]='[' then begin\r
+ opt_tmp := opt;\r
+ opt_h_minus;\r
+\r
+ txt:=ciag_ograniczony(i,zm,true);\r
+ k:=1;\r
+ if pass>1 then oblicz_dane(k,txt,zm,1);\r
+\r
+ omin_spacje(i,zm);\r
+ if zm[i]=',' then begin\r
+ __inc(i,zm);\r
+ idx:=integer( ___wartosc_noSPC(zm,zm,i,#0,'A') );\r
+ end;\r
+\r
+ opt := opt_tmp;\r
+\r
+ end else\r
+ idx:=integer( ___wartosc_noSPC(zm,zm,i,',','A') );\r
+\r
+ org_ofset:=0;\r
+\r
+ omin_spacje(i,zm);\r
+ if zm[i]=',' then begin\r
+ __inc(i,zm);\r
+\r
+ {org_ofs:=idx;}\r
+ hea_ofs.adr := integer( ___wartosc_noSPC(zm,zm,i,#0,'A') );\r
+ if hea_ofs.adr<0 then blad(zm,10);\r
+\r
+ hea_ofs.old := idx;\r
+\r
+ { if adres<0 then\r
+ org_ofset := hea_ofs.adr\r
+ else }\r
+ org_ofset := idx - hea_ofs.adr;\r
+\r
+ end;\r
+\r
+\r
+ if not(first_org) then // koniecznie IF NOT(FIRST_ORG) inaczej nic nie zapisze\r
+ if (adres<>idx) and raw.use then begin\r
+\r
+ if raw.old<0 then\r
+ k:=0\r
+ else\r
+ if hea_ofs.adr>=0 then\r
+ k:=hea_ofs.adr-raw.old\r
+ else\r
+ k:=idx-raw.old;\r
+\r
+ if k<0 then blad(zm,108);\r
+\r
+ if not(hea) then inc(fill,k); // IF NOT(HEA) czeka az zacznie zapisywac cos do pliku\r
+\r
+ adres:=idx; \r
+\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ // RUN,INI\r
+ __run,__ini:\r
+ begin\r
+\r
+ if dreloc.sdx then blad(zm,71); // Illegal instruction at RELOC block\r
+ if opt and 1=0 then blad(zm,111); // Illegal when Atari file headers disabled\r
+\r
+ oddaj_var;\r
+\r
+ idx:=integer( ___wartosc_noSPC(zm,zm,i,#0,'A') );\r
+ mne.l:=2;\r
+\r
+ mne.h[0]:=byte(idx);\r
+ mne.h[1]:=byte(idx shr 8);\r
+\r
+ idx:=$2e0 + r - __run;\r
+ end;\r
+ end;\r
+\r
+\r
+ if (adres<>idx) or (_odd>=0) then begin\r
+\r
+ save_hea;\r
+\r
+ adres:=idx;\r
+\r
+ if r<>__blkEmp then org:=true; // R = MNE.L\r
+ end;\r
+\r
+\r
+ if (idx>=0) and (idx<=$FFFF) then\r
+ first_org:=false\r
+ else\r
+ blad(zm,0); // !!! koniecznie blad(zm,0) !!! w celu akceptacji\r
+ // ORG-ów <0 w poczatkowych przebiegach asemblacji\r
+\r
+ if raw.use and (r in [__run, __ini]) then first_org:=true;\r
+\r
+ ety:=''; \r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .PUT [index] = VALUE,... *)\r
+(*----------------------------------------------------------------------------*)\r
+ __put:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then begin\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ array_used.max:=0;\r
+ \r
+ put_used:=true;\r
+\r
+ blocked := true;\r
+ get_data_array(i,zm,$FFFF,1);\r
+ blocked := false;\r
+\r
+ put_used:=false;\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .SAV [index] ['file',length] | ['file',ofset,length] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __sav:\r
+// if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ save_lst('a');\r
+\r
+ idx_get:=0;\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if zm[i] in ['[','('] then begin\r
+ txt:=ciag_ograniczony(i,zm,true);\r
+ k:=1; idx_get:=integer( ___wartosc_noSPC(txt,zm,k,#0,'A') );\r
+ end;\r
+\r
+ txt:=get_string(i,zm,zm,false);\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if txt<>'' then\r
+ if zm[i]=',' then\r
+ __inc(i,zm)\r
+ else\r
+ blad(zm,23);\r
+\r
+ _doo:=integer( ___wartosc_noSPC(zm,zm,i,',','A') );\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if zm[i]=',' then begin\r
+ __inc(i,zm);\r
+ inc(idx_get, _doo);\r
+ _doo:=integer( ___wartosc_noSPC(zm,zm,i,',','A') );\r
+ end;\r
+\r
+ _odd:=idx_get+_doo; if _odd>0 then dec(_odd);\r
+ \r
+ testRange(zm, _odd, 62); //subrange_bounds(zm,idx_get+_doo,$FFFF);\r
+\r
+ test_eol(i,zm,zm,#0);\r
+\r
+ if txt<>'' then begin\r
+ txt:=GetFile(txt,zm);\r
+\r
+ if pass=pass_end then begin\r
+ WriteAccessFile(txt);\r
+\r
+ AssignFile(g, txt); FileMode:=1; Rewrite(g,1);\r
+ blockwrite(g, t_get[idx_get], _doo);\r
+ closefile(g);\r
+ end;\r
+\r
+ end else begin\r
+\r
+ if (pass=pass_end) and (_doo>0) then\r
+ for idx:=0 to _doo-1 do save_dst(t_get[idx_get+idx]);\r
+\r
+ inc(adres,_doo);\r
+ end;\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .PAGES *)\r
+(*----------------------------------------------------------------------------*)\r
+ __pages:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if adres<0 then blad(zm,10) else begin\r
+\r
+ save_lst('a');\r
+\r
+ war:=1;\r
+ txt:=get_dat_noSPC(i,zm,' ',#0,zm);\r
+\r
+ if txt<>'' then begin\r
+ k:=1; war:=___wartosc_noSPC(txt,zm,k,#0,'A'); // dopuszczalny zakres wartosci to .WORD\r
+\r
+ k:=integer(war);\r
+ testRange(zm, k, 0);\r
+ end;\r
+\r
+ omin_spacje(i,zm);\r
+ if not(test_char(i,zm,#0,#0)) then blad(zm,4);\r
+\r
+ t_pag[pag_idx].adr:= integer(adres and $7FFFFF00);\r
+ t_pag[pag_idx].cnt:= integer(war) shl 8;\r
+\r
+ inc(pag_idx);\r
+ if pag_idx>High(t_pag) then SetLength(t_pag,pag_idx+1);\r
+\r
+ save_end(__endpg);\r
+\r
+// ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .ENDPG *)\r
+(*----------------------------------------------------------------------------*)\r
+ __endpg:\r
+ if ety<>'' then blad(zm,38) else \r
+ if macro_rept_if_test then\r
+ if pag_idx=0 then blad(zm,64) else begin\r
+\r
+ save_lst('a');\r
+\r
+ dec(pag_idx);\r
+\r
+ _odd := t_pag[pag_idx].adr;\r
+ _doo := (adres-1) and $7FFFFF00;\r
+\r
+ if pass=pass_end then\r
+ if (_doo-_odd) >= t_pag[pag_idx].cnt then warning(70);\r
+\r
+// dec(end_idx);\r
+ dec_end(zm,__endpg);\r
+ \r
+// ety:='';\r
+ end;\r
+ \r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .RELOC *)\r
+(*----------------------------------------------------------------------------*)\r
+ __reloc:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if not(hea and not(mne_used)) then blad(zm,83) else begin\r
+\r
+ inc(bank);\r
+ if bank>=__id_param then blad(zm,45);\r
+\r
+ test_wyjscia(zm,false);\r
+\r
+ save_hea;\r
+\r
+ if dreloc.use then begin\r
+ rel_idx:=0; ext_idx:=0; extn_idx:=0; skip.idx:=0; pub_idx:=0;\r
+ smb_idx:=0; sym_idx:=0;\r
+ ext_used.use:=false; rel_used:=false; blocked:=false;\r
+ blkupd.adr:=false; blkupd.ext:=false; blkupd.pub:=false;\r
+ blkupd.sym:=false; blkupd.new:=false;\r
+ end;\r
+\r
+ save_lst(' ');\r
+\r
+ k:=get_type(i,zm,zm,false);\r
+\r
+ if k=1 then\r
+ rel_ofs := __rel\r
+ else\r
+ rel_ofs := __relASM;\r
+\r
+ dreloc.use:=true;\r
+ adres:=rel_ofs;\r
+\r
+ first_org:=false;\r
+ org:=true;\r
+\r
+ save_dstW( __relHea ); // dodatkowy naglowek bloku relokowalnego 'MR'\r
+ save_dstW( rel_ofs ); // informacja o rodzaju bloku .WORD (bit0)\r
+\r
+ // zapisujemy wartosci etykiet dla stosu programowego\r
+ indeks:=adr_label(0,false); save_dstW( indeks ); // @stack_pointer\r
+ indeks:=adr_label(1,false); save_dstW( indeks ); // @stack_address\r
+ indeks:=adr_label(2,false); save_dstW( indeks ); // @proc_vars_adr\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .LINK 'filename' *)\r
+(* pozwala dolaczyc kod relokowalny tzn. pliki DOS o adresie $0000 *)\r
+(*----------------------------------------------------------------------------*)\r
+ __link:\r
+// if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then\r
+ if dreloc.use then blad(zm,57) else begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+// save_lst(zm,'a');\r
+\r
+// omin_spacje(i,zm);\r
+ txt:=get_string(i,zm,zm,true);\r
+\r
+ txt:=GetFile(txt,zm); if not(TestFile(txt)) then blad(txt,18);\r
+ test_eol(i,zm,zm,#0);\r
+\r
+ AssignFile(g, txt); FileMode:=0; Reset(g,1);\r
+\r
+ // sprawdzamy czy wczytujemy plik DOS'a (pierwsze dwa bajty pliku = __HEA_DOS)\r
+ t_lnk[0]:=0;\r
+ t_lnk[1]:=0;\r
+\r
+ blockread(g,t_lnk,2);\r
+ if (t_lnk[0]+t_lnk[1] shl 8)<>__hea_dos then blad(zm,74);\r
+\r
+ Reset(g,1);\r
+ blockread(g,t_lnk,sizeof(t_lnk),IDX); // wczytujemy caly plik do T_LNK o dlugosci IDX\r
+\r
+// w glownej petli uzywamy zmiennych IDX, K, _ODD\r
+\r
+ _odd:=0; dlink.use:=false; dlink.len:=0; dlink.emp:=0;\r
+\r
+ while _odd<idx do begin\r
+\r
+ j:=fgetW(_odd);\r
+ if j=$FFFF then j:=fgetW(_odd);\r
+\r
+\r
+ case j of\r
+\r
+ // blk RELOC\r
+ __hea_reloc:\r
+ begin\r
+\r
+ if dlink.use then flush_link;\r
+\r
+ k:=fgetW(_odd); // odczytujemy dlugosc pliku relokowalnego, maks $FFFE\r
+\r
+ if k=$ffff then // tzn ze dlugosc pliku = 0\r
+ k:=0\r
+ else\r
+ inc(k); // zwiekszamy o 1\r
+\r
+ j:=fgetW(_odd); // odczytujemy 2 bajty z dodatkowego naglowka 'MR'\r
+ if j<>__relHea then blad(zm,74);\r
+(*----------------------------------------------------------------------------*)\r
+(* bajt 0 - nieuzywany *)\r
+(* bajt 1 - bit 0 kod strony zerowej (0), kod poza strona zerowa (1) *)\r
+(* bit 1..7 nieuzywne *)\r
+(*----------------------------------------------------------------------------*)\r
+ fgetB(_odd); // odczytujemy 2 bajty z informacja o pliku .RELOC\r
+ v:=fgetB(_odd);\r
+\r
+ if (v=0) and (adres>$FF) then blad(zm,76);\r
+\r
+ __link_stack_pointer_old := fgetW(_odd); // @stack_pointer\r
+ __link_stack_address_old := fgetW(_odd); // @stack_address\r
+ __link_proc_vars_adr_old := fgetW(_odd); // @proc_vars_adr\r
+\r
+ if pass=0 then begin\r
+\r
+ if dlink.stc then\r
+ if (__link_stack_pointer_old<>__link_stack_pointer) or\r
+ (__link_stack_address_old<>__link_stack_address) or\r
+ (__link_proc_vars_adr_old<>__link_proc_vars_adr) then warning(75);\r
+\r
+ if not(dlink.stc) then begin\r
+ __link_stack_pointer := __link_stack_pointer_old;\r
+ __link_stack_address := __link_stack_address_old;\r
+ __link_proc_vars_adr := __link_proc_vars_adr_old;\r
+\r
+ txt:=mads_stack[0]; save_fake_label(txt,zm,__link_stack_pointer); //@stack_pointer\r
+ txt:=mads_stack[1]; save_fake_label(txt,zm,__link_stack_address); //@stack_address\r
+ txt:=mads_stack[2]; save_fake_label(txt,zm,__link_proc_vars_adr); //@proc_vars_adr\r
+ end;\r
+\r
+ end;\r
+\r
+ move(t_lnk[_odd],t_ins,k); // wczytujemy blok relokowalny do T_INS\r
+ inc(_odd,k);\r
+\r
+ dlink.len:=k; dlink.use:=true; dlink.stc:=true;\r
+ end;\r
+\r
+ // BLK UPDATE ADDRESS\r
+ __hea_address:\r
+ begin\r
+ ch := chr( fgetB(_odd) );\r
+ j := fgetW(_odd);\r
+\r
+ while j>0 do begin\r
+\r
+ idx_get:=fgetW(_odd);\r
+ \r
+ tst:=adres;\r
+\r
+ case ch of\r
+\r
+ 'E': begin // pusty blok rezerwujacy pamiec\r
+ dlink.emp := idx_get;\r
+ end;\r
+\r
+ '<','B':\r
+ begin\r
+ inc(tst, t_ins[idx_get]);\r
+\r
+ t_ins[idx_get] := byte(tst);\r
+ end;\r
+\r
+ '>': begin\r
+ inc(tst, t_ins[idx_get] shl 8);\r
+\r
+ v:=fgetB(_odd); // dodatkowy bajt dla relokacji starszych adresow\r
+\r
+ inc(tst,v);\r
+\r
+ t_ins[idx_get] := byte(tst shr 8);\r
+ end;\r
+\r
+ 'W': begin\r
+ inc(tst, t_ins[idx_get]);\r
+ inc(tst, t_ins[idx_get+1] shl 8);\r
+\r
+ t_ins[idx_get] := byte(tst);\r
+ t_ins[idx_get+1]:= byte(tst shr 8);\r
+ end;\r
+\r
+ 'L': begin\r
+ inc(tst, t_ins[idx_get]);\r
+ inc(tst, t_ins[idx_get+1] shl 8);\r
+ inc(tst, t_ins[idx_get+2] shl 16);\r
+\r
+ t_ins[idx_get] := byte(tst);\r
+ t_ins[idx_get+1]:= byte(tst shr 8);\r
+ t_ins[idx_get+2]:= byte(tst shr 16);\r
+ end;\r
+\r
+ 'D': begin\r
+ inc(tst, t_ins[idx_get]);\r
+ inc(tst, t_ins[idx_get+1] shl 8);\r
+ inc(tst, t_ins[idx_get+2] shl 16);\r
+ inc(tst, t_ins[idx_get+3] shl 24);\r
+\r
+ t_ins[idx_get] := byte(tst);\r
+ t_ins[idx_get+1]:= byte(tst shr 8);\r
+ t_ins[idx_get+2]:= byte(tst shr 16);\r
+ t_ins[idx_get+3]:= byte(tst shr 24);\r
+ end;\r
+\r
+ end;\r
+\r
+ dec(j);\r
+ end;\r
+\r
+ end;\r
+\r
+ // BLK UPDATE EXTERNAL\r
+ __hea_external:\r
+ begin\r
+ ch := chr ( fgetB(_odd) );\r
+ j := fgetW(_odd);\r
+\r
+ txt:=fgetS(_odd); // label_ext name\r
+\r
+ idx_get:=load_lab(txt,false);\r
+ if idx_get<0 then begin\r
+ war:=0;\r
+ if pass=pass_end then blad_und(zm,txt,73);\r
+ end else\r
+ war:=oblicz_wartosc(txt,zm);\r
+\r
+ v:=ord(value_code(war,zm,true));\r
+\r
+ // sprawdzamy czy zgadza sie typ etykiety\r
+ if pass=pass_end then\r
+ case ch of\r
+ 'B': if chr(v)<>'Z' then blad_und(zm,txt,41);\r
+ 'W': if not(chr(v) in ['Z','Q']) then blad_und(zm,txt,41);\r
+ 'L': if not(chr(v) in ['Z','Q','T']) then blad_und(zm,txt,41);\r
+ end;\r
+\r
+\r
+ while j>0 do begin\r
+ idx_get:=fgetW(_odd);\r
+\r
+ tst:=word(war);\r
+\r
+ case ch of\r
+ 'B','<':\r
+ begin\r
+ inc(tst, t_ins[idx_get]);\r
+\r
+ t_ins[idx_get] := byte(tst);\r
+ end;\r
+\r
+ '>': begin\r
+ inc(tst, t_ins[idx_get] shl 8);\r
+\r
+ v:=fgetB(_odd); // dodatkowy bajt dla relokacji starszych adresow\r
+\r
+ inc(tst,v);\r
+\r
+ t_ins[idx_get] := byte(tst shr 8);\r
+ end; \r
+\r
+ 'W': begin\r
+ inc(tst, t_ins[idx_get]);\r
+ inc(tst, t_ins[idx_get+1] shl 8);\r
+\r
+ t_ins[idx_get] := byte(tst);\r
+ t_ins[idx_get+1]:= byte(tst shr 8);\r
+ end;\r
+\r
+ 'L': begin\r
+ inc(tst, t_ins[idx_get]);\r
+ inc(tst, t_ins[idx_get+1] shl 8);\r
+ inc(tst, t_ins[idx_get+2] shl 16);\r
+\r
+ t_ins[idx_get] := byte(tst);\r
+ t_ins[idx_get+1]:= byte(tst shr 8);\r
+ t_ins[idx_get+2]:= byte(tst shr 16);\r
+ end;\r
+\r
+ 'D': begin\r
+ inc(tst, t_ins[idx_get]);\r
+ inc(tst, t_ins[idx_get+1] shl 8);\r
+ inc(tst, t_ins[idx_get+2] shl 16);\r
+ inc(tst, t_ins[idx_get+3] shl 24);\r
+\r
+ t_ins[idx_get] := byte(tst);\r
+ t_ins[idx_get+1]:= byte(tst shr 8);\r
+ t_ins[idx_get+2]:= byte(tst shr 16);\r
+ t_ins[idx_get+3]:= byte(tst shr 24);\r
+ end;\r
+\r
+ end;\r
+\r
+ dec(j);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ // BLK UPDATE PUBLIC\r
+ __hea_public:\r
+ begin\r
+ j:=fgetW(_odd);\r
+\r
+ while j>0 do begin\r
+\r
+ typ:= chr ( fgetB(_odd) ); // TYPE B-YTE, W-ORD, L-ONG, D-WORD\r
+\r
+ ch := chr ( fgetB(_odd) ); // LABEL_TYPE V-ARIABLE, P-ROCEDURE, C-ONSTANT\r
+\r
+ if dlink.use then tst:=adres else tst:=0;\r
+\r
+ case ch of\r
+ 'P': begin\r
+ str:=fgetS(_odd); // label_pub name\r
+\r
+ inc(tst, fgetW(_odd)); // adres procedury\r
+\r
+ r:=fgetB(_odd); // kolejnosc rejestrow CPU\r
+\r
+ rodzaj:=chr(fgetB(_odd)); // typ procedury\r
+\r
+ if not(rodzaj in [__pDef, __pReg, __pVar]) then blad_und(zm,str,41);\r
+\r
+ idx_get:=fgetW(_odd); // liczba danych na temat parametrow\r
+\r
+\r
+ proc_nr:=proc_idx; // koniecznie przez ADD_PROC_NR\r
+\r
+ \r
+ if pass=0 then begin\r
+\r
+ _doo:=_odd+idx_get;\r
+\r
+ txt:='(';\r
+ while _odd<_doo do begin\r
+\r
+ v:=TypeToByte( chr( fgetB(_odd) ) ); // liczba bajtow przypadajaca na parametr\r
+\r
+ txt:=txt+mads_param[v];\r
+\r
+ case rodzaj of // parametr jesli trzeba\r
+ __pDef: tmp:='par'+IntToStr(_odd);\r
+\r
+ __pReg: begin\r
+ tmp:='';\r
+ while v<>0 do begin\r
+ tmp:=tmp+ByteToReg(r);\r
+ dec(v)\r
+ end;\r
+ end;\r
+\r
+ __pVar: tmp:=fgetS(_odd);\r
+ end;\r
+\r
+ txt:=txt+tmp+' ';\r
+ end;\r
+\r
+ txt:=txt+')';\r
+\r
+ case rodzaj of\r
+ __pReg: txt:=txt+' .REG';\r
+ __pVar: txt:=txt+' .VAR';\r
+ end;\r
+\r
+ i:=1;\r
+ get_procedure(str,str,txt,i); // odczytujemy parametry\r
+\r
+ proc:=false; // koniecznie wylaczamy PROC\r
+ proc_name:=''; // i koniecznie PROC_NAME := ''\r
+\r
+ end else\r
+ inc(_odd,idx_get); // koniecznie zwiekszamy _ODD gdy PASS<>0\r
+\r
+ upd_procedure(str,zm,tst);\r
+\r
+ proc:=false; // koniecznie wylaczamy PROC\r
+ proc_name:=''; // i koniecznie PROC_NAME = ''\r
+\r
+ add_proc_nr; // zwiekszamy koniecznie numer procedury\r
+ end;\r
+\r
+ 'A': begin // upubliczniamy .ARRAY\r
+ str:=fgetS(_odd);\r
+\r
+ _doo:= fgetW(_odd);\r
+\r
+ inc(tst, _doo); // nowy adres etykiety\r
+\r
+ save_lab(str, array_idx, __id_array, zm);\r
+\r
+ save_arr(tst, bank); // tutaj ARRAY_IDX zostaje zwiekszone o 1\r
+\r
+ _doo:= fgetW(_odd);\r
+\r
+ v:=TypeToByte( chr( fgetB(_odd) ) );\r
+\r
+ t_arr[array_idx-1].idx:=_doo; // dlatego teraz ARRAY_IDX-1\r
+\r
+ t_arr[array_idx-1].siz := v;\r
+ t_arr[array_idx-1].len := (_doo+1)*v;\r
+\r
+ end;\r
+\r
+ 'S': begin // upubliczniamy .STRUCT\r
+ str:=fgetS(_odd);\r
+\r
+ _doo:= fgetW(_odd);\r
+\r
+ upd_structure(str, zm); // UPD_STRUCTURE ustawi wartosc STRUCT.IDX\r
+\r
+ zapisz_lokal;\r
+ lokal_name:=lokal_name+str+'.';\r
+\r
+ struct.adres:=0;\r
+\r
+ while _doo>0 do begin\r
+ v:=TypeToByte( chr( fgetB(_odd) ) );\r
+\r
+ str:=fgetS(_odd);\r
+\r
+ j:=fgetW(_odd);\r
+\r
+ save_str(str,struct.adres,v,j,adres,bank);\r
+ save_lab(str,struct.adres,bank,zm);\r
+\r
+ inc(struct.adres, v*j);\r
+\r
+ inc(struct.cnt);\r
+\r
+ dec(_doo);\r
+ end;\r
+\r
+ t_str[struct.idx].siz := struct.adres; // zapisujemy dlugosc struktury\r
+\r
+ t_str[struct.idx].ofs := struct.cnt; // i liczbe pol struktury\r
+\r
+ inc(struct.id); // zwiekszamy identyfikator struktury (liczba struktur)\r
+\r
+ struct.cnt := -1;\r
+\r
+ oddaj_lokal(zm);\r
+ end;\r
+\r
+ 'V': begin\r
+ str:=fgetS(_odd);\r
+\r
+ _doo:= fgetW(_odd);\r
+\r
+ inc(tst, _doo); // nowy adres etykiety\r
+\r
+ save_lab(str,tst,bank,zm); // variable\r
+ end;\r
+\r
+ 'C': begin\r
+ str:=fgetS(_odd);\r
+\r
+ case typ of\r
+ 'B': vtmp:=fgetB(_odd);\r
+ 'W': vtmp:=fgetW(_odd);\r
+ 'L': vtmp:=fgetL(_odd);\r
+ 'D': vtmp:=fgetD(_odd);\r
+ end;\r
+\r
+ save_lab(str,vtmp,bank,zm); // constant\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ dec(j);\r
+ end;\r
+\r
+ end;\r
+ else\r
+\r
+ begin\r
+ flush_link;\r
+\r
+ k:=fgetW(_odd); // odczytujemy dlugosc pliku relokowalnego\r
+ inc(k); // zwiekszamy o 1\r
+\r
+ testRange(zm,k, 62); // maksymalna dlugosc pliku $FFFF\r
+\r
+ save_hea;\r
+ adres:=j; org:=true;\r
+\r
+ dlink.len:=k-j;\r
+\r
+ move(t_lnk[_odd],t_ins,dlink.len); // wczytujemy blok relokowalny do T_INS\r
+ inc(_odd,dlink.len);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+\r
+ end;\r
+\r
+ flush_link;\r
+\r
+ closefile(g);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .PUBLIC label [,label2,label3...] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __public:\r
+ if ety<>'' then blad(zm,38) else\r
+ if macro_rept_if_test then begin\r
+\r
+ save_lst(' ');\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ while not(test_char(i,zm,#0,#0)) do begin\r
+\r
+ txt:=get_lab(i,zm, true);\r
+\r
+ save_pub(txt,zm);\r
+\r
+ _odd:=load_lab(txt,false);\r
+ if _odd>=0 then t_lab[_odd].use:=true; //etykieta domyslnie w uzyciu\r
+\r
+ __next(i,zm);\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* .SYMBOL label *)\r
+(*----------------------------------------------------------------------------*)\r
+ __symbol:\r
+ if macro_rept_if_test then\r
+ if not(dreloc.sdx) then blad(zm,53) else begin // tylko gdy blok relokowalny SDX\r
+\r
+ if ety='' then ety:=get_lab(i,zm, true);\r
+\r
+ if not(test_char(i,zm,#0,#0)) then blad(zm,4);\r
+\r
+ save_lst(' ');\r
+\r
+ // zapisujemy symbol .SYMBOL w T_SYM\r
+ t_sym[sym_idx] := ety; // SAVE_SYM\r
+ inc(sym_idx); //\r
+ if sym_idx>High(t_sym) then SetLength(t_sym,sym_idx+1); //\r
+\r
+ end;\r
+\r
+ \r
+(*----------------------------------------------------------------------------*)\r
+(* INS 'filename' [+-expression] [,length[,offset]] *)\r
+(* .GET [index] 'filename' [+-expression] [,length[,offset]] *)\r
+(*----------------------------------------------------------------------------*)\r
+ __ins,__get:\r
+ if macro_rept_if_test then\r
+// if loop_used then blad(zm,36) else \r
+ if first_org and (opt and 1>0) and (mne.l=__ins) then blad(zm,10) else begin\r
+\r
+ data_out:=true;\r
+\r
+ idx_get:=0;\r
+\r
+ omin_spacje(i,zm);\r
+\r
+ if mne.l=__get then\r
+ if zm[i] in ['[','('] then begin\r
+ txt:=ciag_ograniczony(i,zm,true);\r
+ k:=1; idx_get:=integer( ___wartosc_noSPC(txt,zm,k,#0,'A') );\r
+ end;\r
+\r
+// omin_spacje(i,zm);\r
+ txt:=get_string(i,zm,zm,true); \r
+\r
+ txt:=GetFile(txt,zm); if not(TestFile(txt)) then blad(txt,18);\r
+\r
+ if (GetFileName(txt)=GetFileName(a)) or (GetFileName(txt)=GetFileName(plik_asm)) then blad(txt,18);\r
+\r
+ AssignFile(g, txt); FileMode:=0; Reset(g,1);\r
+\r
+ k:=integer(FileSize(g)); _odd:=0; _doo:=k;\r
+\r
+ v:=byte( test_string(i,zm,'B') );\r
+\r
+ if zm[i]=',' then begin\r
+ __inc(i,zm);\r
+\r
+ _odd:=integer( ___wartosc_noSPC(zm,zm,i,',','F') );\r
+\r
+ if _odd<0 then begin\r
+ _doo:=abs(_odd); _odd:=k+_odd;\r
+ end else _doo:=k-abs(_odd);\r
+\r
+ if zm[i]=',' then begin\r
+ __inc(i,zm);\r
+\r
+ _doo:=integer( ___wartosc_noSPC(zm,zm,i,',','F') );\r
+// - testRange(zm, _doo, 13);\r
+ if _doo<0 then begin\r
+ blad(zm,13);\r
+ _doo:=0;\r
+ end;\r
+\r
+ test_eol(i,zm,zm,#0);\r
+ end;\r
+ end else test_eol(i,zm,zm,#0);\r
+\r
+ // sprawdz czy nie zostala przekroczona dlugosc pliku\r
+ if (abs(_odd)>k) or (abs(_odd)+abs(_doo)>k) then blad(zm,24);\r
+ k:=_doo;\r
+\r
+\r
+ // dlugosc pliku nie moze byc mniejsza od 0\r
+// - testRange(zm, k, 25); //if k>$FFFF then blad(zm,25);\r
+ if k<0 then begin\r
+ blad(zm,25);\r
+ k:=0;\r
+ end;\r
+\r
+\r
+ save_lst('a');\r
+\r
+ if mne.l=__get then begin // .GET\r
+\r
+ j:=idx_get+_doo;\r
+ testRange(zm, j, 62); // subrange_bounds(zm,idx_get+_doo,$FFFF+1);\r
+\r
+ if _odd>0 then seek(g,_odd); // omin _ODD bajtow w pliku\r
+ blockread(g,t_get[idx_get],_doo); // odczytaj _DOO bajtow od indeksu [IDX_GET]\r
+\r
+ end else // INS\r
+ if (pass=pass_end) and (_doo>0) then begin\r
+\r
+// if opt and 1=0 then first_org := true;\r
+\r
+ if _odd>0 then seek(g,_odd); // omin _ODD bajtow w pliku\r
+\r
+ for j:=0 to (_doo div $10000)-1 do begin\r
+ blockread(g, t_ins, $10000); // odczytaj 64KB bajtow\r
+ for idx:=0 to $FFFF do save_dst( byte( t_ins[idx]+v ) );\r
+ end;\r
+\r
+ j:=_doo mod $10000; // odczytaj pozostale bajty\r
+\r
+ blockread(g, t_ins, j);\r
+\r
+ for idx:=0 to j-1 do save_dst( byte( t_ins[idx]+v ) );\r
+ end;\r
+\r
+ closefile(g);\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ if mne.l<>__get then inc(adres, k);\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* END *)\r
+(*----------------------------------------------------------------------------*)\r
+ __end, __en:\r
+ if loop_used then blad(zm,36) else begin\r
+\r
+ end_file:=true;\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+\r
+ save_lst('a');\r
+\r
+ mne.l:=0;\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* DTA [abefgtcd] 'string',expression... *)\r
+(* lub dodajemy nowe pola do struktury .STRUCT *)\r
+(*----------------------------------------------------------------------------*)\r
+ __dta,__byte..__dword:\r
+ if macro_rept_if_test then\r
+ if first_org and (opt and 1>0) and not(struct.use) then blad(zm,10) else begin\r
+ \r
+ if struct.use then begin // zapisujemy pola struktury\r
+\r
+ if ety='' then blad(zm,15); // pola struktury musza posiadac etykiety\r
+ if mne.l=__dta then blad(zm,58); // przyjmujemy tylko nazwy typow\r
+\r
+ j:=mne.l-__byteValue; // J = <1..4>\r
+ k:=adres-struct.adres;\r
+\r
+ if ety+'.'=lokal_name then blad(zm,57); // nazwa pola musi byc <> od nazwy struktury\r
+\r
+ save_str(ety,k,j,rpt,adres,bank);\r
+ save_lab(ety,k,bank,zm);\r
+\r
+ nul.i:=k;\r
+ save_lst('l');\r
+\r
+ if loop_used then begin\r
+ loop_used:=false;\r
+ j := j*rpt;\r
+ end;\r
+\r
+ inc(adres, j);\r
+\r
+ inc(struct.cnt); // zwiekszamy licznik pol struktury\r
+\r
+// ety:='';\r
+\r
+ end else\r
+ create_struct_data(i,zm,ety, mne.l);\r
+\r
+ ety:='';\r
+ end;\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* ICL 'filename' *)\r
+(*----------------------------------------------------------------------------*)\r
+ __icl:\r
+ if macro_rept_if_test then\r
+ if loop_used then blad(zm,36) else begin\r
+\r
+ save_lab(ety,adres,bank,zm);\r
+ save_lst('a');\r
+\r
+ txt:=get_string(i,zm,zm,true);\r
+\r
+ txt:=GetFile(txt,zm);\r
+\r
+ if not(TestFile(txt)) then begin\r
+ tmp:=GetFile(txt+'.asm', zm);\r
+\r
+ if not(TestFile(tmp)) then\r
+ blad(txt,18)\r
+ else\r
+ txt:=tmp;\r
+\r
+ end;\r
+\r
+ test_eol(i,zm,zm,#0);\r
+\r
+// if (GetFileName(txt)=GetFileName(a)) or (GetFileName(txt)=GetFileName(plik_asm)) then blad(txt,18);\r
+ if (txt=a) or (txt=plik_asm) then blad(txt,18);\r
+\r
+ // sprawdzamy czy jest to plik tekstowy w pierwszych dwóch przebiegach asemblacji\r
+ if pass<2 then begin\r
+ assignfile(f, txt); FileMode:=0; Reset(f);\r
+ readln(f, tmp);\r
+ CloseFile(f);\r
+ if pos(#0,tmp)>0 then blad(zm,74);\r
+ end;\r
+\r
+ str:=zm; zapisz_lst(str);\r
+\r
+ old_icl_used := icl_used;\r
+ icl_used:=true;\r
+\r
+ analizuj_plik__(txt,zm);\r
+\r
+ bez_lst:=true;\r
+// put_lst(show_full_name(a,full_name,true),'');\r
+ global_name:=a;\r
+\r
+ line:=nr;\r
+\r
+ icl_used := old_icl_used;\r
+\r
+ ety:='';\r
+ mne.l:=0;\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ // zapamietanie etykiety jesli wystapila\r
+ // i zapisanie zdekodowanych rozkazow\r
+ if if_test then begin\r
+\r
+ omin_spacje(i,zm);\r
+ txt:=''; ___search_comment_block(i,zm,txt);\r
+\r
+ if ety<>'' then begin\r
+\r
+// if mne_used then\r
+\r
+ label_type:='V'; // !!! koniecznie label_type = V-ariable\r
+\r
+// else\r
+// label_type:='C';\r
+\r
+ if pass=pass_end then\r
+ if adres<0 then warning(10);\r
+\r
+ save_lab(ety,adres,bank,zm); // pozostale etykiety bez zmian\r
+\r
+ save_lst('a');\r
+ end;\r
+\r
+\r
+// writeln(zm,' | ',if_test);\r
+\r
+\r
+ if mne.l<__equ then begin\r
+\r
+ nul:=mne;\r
+\r
+ if (mne.l=0) and (ety='') then\r
+ save_lst(' ')\r
+ else\r
+ save_lst('a');\r
+\r
+ nul.l:=0;\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ // zapisz wynik asemblacji do pliku LST\r
+\r
+ if not(loop_used) and not(FOX_ripit) then begin\r
+\r
+ if not(bez_lst) then zapisz_lst(zm);\r
+\r
+\r
+ bez_lst:=false;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure get_line(var zm:string; var end_file,ok:Boolean; var _odd,_doo:integer; var app: Boolean; var appLine: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* pobieramy linie i sprawdzamy czy linia nie jest komentarzem *)\r
+(*----------------------------------------------------------------------------*)\r
+var i, j: integer;\r
+ str: string;\r
+begin\r
+ if end_file then exit;\r
+\r
+ noWarning:=false;\r
+\r
+ if not(macro) and not(rept) then\r
+ if komentarz then begin\r
+ i:=1;\r
+ str:=''; search_comment_block(i,zm,str);\r
+\r
+ if str<>'' then begin\r
+ save_lst(' ');\r
+ justuj;\r
+ put_lst(t+zm);\r
+\r
+ zm:=copy(zm,i,length(zm));\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ if not(komentarz) then\r
+ if not(macro) and not(rept) and (pos('\',zm)>0) then begin // pobie¿ny test na obecnosc znaku '\'\r
+ i:=1;\r
+ str:=get_dat(i,zm,'\',false); // tutaj sprawdzamy dokladniej\r
+\r
+ SetLength(t_lin, 1);\r
+\r
+ if zm[i]='\' then begin\r
+ save_lst(' ');\r
+ justuj;\r
+ put_lst(t+zm);\r
+\r
+ _odd:=High(t_lin);\r
+ i:=1;\r
+ while true do begin\r
+ str:=get_dat(i,zm,'\',false);\r
+\r
+ j:=1; omin_spacje(j, str);\r
+ if j>length(str) then str:='';\r
+\r
+ j:=High(t_lin); // SAVE_LIN\r
+ t_lin[j]:=str; //\r
+ SetLength(t_lin,j+2); //\r
+\r
+ if zm[i]='\' then inc(i) else Break;\r
+ end;\r
+\r
+ _doo:=High(t_lin);\r
+\r
+\r
+ if str='' then begin\r
+ app:=true;\r
+\r
+ appLine:=appLine+t_lin[_doo-2];\r
+\r
+ dec(_doo,2);\r
+ end;\r
+\r
+\r
+ lst_off:=true;\r
+\r
+ ok:=false;\r
+ exit;\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ app:=false;\r
+\r
+ i:=1;\r
+\r
+ if zm<>'' then begin\r
+ omin_spacje(i,zm);\r
+\r
+ if not((zm[i] in [';','*']) or ((zm[i]='|') and (zm[i+1]<>'|')) or komentarz) then ok:=true;\r
+\r
+ str:=''; ___search_comment_block(i,zm, str);\r
+ end;\r
+\r
+\r
+// !!! linie z komentarzem /* */ byly traktowane jako puste linie !!!\r
+\r
+{ omin_spacje(i,zm); // sprawdzamy czy wiersz nie zawiera samych "bialych znakow"\r
+\r
+ if not(macro) and not(rept) then\r
+ if (i>length(zm)) then begin\r
+ ok:=false;\r
+\r
+ if not(komentarz) then zm:=''; // jesli nie jest to komentarz to zapiszemy tylko pusty wiersz\r
+ end; }\r
+\r
+\r
+ if not(macro) and not(rept) and not(run_macro) and not(rept_run) then\r
+ if (zm='') or not(ok) then begin\r
+ save_lst(' ');\r
+\r
+ if zm<>'' then\r
+ justuj\r
+ else\r
+ SetLength(t,6);\r
+\r
+ put_lst(t+zm);\r
+\r
+ ok:=false;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure analizuj_plik(var a:string; var old_str: string);\r
+(*----------------------------------------------------------------------------*)\r
+(* odczyt pliku ASM wiersz po wierszu *)\r
+(*----------------------------------------------------------------------------*)\r
+var f: textfile;\r
+ rept_nr, rept_ile, nr, _odd, _doo: integer;\r
+ end_file, ok, wyjscie, app, _app: Boolean;\r
+ zm, appLine, _appLine: string;\r
+ v: byte;\r
+begin\r
+ if not(TestFile(a)) then blad(a,18);\r
+\r
+ AssignFile(f,a); FileMode:=0; Reset(f);\r
+\r
+ _odd:=0; _doo:=0; rept_ile:=0; rept_nr:=0;\r
+\r
+ nr:=0; // nr linii w asemblowanym pliku\r
+ global_name:=a; // nazwa pliku dla funkcji 'BLAD'\r
+ end_file:=false; // czy napotkal rozkaz 'END'\r
+ wyjscie:=false; // czy wystapilo EXIT w makrze\r
+\r
+ app:=false; appLine:='';\r
+ _app:=false; _appLine:='';\r
+\r
+\r
+ // nazwe pierwszego pliku zawsze zapisze do LST\r
+ // pod warunkiem ze (opt and 4>0) czyli wystapilo OPT L+\r
+ if (opt and 4>0) then\r
+ if (pass=pass_end) and (a[2]=':') then\r
+ writeln(lst,show_full_name(global_name,true,true))\r
+ else\r
+ put_lst(show_full_name(global_name,full_name,true));\r
+\r
+\r
+ while (not eof(f)) or (_doo>0) do begin\r
+\r
+ ok:=false;\r
+\r
+ if _doo>0 then begin\r
+ zm:=t_lin[_odd];\r
+ inc(_odd);\r
+ if _odd>=_doo then begin _doo:=0; lst_off:=false; end;\r
+\r
+ get_line(zm,end_file,ok,_odd,_doo, _app,_appLine); \r
+\r
+ end else begin\r
+ readln(f,zm);\r
+\r
+ if length(zm)>$FFFF then begin // maksymalna dlugosc wiersza 65535 znakow\r
+ blad(zm,101); koniec(2)\r
+ end;\r
+\r
+ inc(nr); line:=nr; inc(line_all);\r
+\r
+ get_line(zm,end_file,ok,_odd,_doo, app,appLine);\r
+\r
+ if ok and not(app) and (appLine<>'') then begin\r
+ save_lst(' ');\r
+ justuj;\r
+ put_lst(t+zm);\r
+\r
+ zm:=appLine+zm;\r
+ appLine:=''; \r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ if macro then begin\r
+ v:=dirMACRO(zm);\r
+\r
+ if v in [{__end+1,} __en] then end_file:=true; // !!! dla __end+1 zatrzyma sie gdy 'lda end' \r
+\r
+ end else \r
+\r
+ if rept then begin\r
+\r
+ v:=dirREPT(zm); \r
+\r
+ if v=__endr then\r
+ dirENDR(zm,a,old_str,rept_nr,rept_ile)\r
+ else\r
+ if v in [__end+1, __en] then end_file:=true;\r
+\r
+ end else\r
+ \r
+ if ok and not(komentarz) then\r
+ analizuj_linie(zm,a,old_str, rept_nr,rept_ile, nr, end_file,wyjscie);\r
+\r
+\r
+ if end_file then Break;\r
+\r
+ end;\r
+\r
+\r
+ if appLine<>'' then analizuj_linie(appLine,a,old_str, rept_nr,rept_ile, nr, end_file,wyjscie);\r
+\r
+\r
+ test_skipa;\r
+ if skip.use then blad(zm,84); // Can't skip over this\r
+\r
+\r
+ oddaj_var;\r
+\r
+ if a=plik_asm then oddaj_ds; // !!! koniecznie tutaj, inaczej po ICL z .DS bedzie generowal nowy blok EMPTY\r
+\r
+\r
+ if pass=pass_end then\r
+ if (a=plik_asm) {and not(first_org)} then begin // wymuszamy BLK UPDATE na koncu glownego pliku\r
+\r
+ if dreloc.use or dreloc.sdx then begin\r
+\r
+ save_lst('a');\r
+ if not(blkupd.adr) then begin zm:=load_mes(91)+load_mes(92); blk_update_address(zm) end;\r
+ save_lst('a');\r
+ if not(blkupd.ext) then begin zm:=load_mes(91)+load_mes(93); blk_update_external(zm) end;\r
+ save_lst('a');\r
+ if not(blkupd.pub) then begin zm:=load_mes(91)+load_mes(94); blk_update_public(zm) end;\r
+ save_lst('a');\r
+ if not(blkupd.sym) then begin zm:=load_mes(91)+load_mes(95); blk_update_symbol(zm) end;\r
+ save_lst('a');\r
+\r
+ oddaj_sym;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ test_wyjscia(zm,wyjscie);\r
+\r
+ closefile(f);\r
+end;\r
+\r
+\r
+\r
+procedure analizuj_mem(const start,koniec:integer; var old,a,old_str:string; licz:integer; const p_max:integer; const rp:Boolean);\r
+(*----------------------------------------------------------------------------*)\r
+(* odczyt i analiza wierszy zapisanych w tablicy dynamicznej T_MAC *)\r
+(* P_MAX okresla liczbe powtorzen *)\r
+(*----------------------------------------------------------------------------*)\r
+var rept_ile, rept_nr, licznik, nr, _odd, _doo, old_line_add: integer;\r
+ end_file, ok, wyjscie, old_icl_used, app, _app: Boolean;\r
+ zm, appLine, _appLine: string;\r
+ v: byte;\r
+begin\r
+\r
+ old_icl_used := icl_used;\r
+ icl_used := true;\r
+\r
+ old_line_add := line_add; // !!! koniecznie zapamietac LINE_ADD !!!\r
+ line_add := 0; // inaczej numer linii z bledem dla np. "lda:cmp:rq" bedzie zly\r
+\r
+\r
+ _odd:=0; _doo:=0; rept_ile:=0; rept_nr:=0;\r
+\r
+ while licz < p_max do begin\r
+\r
+ if rp or FOX_ripit then ___rept_ile := licz;\r
+\r
+ licznik:=start;\r
+\r
+ nr:=old_line_add; // nr linii w asemblowanym pliku\r
+ end_file:=false; // czy napotkal rozkaz 'END'\r
+ wyjscie:=false; // czy wystapilo EXIT w makrze\r
+\r
+ app:=false; appLine:='';\r
+ _app:=false; _appLine:='';\r
+\r
+ \r
+ while (licznik<koniec) or (_doo>0) do begin\r
+\r
+ ok:=false;\r
+\r
+ if _doo>0 then begin\r
+\r
+ zm:=t_lin[_odd]; inc(_odd);\r
+\r
+ if _odd>=_doo then begin\r
+ _doo:=0; lst_off:=false\r
+ end;\r
+\r
+ get_line(zm,end_file,ok, _odd,_doo, _app,_appLine);\r
+\r
+ end else begin\r
+ zm:=t_mac[licznik];\r
+\r
+ reptLine(zm); // podstawiamy parametry w bloku .REPT\r
+\r
+ inc(licznik);\r
+\r
+ inc(nr);\r
+ line:=nr; \r
+\r
+ inc(line_all);\r
+\r
+ get_line(zm,end_file,ok, _odd,_doo, app,appLine);\r
+\r
+ if ok and not(app) and (appLine<>'') then begin\r
+ save_lst(' ');\r
+ justuj;\r
+ put_lst(t+zm);\r
+ \r
+ zm:=appLine+zm;\r
+ appLine:=''; \r
+ end;\r
+\r
+ end;\r
+ \r
+\r
+ if rept then begin\r
+\r
+ v:=dirREPT(zm);\r
+\r
+ if v=__endr then\r
+ dirENDR(zm,a,old_str,rept_nr,rept_ile)\r
+ else\r
+ if v in [__end+1, __en] then end_file:=true;\r
+\r
+ end else\r
+\r
+ if ok and not(end_file) and not(komentarz) then\r
+ analizuj_linie(zm,a,old_str, rept_nr,rept_ile, nr, end_file,wyjscie);\r
+\r
+\r
+ if wyjscie then Break; // zakonczenie przetwarzania makra przez dyrektywe .EXIT\r
+\r
+ end;\r
+\r
+\r
+ if appLine<>'' then analizuj_linie(appLine,a,old_str, rept_nr,rept_ile, nr, end_file,wyjscie);\r
+\r
+\r
+ test_wyjscia(old,wyjscie);\r
+ \r
+ inc(licz);\r
+ end;\r
+\r
+ icl_used := old_icl_used;\r
+ line_add := old_line_add;\r
+end;\r
+\r
+\r
+\r
+procedure asem(var a:string);\r
+(*----------------------------------------------------------------------------*)\r
+(* asemblacja glownego pliku *.ASM *)\r
+(*----------------------------------------------------------------------------*)\r
+var i: integer;\r
+ s: string;\r
+begin\r
+\r
+ while (pass<=pass_end) and (pass<pass_max) do begin // maksymalnie PASS_MAX przebiegow\r
+\r
+ line_all:=0;\r
+\r
+ s:='';\r
+ analizuj_plik(a, s);\r
+ \r
+ if list_mac then begin\r
+ s:=' icl '''+plik_mac+'''';\r
+ analizuj_plik(plik_mac, s);\r
+ end;\r
+\r
+ t_hea[hea_i]:=adres-1; // koniec programu, ostatni wpis\r
+\r
+ inc(pass);\r
+\r
+ // jesli NEXT_PASS = TRUE to zwieksz liczbe przebiegow\r
+ if (pass>=pass_end) or (pass<1) then\r
+ if next_pass then inc(pass_end);\r
+\r
+ // !!! zerowanie numeru wywolania makra !!!\r
+ for i:=High(t_lab)-1 downto 0 do\r
+ if t_lab[i].bnk=__id_macro then t_mac[ t_lab[i].adr + 3 ] := '0';\r
+\r
+ label_type:='V';\r
+\r
+ zpvar:=$80;\r
+\r
+ adres:=-$FFFF; raw.old:=-$FFFF;\r
+\r
+ hea_ofs.adr:=-1; struct.cnt:=-1; ___rept_ile:=-1;\r
+\r
+ regOpty.reg[0]:=-1; regOpty.reg[1]:=-1; regOpty.reg[2]:=-1;\r
+\r
+ array_used.max:=0;\r
+\r
+ fillchar(t_zpv, sizeof(t_zpv), false);\r
+\r
+ hea_i:=0; bank:=0; ifelse:=0; blok:=0; rel_ofs:=0; org_ofset:=0;\r
+ proc_idx:=0; proc_nr:=0; lokal_nr:=0; lc_nr:=0; fill:=0;\r
+ line_add:=0; struct.id:=0; wyw_idx:=0; rel_idx:=0; array_idx:=0;\r
+ ext_idx:=0; extn_idx:=0; skip.idx:=0; smb_idx:=0; sym_idx:=0;\r
+ pag_idx:=0; end_idx:=0; var_idx:=0; pub_idx:=0; usi_idx:=0;\r
+ whi_idx:=0; while_nr:=0; ora_nr:=0; test_nr:=0;\r
+ test_idx:=0; var_id:=0; proc_lokal:=0;\r
+\r
+ __link_stack_pointer := adr_label(0,false); // @STACK_POINTER\r
+ __link_stack_address := adr_label(1,false); // @STACK_ADDRESS\r
+ __link_proc_vars_adr := adr_label(2,false); // @PROC_VARS_ADR\r
+\r
+ siz_idx:=1;\r
+\r
+ opt := optDefault;\r
+\r
+ hea:=true; first_org:=true; if_test:=true; TestWhileOpt:=true;\r
+ exProcTest:=true;\r
+\r
+ regOpty.use:=false; regOpty.blk:=false; mae_labels:=false;\r
+ loop_used:=false; macro:=false; proc:=false; regAXY_opty:=false;\r
+ undeclared:=false; new_local:=false;\r
+ icl_used:=false; bez_lst:=false; empty:=false; enum.use:=false;\r
+ reloc:=false; branch:=false; vector:=false; rept:=false; rept_run:=false;\r
+ struct.use:=false; dta_used:=false; code6502:=false;\r
+ struct_used.use:=false; aray:=false; next_pass:=false;\r
+ mne_used:=false; skip.use:=false; skip.xsm:=false; FOX_ripit:=false;\r
+ put_used:=false; ext_used.use:=false; dreloc.use:=false; dreloc.sdx:=false;\r
+ rel_used:=false; blocked:=false; dlink.stc:=false;\r
+ blokuj_zapis:=false; overflow:=false; test_symbols:=false;\r
+ lst_off:=false; noWarning:=false; raw.use:=false; variable:=false;\r
+\r
+ komentarz:=false; org:=false;\r
+\r
+ lokal_name:=''; macro_nr:=''; str_blad:=''; while_name:=''; test_name:='';\r
+\r
+ warning_old:='';\r
+\r
+\r
+// SetLength(t_lin, 1); // T_LIN mozemy zapisywac od nowa\r
+\r
+ \r
+ if binary_file.use then begin\r
+ adres := binary_file.adr;\r
+ org := true;\r
+ first_org := false;\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ // jesli nie wystapil zaden blad i mamy 16 przebiegow to na pewno nastapila petla bez konca\r
+\r
+ if (status=0) and (pass=pass_max) then begin\r
+ writeln(#13#10'Infinite loop !!!');\r
+ koniec(2);\r
+ end;\r
+ \r
+end;\r
+\r
+\r
+procedure Syntax;\r
+(*----------------------------------------------------------------------------*)\r
+(* wyswietlamy informacje na temat przelacznikow, konfiguracji MADS'a *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+ Writeln(load_mes(119+1));\r
+ Writeln(load_mes(117+1));\r
+ halt(3);\r
+end;\r
+\r
+\r
+function NewFileExt(nam: string; const ext: string): string;\r
+begin\r
+\r
+ if pos('.',nam)>0 then begin\r
+ obetnij_kropke(nam);\r
+ Result:=nam+ext;\r
+ end else\r
+ Result:=nam+'.'+ext;\r
+\r
+end;\r
+\r
+\r
+function nowy_plik(var a: string; var i:integer): string;\r
+var name, path: string;\r
+begin\r
+\r
+ path:='';\r
+\r
+ Result:=a;\r
+\r
+ inc(i,2); // omijamy znak przelacznika i znak ':'\r
+\r
+ name:=copy(t,i,length(t));\r
+\r
+ if GetFilePath(name)<>'' then path:=GetFilePath(name);\r
+\r
+ if name<>'' then Result:=path+GetFileName(name);\r
+\r
+ inc(i,length(name));\r
+end;\r
+\r
+\r
+procedure INITIALIZE;\r
+(*----------------------------------------------------------------------------*)\r
+(* procedura obliczajaca tablice CRC16, CRC32, mniej miejsca zajmuje anizeli *)\r
+(* gotowa predefiniowana tablica *)\r
+(*----------------------------------------------------------------------------*)\r
+var IORes, _i, x, y: integer;\r
+ crc: cardinal;\r
+ crc_: Int64;\r
+ tmp: string;\r
+\r
+const\r
+ // HASH_VAL i HASH_OFS wylicza osobny program\r
+ // nie trzeba przechowywac w pamieci stringow z nazwami\r
+ hash_val: array [0..282] of byte=(\r
+ $56,$01,$58,$42,$1E,$1F,$E0,$59,$F0,$3E,$0E,$86,\r
+ $A0,$04,$9E,$9E,$29,$2A,$98,$98,$43,$48,$8D,$89,\r
+ $8C,$93,$97,$3C,$CA,$3D,$D3,$9D,$0A,$33,$9F,$9B,\r
+ $9B,$07,$50,$12,$22,$18,$13,$51,$36,$9F,$9B,$9B,\r
+ $E2,$4E,$9D,$9C,$24,$44,$1B,$49,$08,$85,$9C,$97,\r
+ $BC,$57,$63,$32,$9F,$9B,$9B,$A2,$63,$A2,$65,$83,\r
+ $B9,$B6,$F0,$68,$CD,$54,$23,$19,$AA,$31,$9F,$9B,\r
+ $9B,$8A,$67,$20,$AC,$6B,$45,$94,$17,$A6,$A2,$87,\r
+ $9C,$5B,$9C,$15,$30,$97,$9F,$9B,$9B,$5C,$09,$5A,\r
+ $4C,$55,$D6,$BF,$C6,$61,$C2,$88,$40,$C3,$70,$3B,\r
+ $3A,$1C,$1D,$0F,$0C,$3F,$BE,$2F,$4D,$41,$35,$9F,\r
+ $9B,$9B,$A5,$99,$99,$14,$16,$AC,$0B,$0D,$34,$9F,\r
+ $9B,$9B,$4F,$A6,$84,$21,$37,$9F,$9B,$9B,$2B,$AF,\r
+ $A1,$D4,$38,$A3,$8B,$82,$F0,$8E,$69,$95,$81,$B2,\r
+ $1A,$A3,$9A,$9A,$9C,$B8,$9C,$97,$A4,$62,$2D,$02,\r
+ $28,$46,$4A,$BA,$68,$26,$11,$CB,$2E,$05,$9E,$9E,\r
+ $53,$2C,$03,$27,$47,$4B,$25,$10,$06,$9E,$9E,$52,\r
+ $AB,$D7,$39,$E1,$6F,$A9,$67,$6D,$6A,$A7,$69,$C9,\r
+ $B7,$A7,$D1,$77,$62,$F0,$CE,$71,$74,$76,$F0,$AA,\r
+ $A9,$B9,$AE,$D5,$61,$A4,$B0,$C1,$BB,$65,$B4,$66,\r
+ $AD,$64,$BE,$BD,$CF,$AE,$C5,$B0,$CC,$C0,$73,$75,\r
+ $6E,$C8,$66,$A1,$C3,$6C,$B1,$6B,$D8,$6C,$CF,$D8,\r
+ $CE,$B3,$6A,$D0,$B4,$CD,$C4,$C3,$C7,$72,$CC,$AA,\r
+ $64,$A8,$D0,$C0,$AF,$B5,$D2);\r
+\r
+ hash_ofs: array [0..282] of word=(\r
+ $0458,$048C,$04A4,$04B0,$0510,$0590,$059E,$05C9,$060E,$0642,$064F,$0684,\r
+ $068A,$0693,$06CD,$06ED,$0714,$0734,$0853,$0881,$0910,$0990,$09AC,$09AE,\r
+ $09B2,$09B3,$0A03,$0A54,$0A68,$0A74,$0A82,$0AB3,$0C53,$0C62,$0C6A,$0C72,\r
+ $0C73,$0C81,$0C94,$0CA4,$0CB3,$0D83,$0DC9,$0E74,$0EC2,$0ECA,$0ED2,$0ED3,\r
+ $0EF2,$1074,$1081,$10A4,$10B3,$1110,$1183,$1190,$11C1,$11C5,$11C9,$1203,\r
+ $1284,$1478,$155E,$15C2,$15CA,$15D2,$15D3,$1925,$1A4F,$1B79,$1C4B,$1E4F,\r
+ $1EE6,$1EE7,$20ED,$2258,$22D8,$2437,$24B3,$2583,$2585,$25A2,$25AA,$25B2,\r
+ $25B3,$25C9,$266F,$2692,$2760,$2C28,$2D10,$2D82,$2E42,$2F88,$2FDC,$3069,\r
+ $30A4,$31AA,$31C9,$31F2,$3202,$3203,$320A,$3212,$3213,$3242,$3261,$326A,\r
+ $3292,$3497,$3538,$354A,$361E,$3721,$3AA5,$3AB2,$3ACD,$3FD3,$400D,$40B2,\r
+ $40B3,$4110,$4190,$41A3,$41AA,$41E3,$41E6,$41EE,$4293,$42CD,$44A2,$44AA,\r
+ $44B2,$44B3,$463C,$4910,$4990,$49E5,$49F2,$4A25,$4A6A,$4A6C,$4C62,$4C6A,\r
+ $4C72,$4C73,$4C74,$4D85,$4DC9,$4E92,$4EC2,$4ECA,$4ED2,$4ED3,$4F14,$4FA1,\r
+ $50C9,$50FC,$5122,$51D4,$51E2,$520F,$521A,$5245,$5297,$5305,$5625,$56C2,\r
+ $5983,$5A04,$5C53,$5C81,$5CA4,$5D5E,$5DC9,$5E03,$5E83,$5EDF,$6034,$608C,\r
+ $60A4,$6110,$6190,$61A1,$61A6,$61C9,$6203,$6231,$6274,$6293,$62CD,$62ED,\r
+ $6334,$6434,$648C,$64A4,$6510,$6590,$65C9,$6603,$6693,$66CD,$66ED,$6714,\r
+ $68C2,$6A46,$6A93,$6B3A,$733C,$73F5,$7833,$7B65,$7C8D,$7D7A,$7E9D,$7F58,\r
+ $7F79,$8154,$843F,$864A,$8976,$8A4B,$8C5C,$8D4A,$92F2,$9704,$987A,$990E,\r
+ $9998,$9B88,$9E9D,$9F41,$9F52,$A152,$A307,$A3EE,$A421,$A934,$A9FB,$AB24,\r
+ $ACD0,$AFC6,$B2B3,$B633,$B904,$B9DA,$B9F0,$BA41,$BFBD,$C10A,$C257,$CA0E,\r
+ $CA5A,$CD5F,$CDE6,$CE0D,$CF8A,$D040,$D0C2,$D0CD,$D417,$D894,$D91C,$DB0C,\r
+ $DE1A,$E073,$E3FC,$E767,$E829,$E97F,$EB60,$EBA8,$F129,$F166,$F1FE,$F353,\r
+ $F5F1,$F6D0,$F6E5,$F88C,$F8D5,$FAC5,$FCCE);\r
+\r
+begin\r
+\r
+// szukanie indeksow dla MES\r
+ y:=0;\r
+ for x:=0 to sizeof(mes)-1 do\r
+ if ord(mes[x])>$7f then begin\r
+ dec(mes[x],$80);\r
+ imes[y]:=x;\r
+ inc(y);\r
+ end;\r
+ \r
+\r
+ for x:=0 to 255 do begin\r
+\r
+ crc:=x shl 8;\r
+ crc_:=crc;\r
+\r
+ for y:=1 to 8 do begin\r
+ crc := crc shl 1;\r
+ crc_ := crc_ shr 1;\r
+\r
+ if (crc and $00010000) > 0 then crc := crc xor $1021;\r
+ if (crc_ and $80) > 0 then crc_ := crc_ xor $edb8832000;\r
+ end;\r
+\r
+ tcrc16[x] := integer(crc);\r
+ tcrc32[x] := cardinal(crc_ shr 8);\r
+ end;\r
+\r
+\r
+ for IORes:=sizeof(hash_val)-1 downto 0 do hash[hash_ofs[IORes]] := hash_val[IORes];\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* przetwarzanie parametrow, inicjalizacja zmiennych *)\r
+(*----------------------------------------------------------------------------*)\r
+\r
+ plik_asm:=''; \r
+\r
+ if ParamCount<1 then Syntax;\r
+\r
+ // odczyt parametrow\r
+ for IORes:=1 to ParamCount do begin\r
+ t:=ParamStr(IORes);\r
+\r
+ if t<>'' then\r
+// if not(t[1] in ['/','-']) then begin\r
+ if not(t[1]='-') then begin // w celu kompatybilnosci z Linuxami, Mac OS X\r
+\r
+ if plik_asm<>'' then \r
+ Syntax\r
+ else\r
+ plik_asm:=t\r
+ \r
+ end else begin\r
+\r
+ _i:=2;\r
+ while _i<=length(t) do begin\r
+\r
+ case UpCase(t[_i]) of\r
+\r
+\r
+ 'C': case_used := true;\r
+ 'F': labFirstCol := true;\r
+ 'P': full_name := true;\r
+ 'S': silent := true;\r
+ 'X': exclude_proc := true;\r
+ 'U': unused_label := true;\r
+ 'V': if UpCase(t[_i+1])='U' then begin inc(_i,2); VerifyProc := true end;\r
+\r
+\r
+ 'B': if t[_i+1]<>':' then\r
+ Syntax\r
+ else begin\r
+ inc(_i,2);\r
+\r
+ tmp:=get_dat(_i,t,' ',true);\r
+\r
+ binary_file.adr := integer( oblicz_wartosc(tmp, t) );\r
+\r
+ binary_file.use := true;\r
+ end;\r
+ \r
+ 'D': if t[_i+1]<>':' then Syntax else begin\r
+ inc(_i,2);\r
+ def_label:=get_lab(_i,t, true);\r
+\r
+ if t[_i]<>'=' then\r
+ nul.i:=1\r
+ else begin\r
+ inc(_i);\r
+ nul.i:=integer( get_expres(_i,t,t, false) );\r
+ end; \r
+\r
+ s_lab(def_label,nul.i,bank,t,def_label[1]);\r
+ end;\r
+\r
+ 'H': begin\r
+ inc(_i);\r
+\r
+ case UpCase(t[_i]) of\r
+ 'C': begin\r
+ list_hhh:=true;\r
+ if t[_i+1]=':' then plik_h:=nowy_plik(plik_h, _i);\r
+ end;\r
+\r
+ 'M': begin\r
+ list_mmm:=true;\r
+ if t[_i+1]=':' then plik_hm:=nowy_plik(plik_hm, _i);\r
+ end;\r
+ else\r
+ Syntax\r
+ end;\r
+\r
+ end;\r
+\r
+ 'I': if t[_i+1]<>':' then Syntax else begin\r
+ name:=nowy_plik(name, _i);\r
+\r
+ if name='' then Syntax else begin\r
+ t_pth[High(t_pth)]:=name; \r
+ SetLength(t_pth, High(t_pth)+2);\r
+ end;\r
+\r
+ end;\r
+\r
+ 'L': begin\r
+ opt:=opt or 4;\r
+ if t[_i+1]=':' then plik_lst:=nowy_plik(plik_lst, _i);\r
+ end;\r
+\r
+ 'M': if t[_i+1]<>':' then Syntax else begin\r
+ list_mac:=true;\r
+ plik_mac:=nowy_plik(plik_mac, _i);\r
+ end;\r
+\r
+ 'O': if t[_i+1]<>':' then Syntax else plik_obj:=nowy_plik(plik_obj, _i);\r
+\r
+ 'T': begin\r
+ list_lab:=true;\r
+ if t[_i+1]=':' then plik_lab:=nowy_plik(plik_lab, _i);\r
+ end;\r
+\r
+ else\r
+ Syntax;\r
+ end;\r
+\r
+ inc(_i);\r
+ end;\r
+\r
+ end;\r
+\r
+ end;\r
+\r
+\r
+ if (plik_asm='') or (GetFileName(plik_asm)='') then Syntax;\r
+\r
+ path:=GetFilePath(plik_asm);\r
+ if path='' then begin GetDir(0,path); path:=path+PathDelim end;\r
+\r
+ name:=GetFileName(plik_asm);\r
+ global_name:=name;\r
+\r
+// sprawdzamy obecnosc pliku ASM\r
+ plik_asm:=path+name;\r
+ if not(TestFile(plik_asm)) then plik_asm := path + NewFileExt(name,'asm');\r
+\r
+\r
+ if plik_lst = '' then plik_lst := path + NewFileExt(name,'lst');\r
+ if plik_obj = '' then plik_obj := path + NewFileExt(name,'obx');\r
+ if plik_lab = '' then plik_lab := path + NewFileExt(name,'lab');\r
+ if plik_mac = '' then plik_mac := path + NewFileExt(name,'mac');\r
+ if plik_h = '' then plik_h := path + NewFileExt(name,'h');\r
+ if plik_hm = '' then plik_hm := path + NewFileExt(name,'hea');\r
+\r
+ t:=load_mes(119+1);\r
+\r
+// if not(silent) then new_message(t);\r
+\r
+ if list_lab then begin\r
+ WriteAccessFile(plik_lab); AssignFile(lab,plik_lab); FileMode:=1; Rewrite(lab);\r
+ writeln(lab,t);\r
+ writeln(lab,load_mes(54+1));\r
+ end;\r
+\r
+\r
+ name:=GetFileName(plik_asm);\r
+ _i:=1; name:=get_datUp(_i,name,'.',false);\r
+ \r
+ if list_mmm then begin\r
+ WriteAccessFile(plik_hm); AssignFile(mmm,plik_hm); FileMode:=1; Rewrite(mmm);\r
+ end;\r
+\r
+ if list_hhh then begin\r
+ WriteAccessFile(plik_h); AssignFile(hhh,plik_h); FileMode:=1; Rewrite(hhh);\r
+ writeln(hhh,'#ifndef _'+name+'_ASM_H_');\r
+ writeln(hhh,'#define _'+name+'_ASM_H_'+#13#10);\r
+ end;\r
+\r
+ WriteAccessFile(plik_lst); AssignFile(lst,plik_lst); FileMode:=1; Rewrite(lst);\r
+\r
+ WriteAccessFile(plik_obj); Assignfile(dst,plik_obj); FileMode:=1; Rewrite(dst,1);\r
+\r
+ Writeln(lst,t); // naglowek z nazwa programu do pliku LST\r
+end;\r
+\r
+\r
+{\r
+procedure tttt(a: string);\r
+begin\r
+ case length(a) of\r
+ 1,2: writeln(hex(ord(a[1]) shl 8+ord(a[2]),8));\r
+ 3: writeln(hex(ord(a[1]) shl 16+ord(a[2]) shl 8+ord(a[3]),8));\r
+ 4: writeln(hex(ord(a[1]) shl 24+ord(a[2]) shl 16+ord(a[3]) shl 8+ord(a[4]),8));\r
+ end;\r
+end;\r
+}\r
+\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* M A I N P R O G R A M *)\r
+(*----------------------------------------------------------------------------*)\r
+begin\r
+\r
+ ___search_comment_block := search_comment_block;\r
+\r
+ oblicz_mnemonik__ := oblicz_mnemonik;\r
+ analizuj_plik__ := analizuj_plik;\r
+ analizuj_mem__ := analizuj_mem;\r
+ ___wartosc_noSPC := oblicz_wartosc_noSPC;\r
+\r
+ SetLength(t_lab,1);\r
+ SetLength(t_hea,1);\r
+ SetLength(t_mac,1);\r
+ SetLength(t_par,1);\r
+ SetLength(t_loc,1);\r
+ SetLength(t_prc,1);\r
+ SetLength(t_pth,1);\r
+ SetLength(t_wyw,1);\r
+ SetLength(t_rel,1);\r
+ SetLength(t_smb,1);\r
+ SetLength(t_ext,1);\r
+ SetLength(t_extn,1);\r
+ SetLength(t_str,1);\r
+ SetLength(t_arr,1);\r
+ SetLength(t_pag,1);\r
+ SetLength(t_end,1);\r
+ SetLength(t_mad,1);\r
+ SetLength(t_pub,1);\r
+ SetLength(t_var,1);\r
+ SetLength(t_skp,1);\r
+// SetLength(t_lin,1);\r
+ SetLength(t_sym,1);\r
+ SetLength(t_usi,1);\r
+ SetLength(t_els,1);\r
+ SetLength(if_stos,1);\r
+\r
+ SetLength(t_siz,2);\r
+\r
+ SetLength(messages,1);\r
+\r
+\r
+ pass:=1;\r
+\r
+(*----------------------------------------------------------------------------*)\r
+(* tworzenie tablic 'TCRC16', 'TCRC32' oraz tablicy 'HASH', odczyt parametrow *)\r
+(*----------------------------------------------------------------------------*)\r
+ INITIALIZE;\r
+\r
+\r
+ if binary_file.use then begin\r
+ opt := opt or 2;\r
+ adres := binary_file.adr;\r
+ org := true;\r
+ first_org := false;\r
+ end;\r
+\r
+ optDefault := opt;\r
+\r
+ open_ok:=true;\r
+\r
+ t:='';\r
+\r
+ nul.l:=0;\r
+ nul.i:=0;\r
+\r
+ pass:=0;\r
+\r
+ asem(plik_asm);\r
+\r
+ over:=true;\r
+ koniec(status);\r
+end.\r
projects / vuplus_xbmc / commitdiff