(*----------------------------------------------------------------------------*) (* Mad-Assembler v1.9.0 by Tomasz Biela (aka Tebe/Madteam) *) (* *) (* support 6502, 65816, Sparta DOS X, virtual banks *) (* .LOCAL, .MACRO, .PROC, .STRUCT, .ARRAY, .REPT, .PAGES, .ENUM *) (* #WHILE, #IF, #ELSE *) (* *) (* last changes: 04.08.2009 *) (*----------------------------------------------------------------------------*) // Free Pascal Compiler, http://www.freepascal.org/ // Compile: fpc -Mdelphi -vh -O3 mads.pas program MADS; {$APPTYPE CONSOLE} {$I-} //uses SysUtils; type _typStrREG = string [4]; _typStrSMB = string [8]; _typStrINT = string [32]; _argArray = array [0..31] of byte; _strArray = array of string; _intArray = array of integer; _carArray = array of cardinal; _bolArray = array of Boolean; labels = record nam: cardinal; // identyfikator etykiety (CRC32) adr: cardinal; // wartosc etykiety ofs: integer; // wartosc etykiety przed zmiana adresu asemblacji len: integer; // dlugosc etykiety w bajtach <1..65535> blk: integer; // blok przypisany etykiecie lln: integer; // dlugosc bloku .LOCAL lid: Boolean; // identyfikator etykiety .LOCAL bnk: integer; // licznik wirtualnych bankow przypisany do etykiety <0..$FF>, na potrzeby MADS-a jest on typu WORD sts: Boolean; // czy definicja etykiety powiodla sie rel: Boolean; // czy relokowac pas: byte; // numer przebiegu dla danej etykiety typ: char; // typ etykiety (V-ARIABLE, P-ROCEDURE, C-ONSTANT) use: Boolean; // czy etykieta jest używana end; wywolyw = record zm: string; // wiersz listingu pl: string; // nazwa pliku ktorego zawartosc asemblujemy nr: integer; // numer linii listingu end; stosife = record _if_test: Boolean; // stan IF_TEST _else: Boolean; // czy wystapilo .ELSE _okelse: integer; // numer aktualnego poziomu .IF old_iftest: Boolean; // stan IF_TEST przed wykonaniem nowego .IF end; relocLab = record adr: integer; // adres relokowalny idx: integer; // indeks do T_SMB lub T_SIZ blk: integer; // numer segmentu blo: integer; // numer bloku bnk: integer; // bank end; relocSmb = record smb: _typStrSMB; // 8 znakowy symbol SMB dla systemu SDX use: Boolean; // czy w programie nastapilo odwolanie do symbolu end; extLabel = record adr: cardinal; // adres pod ktorym wystapila etykieta external bnk: integer; // bank w ktorym wystapila etykieta external idx: integer; // index do T_EXT typ: char; // typ operacji ' ', '<', '>', '^' lsb: byte; end; usingLab = record lok: integer; // numer obszaru lokalnego nam: string; // nazwa obszaru w ktorym wystapilo .USING lab: string; // etykieta end; pubTab = record nam: string; // nazwa etykiety publicznej typ: Boolean; // aktualny adres asemblacji end; mesTab = record pas: byte; // numer przebiegu mes: string; // tresc komunikatu bledu end; locTab = record nam: string; // nazwa bloku .LOCAL adr: integer; // aktualny adres asemblacji idx: integer; // indeks do tablicy T_LAB ofs: integer; // poprzedni adres asemblacji end; arrayTab = record adr: cardinal; // adres tablicy bnk: integer; // bank przypisany tablicy idx: integer; // okreslony indeks tablicy [0..IDX] def: Boolean; // czy zostal okreslony indeks tablicy siz: byte; // wielkosc pola tablicy B-YTE, W-ORD, L-ONG, D-WORD len: integer; // dlugosc tablicy w bajtach ofs: integer; end; varTab = record lok: integer; // nr poziomu lokalnego nam: string; // nazwa zmiennej siz: integer; // rozmiar zmiennej cnt: integer; // wielokrotnosc rozmiaru zmiennej war: cardinal; // wartosc poczatkowa zmiennej adr: integer; // adres zmiennych jesli zostal okreslony typ: char; // typ zmiennej V-AR, S-TRUCT, E-NUM idx: integer; // indeks do struktury tworzacej zmienna str: string; // nazwa struktury tworzacej zmienna id: integer; // identyfikator grupy etykiet deklarowanych przez .VAR w tym samym bloku zpv: Boolean; // ZPV = TRUE dla zmiennych deklarowanych przez .ZPVAR end; stctTab = record id: integer; // numer struktury (identyfikator) no: integer; // numer pozycji w strukturze (-1 gdy nie sa to pola struktury) adr: cardinal; // adres struktury bnk: integer; // bank przypisany strukturze idx: integer; // index do dodatkowej struktury ofs: integer; // ofset od poczatku struktury siz: integer; // rozmiar danych definiowanych przez pole struktury 1..4 (B-YTE..D-WORD) // lub calkowita dlugosc danych definiowanych przez strukture rpt: integer; // liczba powtorzen typu SIZ (SIZ*RPT = rozmiar calkowity pola) lab: string; // etykieta wystepujaca w .STRUCT end; procTab = record nam: string; // nazwa procedury .PROC str: integer; // indeks do T_MAC z nazwami parametrow adr: cardinal; // adres procedury ofs: integer; bnk: integer; // bank przypisany procedurze par: integer; // liczba parametrow procedury ile: integer; // liczba bajtow zajmowana przez parametry procedury typ: char; // typ procedury __pDef, __pReg, __pVar reg: byte; // kolejnosc rejestrow CPU use: Boolean; // czy procedura zostala uzyta w programie, czy pominac ja podczas asemblacji len: cardinal; // dlugosc procedury w bajtach pnr: integer; // proc_nr prc: Boolean; // proc = [TRUE, FALSE] oof: integer; // org_ofset pnm: string; // proc_name end; pageTab = record adr: integer; // poczatkowa strona pamieci cnt: integer; // liczba stron pamieci end; rSizTab = record siz: char; lsb: byte; end; endTab = record kod: byte; // kod konca bloku .END?? adr: integer; old: integer; sem: Boolean; // czy wystapil znak { end; extName = record nam: string; // nazwa etykiety external siz: char; // zadeklarowany rozmiar etykiety od 1..4 bajtow prc: Boolean; // czy etykieta external jest deklaracja procedury end; heaMad = record nam: string; // nazwa etykiety adr: cardinal; // adres przypisany etykiecie bnk: byte; // bank przypissany etykiecie typ: char; // typ etykiety (P-procedure, V-ariable, C-onstans) idx: integer; // index do tablicy T_PRC gdy etykiecie external przypisano procedure end; int5 = record // nowy typ dla OBLICZ_MNEMONIK l: byte; // liczba bajtow skladajaca sie na rozkaz CPU h: _argArray; // argumenty rozkazu i: integer; // ofset do tablic tmp: byte; // bajt pomocniczy end; relVal = record use: Boolean; cnt: integer; end; _bckAdr = array [0..1] of integer; c64kb = array [0..$FFFF] of cardinal; m64kb = array [0..$FFFF] of byte; m4kb = array [0..4095] of byte; t256i = array [0..255] of integer; t256c = array [0..255] of cardinal; t256b = array [0..255] of Boolean; var lst, lab, hhh, mmm: textfile; dst: file; label_type: char = 'V'; pass, status, memType, optDefault: byte; opt : byte = 3; // OPT default value bank: integer; __link_stack_pointer_old, __link_stack_address_old, __link_proc_vars_adr_old: cardinal; __link_stack_pointer, __link_stack_address, __link_proc_vars_adr: cardinal; blok, proc_lokal, fill, proc_idx: integer; whi_idx, while_nr, ora_nr, test_nr, test_idx, sym_idx, org_ofset: integer; hea_i, rel_ofs, wyw_idx, array_idx, buf_i: integer; proc_nr, lc_nr, lokal_nr, rel_idx, smb_idx, var_id, usi_idx: integer; line, line_err, line_all, line_add, ___rept_ile, ext_idx, extn_idx: integer; pag_idx, end_idx, pub_idx, var_idx, ifelse, ds_empty: integer; siz_idx : integer = 1; adres : integer = -$FFFF; zpvar : integer = $80; nul : int5; while_name, test_name: string; path, name, t, global_name, proc_name, def_label, str_blad: string; end_string, plik_h, plik_hm, plik_lst, plik_obj, warning_mes: string; plik_lab, plik_mac, plik_asm, macro_nr, lokal_name, warning_old: string; regOpty : record blk: Boolean; use: Boolean; reg: array [0..2] of integer; end; struct : record use, drelocUSE, drelocSDX: Boolean; idx, id, adres, cnt: integer; end = (use: false; drelocUSE: false; drelocSDX: false; idx: 0; id: 0; adres: 0; cnt: -1); struct_used : record use: Boolean; // czy powstala struktura danych idx: integer; // index do struktury zalozyciela cnt: integer; // licznik pozycji struktury end; array_used : record idx: integer; max: integer; // maksylany indeks na podstawie wprowadzonych danych typ: char; end; ext_used : record use: Boolean; idx: integer; siz: char; end; dreloc : record use: Boolean; // czy wystapila dyrektywa .RELOC sdx: Boolean; // czy wystapil pseudo rozkaz BLK SPARTA siz: char; // rozmiar etykiety end; dlink : record use: Boolean; // czy linkujemy blok z adresem ladowania $0000 stc: Boolean; // czy sprawdzalismy adresy stosu len: integer; // dlugosc bloku linkowanego emp: integer; // dlugosc pustego bloku end; skip : record use: Boolean; // czy zostal wywolany pseudorozkaz skoku xsm: Boolean; // czy wystapilo laczenie mnemonikow w stylu XASM-a hlt: Boolean; // blokada TEST_SKIPA jesli przetwarzamy makra rozdzielone znakiem ':' idx: integer; // indeks do tablicy T_SKP cnt: byte; // liczba odlozonych adresow w przod end; blkupd : record adr: Boolean; // czy wystapilo BLK UPDATE ADDRESS ext: Boolean; // czy wystapilo BLK UPDATE EXTERNAL pub: Boolean; // czy wystapilo BLK UPDATE PUBLIC sym: Boolean; // czy wystapilo BLK UPDATE SYMBOL new: Boolean; // czy wystapilo BLK UPDATE NEW SYMBOL end; binary_file : record use: Boolean; adr: integer; end; raw : record use: Boolean; old: integer; end; hea_ofs : record adr: integer; old: integer; end; enum : record use, drelocUSE, drelocSDX: Boolean; val, max: integer; end; VerifyProc : Boolean = false; exProcTest : Boolean = false; // wymagany w celu wyeliminowania 'Unreferenced procedures' new_local : Boolean = false; NoAllocVar : Boolean = false; // wstrzymaj się z alokacją zmiennych .VAR code6502 : Boolean = false; unused_label: Boolean = false; regAXY_opty : Boolean = false; // OPT R+- registry optymisation MW?,MV? mae_labels : Boolean = false; // OPT ?+- MAE ?labels undeclared : Boolean = false; variable : Boolean = false; klamra_used : Boolean = false; noWarning : Boolean = false; lst_off : Boolean = false; macro : Boolean = false; labFirstCol : Boolean = false; test_symbols: Boolean = false; overflow : Boolean = false; blokuj_zapis: Boolean = false; FOX_ripit : Boolean = false; blocked : Boolean = false; rel_used : Boolean = false; put_used : Boolean = false; exclude_proc: Boolean = false; mne_used : Boolean = false; data_out : Boolean = false; aray : Boolean = false; dta_used : Boolean = false; pisz : Boolean = false; rept : Boolean = false; rept_run : Boolean = false; empty : Boolean = false; reloc : Boolean = false; branch : Boolean = false; vector : Boolean = false; silent : Boolean = false; bez_lst : Boolean = false; icl_used : Boolean = false; komentarz : Boolean = false; case_used : Boolean = false; full_name : Boolean = false; proc : Boolean = false; run_macro : Boolean = false; loop_used : Boolean = false; org : Boolean = false; over : Boolean = false; open_ok : Boolean = false; list_lab : Boolean = false; list_hhh : Boolean = false; list_mmm : Boolean = false; list_mac : Boolean = false; next_pass : Boolean = false; regA : Boolean = true; // rozmiar rejestrow dla OPT T+ (track sep rep) regX : Boolean = true; // true = 8bit, false = 16bit regY : Boolean = true; first_org : Boolean = true; if_test : Boolean = true; hea : Boolean = true; TestWhileOpt: Boolean = true; ___search_comment_block : procedure (var i:integer; var zm,txt:string); analizuj_plik__ : procedure (var a:string; var old_str:string); analizuj_mem__ : procedure (const start,koniec:integer; var old,a,old_str:string; licz:integer; const p_max:integer; const rp:Boolean); oblicz_mnemonik__ : function (var i:integer; var a,old:string): int5; ___wartosc_noSPC : function (var zm,old:string; var i:integer; const sep,typ:Char): Int64; imes: t256i; tCRC16: t256i; tCRC32: t256c; reptPar: _strArray; // globalna tablica dla parametrów przekazywanych do .REPT // zmienna przechowujaca 2 adresy wstecz t_bck: _bckAdr; // hashowane mnemoniki i tryby adresowania hash: m64kb; // bufor dla dyrektywy .GET i .PUT t_get: m64kb; // bufor dla dyrektywy .LINK t_lnk: m64kb; // bufor dla wpisywanych danych do .ARRAY t_tmp: c64kb; // bufor dla odczytu plikow przez INS, maksymalna dlugosc pliku to 64KB t_ins: m64kb; // bufor pamieci dla zapisu t_buf: m4kb; // 256 znaczników dla zmiennych odkladanych na stronie zerowej t_zpv: t256b; // T_HEA zapamieta dlugosc bloku t_hea: _intArray; // tablica przechowujaca adres naprzod t_skp: _intArray; // T_LIN przechowuje polaczone znakiem '\' linie listingu (rozbite na wiersze) t_lin: _strArray; // T_MAC zapamieta linie z makrami, procedurami, petlami .REPT t_mac: _strArray; // T_PAR zapamieta nazwy parametrow procedur .PROC t_par: _strArray; // T_PTH zapamieta sciezki poszukiwan dla INS i ICL t_pth: _strArray; // T_SYM zapamieta nowe symbole dla SDX (blk update new i_settd 'i_settd') t_sym: _strArray; // T_ELS zapamieta wystapienia #ELSE w blokach #IF t_els: _bolArray; // T_LOC zapamieta nazwy obszarow .LOCAL t_loc: array of locTab; // MESSAGES - komunikaty o bledach i ostrzezeniach messages: array of mesTab; // T_PUB zapamieta nazwy etykiet .PUBLIC t_pub: array of pubTab; // T_VAR zapamieta nazwy etykiet .VAR t_var: array of varTab; // T_END zapamieta kolejnosci wywolywania dyrektyw .MACRO, .PROC, .LOCAL, .STRUCT, .ARRAY itd. t_end: array of endTab; // T_SIZ zapamieta rozmiary argumentow t_siz: array of rSizTab; // T_MAD zapamieta etykiety dla pliku naglowkowego *.HEA (-hm) t_mad: array of heaMad; // T_PAG zapamieta paremetry dla dyrektywy .PAGE t_pag: array of pageTab; // T_USI zapamieta paremetry dla dyrektywy .USE [.USING] t_usi: array of usingLab; // T_EXT zapamieta adresy wystapienia etykiet external // T_EXTN zapamieta deklaracje etykiet external t_ext: array of extLabel; t_extn: array of extName; // T_ARR zapamieta parametry tablic .ARRAY t_arr: array of arrayTab; // T_REL zapamieta relokowalne adresy etykiet SDX t_rel: array of relocLab; // T_SMB zapamieta relokowalne adresy symboli SDX t_smb: array of relocSmb; // T_PRC zapamieta parametry procedury .PROC t_prc: array of procTab; // T_LAB zapamieta etykiety t_lab: array of labels; // T_WYW zapamieta linie z wywolywanymi makrami, pomocne przy wyswietlaniu linii z bledem t_wyw: array of wywolyw; // T_STR zapamieta nazwy struktur .STRUCT t_str: array of stctTab; // stos dla operacji .IF .ELSE .ENDIF if_stos: array of stosife; pass_end : byte = 2; // pass = <0..2> // komunikaty mes: array [0..2911] of char=( {0} chr(ord('V') + $80),'a','l','u','e',' ','o','u','t',' ','o','f',' ','r','a','n','g','e', {1} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','I','F', {2} chr(ord(' ') + $80),'d','e','c','l','a','r','e','d',' ','t','w','i','c','e', {3} chr(ord('S') + $80),'t','r','i','n','g',' ','e','r','r','o','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', {5} chr(ord('U') + $80),'n','d','e','c','l','a','r','e','d',' ','l','a','b','e','l',' ', {6} chr(ord('N') + $80),'o',' ','m','a','t','c','h','i','n','g',' ','b','r','a','c','k','e','t', {7} chr(ord('N') + $80),'e','e','d',' ','p','a','r','e','n','t','h','e','s','i','s', {8} chr(ord('I') + $80),'l','l','e','g','a','l',' ','c','h','a','r','a','c','t','e','r',':',' ', {9} chr(ord('R') + $80),'e','s','e','r','v','e','d',' ','w','o','r','d',' ', {10} chr(ord('N') + $80),'o',' ','O','R','G',' ','s','p','e','c','i','f','i','e','d', {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', {12} chr(ord('I') + $80),'l','l','e','g','a','l',' ','i','n','s','t','r','u','c','t','i','o','n',' ', {13} chr(ord('V') + $80),'a','l','u','e',' ','o','u','t',' ','o','f',' ','r','a','n','g','e', {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', {15} chr(ord('L') + $80),'a','b','e','l',' ','n','a','m','e',' ','r','e','q','u','i','r','e','d', {16} chr(ord('I') + $80),'n','v','a','l','i','d',' ','o','p','t','i','o','n', {17} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D', {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', {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', {20} chr(ord('M') + $80),'i','s','s','i','n','g',' ','''','}','''', {21} chr(ord('B') + $80),'r','a','n','c','h',' ','o','u','t',' ','o','f',' ','r','a','n','g','e',' ','b','y',' ','$', {22} chr(ord(' ') + $80),'b','y','t','e','s', {23} chr(ord('U') + $80),'n','e','x','p','e','c','t','e','d',' ','e','n','d',' ','o','f',' ','l','i','n','e', {24} chr(ord('F') + $80),'i','l','e',' ','i','s',' ','t','o','o',' ','s','h','o','r','t', {25} chr(ord('F') + $80),'i','l','e',' ','i','s',' ','t','o','o',' ','l','o','n','g', {26} chr(ord('D') + $80),'i','v','i','d','e',' ','b','y',' ','z','e','r','o', {27} chr(ord('^') + $80),' ','n','o','t',' ','r','e','l','o','c','a','t','a','b','l','e', {28} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','L','O','C','A','L', {29} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','L', {30} chr(ord('U') + $80),'s','e','r',' ','e','r','r','o','r', {31} chr(ord('O') + $80),'p','e','r','a','n','d',' ','o','v','e','r','f','l','o','w', {32} chr(ord('B') + $80),'a','d',' ','s','i','z','e',' ','s','p','e','c','i','f','i','e','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', {34} chr(ord(' ') + $80), // !!! zarezerwowane !!! USER ERROR {35} chr(ord('U') + $80),'n','d','e','c','l','a','r','e','d',' ','m','a','c','r','o',' ', {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', {37} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','I','F', {38} chr(ord('L') + $80),'a','b','e','l',' ','n','o','t',' ','r','e','q','u','i','r','e','d', {39} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','P','R','O','C', {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', {41} chr(ord('I') + $80),'n','c','o','m','p','a','t','i','b','l','e',' ','t','y','p','e','s',' ', {42} chr(ord('.') + $80),'E','N','D','I','F',' ','e','x','p','e','c','t','e','d', {43} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','R', {44} chr(ord('S') + $80),'M','B',' ','l','a','b','e','l',' ','t','o','o',' ','l','o','n','g', {45} chr(ord('T') + $80),'o','o',' ','m','a','n','y',' ','b','l','o','c','k','s', {46} chr(ord('B') + $80),'a','d',' ','p','a','r','a','m','e','t','e','r',' ','t','y','p','e',' ', {47} chr(ord('B') + $80),'a','d',' ','p','a','r','a','m','e','t','e','r',' ','n','u','m','b','e','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', {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', {50} chr(ord('M') + $80),'i','s','s','i','n','g',' ','t','y','p','e',' ','l','a','b','e','l', {51} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','R','E','P','T', {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', {53} chr(ord('O') + $80),'n','l','y',' ','R','E','L','O','C',' ','b','l','o','c','k', {54} chr(ord('L') + $80),'a','b','e','l',' ','t','a','b','l','e',':', {55} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','S','T','R','U','C','T', {56} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','S', {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', {58} chr(ord('I') + $80),'m','p','r','o','p','e','r',' ','s','y','n','t','a','x', {59} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','A','R','R','A','Y', {60} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','A', {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',' ', {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', {63} chr(ord('B') + $80),'a','d',' ','r','e','g','i','s','t','e','r',' ','s','i','z','e', {64} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','P','A','G','E','S', {65} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','P','G', {66} chr(ord('I') + $80),'n','f','i','n','i','t','e',' ','r','e','c','u','r','s','i','o','n', {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', {68} chr(ord('U') + $80),'n','k','n','o','w','n',' ','d','i','r','e','c','t','i','v','e',' ', {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',' ', {70} chr(ord('P') + $80),'a','g','e',' ','e','r','r','o','r',' ','a','t',' ', {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', {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', {73} chr(ord('U') + $80),'n','d','e','f','i','n','e','d',' ','s','y','m','b','o','l',' ', {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', {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', {76} chr(ord('Z') + $80),'e','r','o',' ','p','a','g','e',' ','R','E','L','O','C',' ','b','l','o','c','k', {77} chr(ord(' ') + $80),'(','B','A','N','K','=', // od 77 kolejnosc wystapienia istotna {78} chr(ord(' ') + $80),'(','B','L','O','K','=', {79} chr(ord('L') + $80),'a','b','e','l',' ', {80} chr(ord(')') + $80),' ','E','R','R','O','R',':',' ', {81} chr(ord('0') + $80),'2',')', {82} chr(ord('8') + $80),'1','6',')', {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', {84} chr(ord('C') + $80),'a','n','''','t',' ','s','k','i','p',' ','o','v','e','r',' ','t','h','i','s', {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', {86} chr(ord('N') + $80),'o','t',' ','r','e','l','o','c','a','t','a','b','l','e', {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', {88} chr(ord('M') + $80),'i','s','s','i','n','g',' ','#','W','H','I','L','E', {89} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','W', {90} chr(ord('B') + $80),'L','K',' ','U','P','D','A','T','E',' ', {91} chr(ord('A') + $80),'D','D','R','E','S','S', {92} chr(ord('E') + $80),'X','T','E','R','N','A','L', {93} chr(ord('P') + $80),'U','B','L','I','C', {94} chr(ord('S') + $80),'Y','M','B','O','L', {95} chr(ord('M') + $80),'i','s','s','i','n','g',' ','#','I','F', {96} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','E','N','D','T', {97} chr(ord('M') + $80),'i','s','s','i','n','g',' ','.','M','A','C','R','O', {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', {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', {100} chr(ord('O') + $80),'n','l','y',' ','S','D','X',' ','R','E','L','O','C',' ','b','l','o','c','k', {101} chr(ord('L') + $80),'i','n','e',' ','t','o','o',' ','l','o','n','g', {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', {103} chr(ord('C') + $80),'a','n',' ','n','o','t',' ','d','e','c','l','a','r','e',' ','l','a','b','e','l',' ', {104} chr(ord(' ') + $80),'a','s',' ','p','u','b','l','i','c', {105} chr(ord('W') + $80),'r','i','t','i','n','g',' ','l','i','s','t','i','n','g',' ','f','i','l','e','.','.','.', {106} chr(ord('W') + $80),'r','i','t','i','n','g',' ','o','b','j','e','c','t',' ','f','i','l','e','.','.','.', {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', {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', {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',' ', {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', {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', {112} chr(ord('T') + $80),'h','e',' ','r','e','f','e','r','e','n','c','e','d',' ','l','a','b','e','l',' ', {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', {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', {115} chr(ord('U') + $80),'n','u','s','e','d',' ','l','a','b','e','l',' ', {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', {117} chr(ord('S') + $80), '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, '-','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, '-','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, '-','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, '-','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, '-','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, '-','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, '-','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, '-','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, '-','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, '-','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, '-','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, '-','s',#9,#9,'S','i','l','e','n','t',' ','m','o','d','e',#13,#10, '-','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, '-','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, '-','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, '-','u',#9,#9,'W','a','r','n',' ','o','f',' ','u','n','u','s','e','d',' ','l','a','b','e','l','s', chr($80), // version {118} chr(ord('m') + $80),'a','d','s',' ','1','.','9','.','0',chr($80),' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', chr($80)); const pass_max = 16; // maksymalna mozliwa liczba przebiegow asemblacji __equ = $80; // kody pseudo rozkazow __opt = $81; __org = $82; __ins = $83; __end = $84; __dta = $85; __icl = $86; __run = $87; // RUN __nmb = $88; __ini = $89; // INI-RUN = 2 !!! koniecznie !!! // __bot = $8a; // BOT aktualnie nie oprogramowany __rmb = $8b; __lmb = $8c; __ert = $8d; // __ift = $8e; // -> .IF // __els = $8f; // -> .ELSE // __eif = $90; // -> .ENDIF // __eli = $91; // -> .ELSEIF __smb = $92; __blk = $93; __ext = $94; __cpbcpd = $97; // kody makro rozkazow __cpbcpd..__jskip __adbsbb = $98; __phrplr = $99; __adwsbw = $9A; __BckSkp = $9B; __inwdew = $9C; __addsub = $9D; __movaxy = $9E; __jskip = $9F; // koniec kodów makro rozkazów __macro = $A0; // kody dyrektyw, kolejnosc wg tablicy 'MAC' + $A0 __if = $A1; __endif = $A2; __endm = $A3; __exit = $A4; __error = $A5; __else = $A6; __print = $A7; // = __echo __proc = $A8; __endp = $A9; __elseif = $AA; __local = $AB; __endl = $AC; __rept = $AD; __endr = $AE; __byte = $AF; // kody dla .BYTE, .WORD, .LONG, .DWORD // __word = $B0; // nastepuja po sobie, !!! koniecznie !!! // __long = $B1; __dword = $B2; __byteValue = __byte-1; // zastapi operacje (...-__byte+1) __struct = $B3; __ends = $B4; __ds = $B5; __symbol = $B6; __fl = $B7; __array = $B8; __enda = $B9; __get = $BA; __put = $BB; __sav = $BC; __pages = $BD; __endpg = $BE; __reloc = $BF; __dend = $C0; // zastepuje dyrektywy .ENDL, .ENDP, .ENDS, .ENDM itd. __link = $C1; __extrn = $C2; // odpowiednik pseudo rozkazu EXT __public = $C3; // odpowiednik dla .GLOBAL, .GLOBL __reg = $C4; // __REG, __VAR koniecznie w tej kolejnosci __var = $C5; __or = $C6; __by = $C7; __he = $C8; __wo = $C9; __en = $CA; __sb = $CB; __while = $CC; __endw = $CD; __test = $CE; __endt = $CF; __using = $D0; __ifndef = $D1; __nowarn = $D2; __def = $D3; __ifdef = $D4; __align = $D5; __zpvar = $D6; __enum = $D7; __ende = $D8; __over = __ende; // koniec kodow dyrektyw // __switch = $E0; // nie oprogramowane // __case = $E1; __telse = $E2; __nill = $F0; __addEqu = $F1; __xasm = $F2; __blkSpa = $F3; __blkRel = $F4; __blkEmp = $F5; __struct_run_noLabel = $F6; // ostatni wolny tutaj kod to $F7 __rel = $0000; // wartosc dla etykiet relokowalnych __relASM = $0100; // adres asemblacji dla bloku .RELOC __relHea = ord('M')+ord('R') shl 8; // naglowek 'MR' dla bloku .RELOC __id_param = $FFF7; // !!! zaczynamy koniecznie od __ID_PARAM !!! __id_array = $FFF8; __dta_struct = $FFF9; __id_ext = $FFFA; __id_smb = $FFFB; __id_macro = $FFFC; __id_enum = $FFFD; __id_struct = $FFFE; __id_proc = $FFFF; __array_run = byte(__id_array); __macro_run = byte(__id_macro); __enum_run = byte(__id_enum); __struct_run = byte(__id_struct); __proc_run = byte(__id_proc); __hea_dos = $FFFF; // naglowek dla bloku DOS __hea_reloc = $0000; // naglowek dla bloku .RELOC __hea_public = $FFED; // naglowek dla bloku aktualizacji symboli public __hea_external = $FFEE; // naglowek dla bloku aktualizacji symboli external __hea_address = $FFEF; // naglowek dla bloku aktualizacji adresow relokowalnych __pDef = 'D'; // Default __pReg = 'R'; // Registry __pVar = 'V'; // Variable __test_label = '##TB'; // etykieta dla poczatku bloku #IF __telse_label = '@?@?@ML?ET'; // etykieta dla poczatku bloku #ELSE __endt_label = '@?@?@ML?TE'; // etykieta dla konca bloku #IF (#END) __while_label = '##B'; // etykieta dla poczatku bloku #WHILE __endw_label = '@?@?@ML?E'; // etykieta dla konca bloku #WHILE (#END) mads_stack: array [0..2] of string[14] = ('@STACK_POINTER', '@STACK_ADDRESS', '@PROC_VARS_ADR'); tType: array [1..4] of char = ('B','A','T','F'); // typy uzywane wewnetrznie przez MADS relType: array [1..7] of char = ('B','W','L','D','<','>','^'); // typy zapisywane w relokowalnych plikach mads_param: array [1..4] of string [7] = ('.BYTE ', '.WORD ', '.LONG ', '.DWORD '); PathDelim: char = '/'; function _pth(const a: char): Boolean; (*----------------------------------------------------------------------------*) (* test dla roznych znakow PathDelim *) (*----------------------------------------------------------------------------*) begin _pth := (a in ['/','\']) end; {procedure czytaj_komentarz(var i: integer; var a, txt: string); (*----------------------------------------------------------------------------*) (* czytamy komentarz ograniczony znakami /* */ *) (*----------------------------------------------------------------------------*) begin txt:=txt+'/*'; inc(i,2); komentarz:=true; while komentarz and (i<=length(a)) do begin txt:=txt+a[i]; if a[i]='*' then if a[i+1]='/' then begin txt:=txt+'/'; inc(i); komentarz:=false end; inc(i); end; end; } procedure omin_spacje (var i:integer; var a:string); (*----------------------------------------------------------------------------*) (* omijamy tzw. "biale spacje" czyli spacje, tabulatory, komentarze /* */ *) (*----------------------------------------------------------------------------*) var txt: string; begin if a<>'' then begin while a[i] in [' ',#9] do inc(i); if (a[i]='/') and (a[i+1]='*') then begin txt:=''; ___search_comment_block(i,a, txt); if not(komentarz) then omin_spacje(i,a); end; end; end; procedure __inc(var i:integer; var a:string); begin if i>length(a) then exit; inc(i); omin_spacje(i,a); end; function UpCas_(const a: char): char; begin if not(case_used) then Result:=UpCase(a) else Result:=a; end; function ata2int(const a: byte): byte; (*----------------------------------------------------------------------------*) (* zamiana znakow ATASCII na INTERNAL *) (*----------------------------------------------------------------------------*) begin Result:=a; case (a and $7f) of 0..31: inc(Result,64); 32..95: dec(Result,32); end; end; function IntToStr(const a: Int64): string; var tmp: _typStrINT; begin str(a, tmp); Result := tmp; end; function StrToInt(var a: string): Int64; var i: integer; begin val(a,Result, i); end; procedure flush_dst; (*----------------------------------------------------------------------------*) (* oproznienie bufora zapisu *) (*----------------------------------------------------------------------------*) begin if buf_i>0 then blockwrite(dst,t_buf,buf_i); buf_i:=0; end; procedure put_dst(const a: byte); (*----------------------------------------------------------------------------*) (* zapisz do bufora zapisu *) (*----------------------------------------------------------------------------*) var v: byte; begin if fill>0 then begin flush_dst; v:=$ff; while fill>0 do begin blockwrite(dst,v,1); dec(fill); end; end; t_buf[buf_i]:=a; inc(buf_i); if buf_i>=sizeof(t_buf) then flush_dst; end; function Hex(a:cardinal; b:shortint): string; (*----------------------------------------------------------------------------*) (* zamiana na zapis hexadecymalny *) (* 'B' okresla maksymalna liczbe nibbli do zamiany *) (* jesli sa jeszcze jakies wartosci to kontynuuje zamiane *) (*----------------------------------------------------------------------------*) var v: byte; const tHex: array [0..15] of char = ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); begin Result:=''; while (b>0) or (a<>0) do begin v := byte(a); Result:=tHex[v shr 4] + tHex[v and $0f] + Result; a:=a shr 8; dec(b,2); end; end; function load_mes(const b: integer): string; (*----------------------------------------------------------------------------*) (* tworzymy STRING z komunikatem nr w 'B' *) (*----------------------------------------------------------------------------*) var i: integer; begin i:=imes[b]-imes[b-1]; SetLength(Result, i); move(mes[imes[b-1]], Result[1], i); end; function GetFilePath(var a: string): string; (*----------------------------------------------------------------------------*) (* z pelnej nazwy pliku wycinamy sciezke (ExtractFilePath) *) (*----------------------------------------------------------------------------*) var i: integer; begin Result:=''; if a<>'' then begin i:=length(a); while not(_pth(a[i])) and (i>=1) do dec(i); Result:=a; SetLength(Result,i); end; end; function GetFileName(var a: string): string; (*----------------------------------------------------------------------------*) (* z pelnej nazwy pliku wycinamy nazwe pliku (ExtractFileName) *) (*----------------------------------------------------------------------------*) var i: integer; begin Result:=''; if a<>'' then begin i:=length(a); while not(_pth(a[i])) and (i>=1) do dec(i); Result:=copy(a,i+1,length(a)); end; end; function show_full_name(var a:string; const b,c:Boolean): string; var pth: string; begin pth:=GetFilePath(a); Result:=a; if b then begin if pth='' then Result:=path+Result; end else Result:=GetFileName(Result); if c then Result:='Source: '+Result; end; procedure warning(const a: byte); (*----------------------------------------------------------------------------*) (* wyswietla ostrzezenie, nie przerywa asemblacji *) (*----------------------------------------------------------------------------*) var txt: string; begin if not(noWarning) then begin txt:=load_mes(a+1); case a of 8: txt:=txt+'?'; 109: txt:=txt+'$'+HEX(zpvar,4); 69,115: txt:=txt+str_blad; 70: txt:=txt+'$'+HEX(adres,4); end; warning_mes:=show_full_name(global_name,full_name,false)+' ('+IntToStr(line)+') WARNING: '+txt; if warning_mes<>warning_old then begin writeln(warning_mes); warning_old:=warning_mes; end; end; end; procedure madH_save(var b:integer; var s:string); (*----------------------------------------------------------------------------*) (* zapisujemy plik naglowkowy MADS'a *) (*----------------------------------------------------------------------------*) var okej: Boolean; tst: char; i: integer; begin tst:=s[1]; okej:=false; for i:=High(t_mad)-1 downto 0 do if t_mad[i].bnk=b then if t_mad[i].typ=tst then begin okej:=true; Break end; if okej then begin writeln(mmm,#13#10,'; ',s); for i:=High(t_mad)-1 downto 0 do if t_mad[i].bnk=b then if t_mad[i].typ=tst then writeln(mmm,t_mad[i].nam,#9,'=',#9,'$',Hex(t_mad[i].adr,4)); end; end; procedure new_message(var a: string); var i: integer; begin if a='' then exit; i:=High(messages); messages[i].pas:=pass; messages[i].mes:=a; SetLength(messages,i+2); a:=''; end; procedure koniec(const err: byte); (*----------------------------------------------------------------------------*) (* ERR = 0 bez bledow *) (* ERR = 1 tylko komunikaty WARNING *) (* ERR = 2 blad i zatrzymanie asemblacji *) (* ERR = 3 bledne parametry dla MADS'a *) (*----------------------------------------------------------------------------*) var a, b: integer; ok: Boolean; txt: string; f: textfile; begin if open_ok then begin Flush(lst); CloseFile(lst); Flush_dst; a:=integer( FileSize(dst) ); CloseFile(dst); AssignFile(f, plik_lst); FileMode:=0; Reset(f); // sprawdzamy liczbe wierszy w 'PLIK_LST' b:=0; while not(eof(f)) do begin ReadLn(f, t); inc(b); if b>2 then Break; end; CloseFile(f); if list_lab then CloseFile(lab); if (b<3) or (err>1) then begin Erase(lst); // usuwamy plik LST if list_lab then Erase(lab); end else if (opt and 4>0) then begin txt:=load_mes(105+1); if not(silent) then new_message(txt); end; if (a=0) or (err>1) then Erase(dst) // usuwamy plik OBX (plik DST wczesniej musi zostac zamkniety) else begin txt:=load_mes(106+ord(raw.use)+1); if not(silent) then new_message(txt); end; if over then if end_string<>'' then write(end_string); if over and not(silent) then begin if err<>2 then begin txt:=IntToStr(line_all)+load_mes(48+1)+' in '+IntToStr(pass_end)+' pass'; new_message(txt); if a>0 then begin txt:=IntToStr(a)+load_mes(49+1); new_message(txt); end; end; end; end; if list_mmm then begin b:=0; while b<256 do begin ok:=false; for a:=High(t_mad)-1 downto 0 do if t_mad[a].bnk=b then begin ok:=true; Break end; if ok then begin if b>0 then writeln(mmm,#13#10,' lmb #',b,#9#9,'; BANK #',b); txt:='CONSTANS'; madH_save(b,txt); // constans txt:='VARIABLES'; madH_save(b,txt); // variables txt:='PROCEDURES'; madH_save(b,txt); // procedures end; inc(b); end; CloseFile(mmm); end; if list_hhh then begin writeln(hhh,#13#10+'#endif'); CloseFile(hhh); end; for a:=0 to High(messages)-1 do if messages[a].pas < 16 then begin if a<>High(messages)-1 then writeln(messages[a].mes) else write(messages[a].mes); for b:=High(messages)-1 downto 0 do // usuwamy powtarzajace sie komunikaty // if messages[b].pas=messages[a].pas then if messages[b].mes=messages[a].mes then messages[b].pas:=$ff; end; if not(silent) then writeln; Halt(err); end; function TestFile(var a: string): Boolean; (*----------------------------------------------------------------------------*) (* sprawdzamy istnienie pliku na dysku bez udzialu 'SysUtils', *) (* jest to odpowiednik funkcji 'FileExists' *) (*----------------------------------------------------------------------------*) var f: textfile; // !!! koniecznie plik tekstowy !!! begin AssignFile(f, a); // {$I-} FileMode:=0; Reset(f); // {$I+} if IOResult = 0 then begin Result:=true; CloseFile(f); end else Result:=false; end; procedure just_t(const a:cardinal); var len: integer; begin len:=length(t); if not(len>31) then if len+3>29 then begin t:=t+' +'; while length(t)<32 do t:=t+' '; end else t:=t+' '+Hex(a,2); end; procedure bank_adres(a: integer); begin if (dreloc.use) and (a-rel_ofs>=0) then dec(a, rel_ofs); if bank>0 then t:=t+Hex(bank,2)+','; {if a>=0 then} t:=t+Hex(a,4); // inaczej nie wyswietli wartosci 64bit end; procedure save_dst(const a: byte); var x, y, ex, ey: integer; znk: char; begin if (pass=pass_end) and (opt and 2>0) then begin if org then begin SetLength(t,7); if hea and (opt and 1>0) and not(dreloc.sdx) then t:=t+'FFFF> '; x:=adres; y:=t_hea[hea_i]; if dreloc.use then begin dec(x,rel_ofs); dec(y,rel_ofs); end; if hea_ofs.adr>=0 then begin y:=hea_ofs.adr+(y-x); x:=hea_ofs.adr; end; if x<=y then begin ex:=x; ey:=y end else begin ey:=x; ex:=y end; if blok>0 then begin // dlugosc bloku relokowalnego y:=y-x+1; znk:=','; end else znk:='-'; if adres>=0 then begin if ex>ey then bank_adres(t_hea[hea_i-1]+1) else bank_adres(x); if (ex<=ey) and (opt and 1>0) then t:=t+znk+Hex(y,4)+'>'; end; if hea and (opt and 1>0) and not(dreloc.sdx) then begin put_dst($FF); put_dst($FF); end; if (opt and 1>0) then begin put_dst( byte(x) ); put_dst( byte(x shr 8) ); put_dst( byte(y) ); put_dst( byte(y shr 8) ); end; org:=false; hea:=false; end; just_t(a); if not(blokuj_zapis) then put_dst(a); end else begin fill:=0; // istotne dla zapisu pliku RAW if org and raw.use then begin hea:=false; // istotne dla zapisu pliku RAW org:=false; // istotne dla zapisu pliku RAW end; end; end; procedure save_dstW(const a: integer); begin save_dst( byte(a) ); // lo save_dst( byte(a shr 8) ); // hi end; procedure save_dstS(var a: string); var i, len: integer; begin len:=length(a); save_dstW( len ); for i:=1 to len do save_dst( ord(a[i]) ); end; procedure blad(var a: string; const b: integer); (*----------------------------------------------------------------------------*) (* wyswietla komunikat bledu nr w 'B' *) (* wyjatek stanowi b<0 wtedy wyswietli komunikat 'Branch...' *) (* dla komunikatu nr 14 wyswietli nazwe wybranego trybu pracy CPU 8-16bit *) (*----------------------------------------------------------------------------*) var add, prv, con: string; begin if b=0 then begin overflow := true; if pass<>pass_end then exit; end; add:=''; prv:=''; con:=''; line_err := line; if run_macro then begin con := t_wyw[1].zm; new_message(con); global_name:=t_wyw[wyw_idx].pl; inc(line_err,t_wyw[wyw_idx].nr); end else if not(rept_run) and not(FOX_ripit) and not(loop_used) and not(code6502) then if line_add>0 then inc(line_err,line_add); { if str_blad<>'' then while (length(str_blad)>0) and (str_blad[1]='#') do str_blad:=copy(str_blad,2,length(str_blad)); } // usuwamy znaki #0 bo to pewnie jakies krzaki-dziwaki while (length(a)>0) and (pos(#0,a)>0) do SetLength(a,pos(#0,a)-1); if (a<>'') and not(b in [18,34]) then begin con := a; new_message(con) end; con := con+show_full_name(global_name,full_name,false)+' ('+IntToStr(Int64(line_err)+ord(line_err=0))+load_mes(81); if b=18 then add:=' '''+a+''''; if b=2 then prv:=load_mes(80); if b=113 then prv:=load_mes(112+1); if b in [2,113] then prv:=prv+str_blad; if b in [5,8,9,35,41,46,61,68,73,103] then add:=add+str_blad; if b in [2,5,35] then add:=add+load_mes(77+1+ord(dreloc.use))+IntToStr(bank)+')'; // BLOK / BANK if b=103 then add:=add+load_mes(104+1); // ... as public if b=14 then add:=load_mes( 82+ord( opt and 16>0 ) ); // if opt and 16>0 then add:='816)' else add:='02)'; if b=17 then if proc then add:='P' else if macro then add:='M'; if b<0 then con := con+load_mes(22)+Hex(abs(b),4)+load_mes(23) else if b<>34 then con := con+prv+load_mes(b+1)+add else con := con+a+add; status := 2; new_message(con); // pewne bledy wymagaja natychmiastowego zakonczenia asemblacji // jesli wystapi za duzo bledow (>512) to też konczymy asemblacje 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; end; procedure justuj; var j: integer; begin if (pass=pass_end) and (t<>'') and not(FOX_ripit) then begin j:=length(t); while j<32 do begin t:=t+#9; inc(j,8); end; end; end; procedure blad_und(var old: string; const b: string; const x: byte); (*----------------------------------------------------------------------------*) (* wyswietla komunikat 'Undeclared label ????' *) (* wyswietla komunikat 'Label ???? declared twice' *) (* wyswietla komunikat 'Undeclared macro ????' *) (*----------------------------------------------------------------------------*) begin str_blad:=b; if x=69 then warning(x) else blad(old,x); end; procedure WriteAccessFile(var a: string); (*----------------------------------------------------------------------------*) (* sprawdzamy mozliwosc zapisu do pliku o podanej nazwie *) (*----------------------------------------------------------------------------*) var f: textfile; // !!! koniecznie plik tekstowy !!! begin AssignFile(f,a); // {$I-} FileMode:=1; Rewrite(f); // {$I+} if IOResult = 0 then CloseFile(f) else blad(a,18); end; function GetFile(a: string; var zm: string): string; (*----------------------------------------------------------------------------*) (* szukamy pliku w zadeklarowanych sciezkach poszukiwan *) (*----------------------------------------------------------------------------*) var c, p: string; i: integer; begin if a='' then blad(zm,3); p:=path+a; if TestFile(p) then a:=path+a; Result:=a; if TestFile(a) then exit; for i:=0 to High(t_pth)-1 do begin // !!! kolejnosc przegladania T_PTH[0..] ma znaczenie !!! p:=t_pth[i]; if p<>'' then if not(_pth(p[length(p)])) then p:=p+PathDelim; c:=p+a; if TestFile(c) then begin Result:=c; Break end; end; end; procedure blad_ill(var a:string; const c:char); (*----------------------------------------------------------------------------*) (* wyswietla komunikat 'Illegal character ??' *) (*----------------------------------------------------------------------------*) begin str_blad:=c; blad(a,8); end; function fASC(var a: string): byte; (*----------------------------------------------------------------------------*) (* !!! koniecznie obliczamy kod dla 3 pierwszych znakow !!! *) (* obliczamy sume kontrolna dla 3 literowego ciagu znakowego 'A'..'Z' *) (* obliczona suma kontrolna jest indeksem do tablicy HASH *) (*----------------------------------------------------------------------------*) var i: cardinal; j: integer; begin Result:=0; if length(a)>=3 then begin // !!! koniecznie LENGTH(A)>=3 !!! aby obliczal LDA.W itp. for j:=1 to 3 do if not(a[j] in ['A'..'Z']) then exit; i:= ord(a[1])-ord('@') + (ord(a[2])-ord('@')) shl 5 + (ord(a[3])-ord('@')) shl 10; Result:=hash[i]; end; end; function fCRC16(var a: string): byte; (*----------------------------------------------------------------------------*) (* obliczamy sume kontrolna CRC 16-bit dla krotkiego ciagu znakowego <3..6> *) (* obliczona 16-bitowa suma kontrolna jest indeksem do tablicy HASH *) (*----------------------------------------------------------------------------*) var x, i: integer; begin x:=$ffff; i:=1; while i<=length(a) do begin // WHILE jest krótsze od FOR x:=tCRC16[byte(x shr 8) xor byte(a[i])] xor (x shl 8); inc(i); end; Result:=hash[x and $ffff]; end; function l_lab(var a: string): integer; (*----------------------------------------------------------------------------*) (* szukamy etykiety i zwracamy jej indeks do tablicy 'T_LAB' *) (* jesli nie ma takiej etykiety zwracamy wartosc -1 *) (*----------------------------------------------------------------------------*) var x: cardinal; i, len: integer; begin Result:=-1; len:=length(a); x:=$ffffffff; i:=1; while i<=len do begin // WHILE jest krótsze od FOR x:=tCRC32[byte(x) xor byte(a[i])] xor (x shr 8); inc(i); end; // OK jesli znaleziona etykieta ma kod >=__id_param, lub aktualna wartosc BANK=0 // OK jesli znaleziona etykieta jest z aktualnego banku lub banku zerowego (BNK=BANK | BNK=0) for i:=High(t_lab)-1 downto 0 do if (t_lab[i].len=len) and (t_lab[i].nam=x) then if (bank=0) or (t_lab[i].bnk>=__id_param) then begin Result:=i; Break end else if t_lab[i].bnk in [bank,0] then begin Result:=i; Break end; end; procedure obetnij_kropke(var b: string); (*----------------------------------------------------------------------------*) (* usuwamy z ciagu ostatni ciag znakow po kropce, ciag konczy znak kropki *) (*----------------------------------------------------------------------------*) var i: integer; begin i:=length(b); if (b<>'') and (i>1) then begin dec(i); while (b[i]<>'.') and (i>=1) do dec(i); SetLength(b,i); end; end; function search(var a,x: string): integer; (*----------------------------------------------------------------------------*) (* szukamy nazwy etykiety w tablicy T_LAB, jesli w nazwie wystepuje kropka *) (* obcinamy nazwe i szukamy dalej *) (*----------------------------------------------------------------------------*) var b, t: string; begin b:=x+lokal_name; t:=b+a; Result:=l_lab(t); while (Result<0) and (pos('.',b)>0) do begin obetnij_kropke(b); t:=b+a; Result:=l_lab(t); end; end; function load_lab(var a:string; const test:Boolean): integer; (*----------------------------------------------------------------------------*) (* szukamy etykiety i zwracamy jej indeks do tablicy 'T_LAB' *) (* jesli nie ma takiej etykiety zwracamy wartosc -1 *) (* *) (* jesli jest uruchomione makro i nie znajdziemy etykiety to szukamy w proc *) (* jesli nie znajdziemy w proc to wtedy szukamy w glownym programie *) (*----------------------------------------------------------------------------*) var txt: string; i: integer; begin if test then begin if run_macro then begin Result:=search(a,macro_nr); if Result>=0 then exit; end; if proc then begin Result:=search(a,proc_name); if Result>=0 then exit; end; txt:=''; Result:=search(a,txt); if Result>=0 then exit; end; txt:=lokal_name+a; Result:=l_lab(txt); if Result<0 then Result:=search(a,proc_name); if Result<0 then // test dla .USE [.USING] if usi_idx>0 then for i:=0 to usi_idx-1 do {begin} 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 txt:=t_usi[i].lab+'.'+a; Result:=l_lab(txt); if Result>=0 then exit else begin txt:=lokal_name+txt; Result:=l_lab(txt); if Result>=0 then exit; end; end; end; procedure zapisz_etykiete(var a:string; const ad:cardinal; const ba:integer; const symbol:char); (*----------------------------------------------------------------------------*) (* zapisujemy nazwe etykiety, jej adres itp w pliku .LAB *) (* dodatkowo jesli jest to wymagane w pliku naglowkowym .C dla cc65 *) (* nie zapisujemy etykiet tymczasowych, lokalnych w makrach *) (*----------------------------------------------------------------------------*) var i: integer; begin if pass=pass_end then if not(struct.use) and not(not(mae_labels) and (symbol='?')) and not(pos('::',a)>0) then begin if list_lab then writeln(lab,Hex(ba,2),#9,Hex(ad,4),#9,a); if not(proc) and (ba<256) then begin if list_hhh and (ba=0) then writeln(hhh,'#define ',name,'_',a,' 0x',Hex(ad,4)); if list_mmm then begin i:=High(t_mad); // SAVE_MAD // t_mad[i].nam:=a; // t_mad[i].adr:=ad; // t_mad[i].bnk:=byte(ba); // t_mad[i].typ:=label_type; // // SetLength(t_mad,i+2); // end; end; end; end; function loa_str(var a:string; var id:integer): integer; (*----------------------------------------------------------------------------*) (* sprawdz czy wystepuje deklaracja pola struktury w T_STR *) (*----------------------------------------------------------------------------*) var i: integer; begin Result:=-1; for i:=High(t_str)-1 downto 0 do // !!! koniecznie przegladamy od tylu !!! if t_str[i].id=id then if t_str[i].lab=a then begin Result:=i; Break end; // dzieki temu ze przegladamy od tylu nigdy nie trafimy na nazwe struktury, // nazwa struktury ma numer NO ten sam co pierwsze pole struktury end; function loa_str_no(var id:integer; const x:integer): integer; (*----------------------------------------------------------------------------*) (* odczytaj indeks do pola struktury o konkretnym numerze X *) (*----------------------------------------------------------------------------*) var i: integer; begin Result:=-1; for i:=High(t_str)-1 downto 0 do // !!! koniecznie przegladamy od tylu !!! if t_str[i].id=id then if t_str[i].no=x then begin Result:=i; Break end; end; procedure save_str(var a:string; const ofs,siz,rpt:integer; const ad:cardinal; const bn:integer); (*----------------------------------------------------------------------------*) (* zapisz informacje na temat pol struktury, jesli wczesniej nie wystapily *) (*----------------------------------------------------------------------------*) var i: integer; begin i:=loa_str(a, struct.id); if i<0 then begin i:=High(t_str); SetLength(t_str,i+2); end; t_str[i].id:=struct.id; t_str[i].no:=struct.cnt; t_str[i].adr := ad; t_str[i].bnk := bn; t_str[i].lab := a; t_str[i].ofs := ofs; t_str[i].siz := siz; if rpt=0 then t_str[i].rpt := 1 else t_str[i].rpt := rpt; end; procedure s_lab(var a:string; const ad:cardinal; var ba:integer; var old:string; const symbol:char); (*----------------------------------------------------------------------------*) (* wlasciwa procedura realizujaca zapamietanie etykiety w tablicy 'T_LAB' *) (*----------------------------------------------------------------------------*) var tmp: cardinal; x, len, i: integer; begin // sprawdz czy nie ma juz takiej etykiety // bo jesli jest to nie dopisuj nowej pozycji tylko popraw stara x:=l_lab(a); if x<0 then begin x:=High(t_lab); SetLength(t_lab,x+2); end else if symbol<>'?' then if (t_lab[x].bnk<>ba) and not(struct_used.use) and not(enum.use) then blad_und(old,a,2); len:=length(a); tmp:=$ffffffff; // crc32 i:=1; while i<=len do begin // WHILE jest krótsze od FOR tmp:=tCRC32[byte(tmp) xor byte(a[i])] xor (tmp shr 8); inc(i); end; if pass>0 then if (symbol<>'?') or mae_labels then // jesli to styl etykiet MAE to musimy je sprawdzic if t_lab[x].nam=tmp then // normalnie sprawdzamy tylko etykiety z pierwszym znakiem <>'?' if (t_lab[x].bnk<__id_param) and not(t_lab[x].lid) then begin if t_lab[x].pas=pass then blad_und(old,a,2); // nie mozna sprawdzac dwa razy tej samej etykiety w aktualnym przebiegu if not(next_pass) then // sprawdz czy potrzebny jest dodatkowy przebieg if mne_used then // jakis mnemonik musial zostac wczesniej wykonany next_pass := (t_lab[x].adr <> ad); end; 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 str_blad:=a; warning(115); end; if t_lab[x].lid and not(new_local) then blad_und(old,a,2); t_lab[x].lid := new_local; t_lab[x].typ := label_type; t_lab[x].len := len; t_lab[x].nam := tmp; if new_local then begin if t_lab[x].pas<>pass then t_lab[x].adr := ad; // tylko pierwszy adres dla .LOCAL end else t_lab[x].adr := ad; t_lab[x].bnk := ba; t_lab[x].blk := blok; t_lab[x].pas := pass; t_lab[x].ofs := org_ofset; if (blok>0) or dreloc.use then t_lab[x].rel := true; zapisz_etykiete(a,ad,ba,symbol); end; procedure save_lab(var a:string; const ad:cardinal; ba:integer; var old:string); (*----------------------------------------------------------------------------*) (* zapamietujemy etykiete, adres, bank *) (*----------------------------------------------------------------------------*) var tmp: string; begin if a<>'' then begin // !!! konieczny test if mae_labels and (a[1]<>'?') then begin tmp:=a; lokal_name:=a+'.'; end else if run_macro then tmp:=macro_nr+lokal_name+a else // !!! nie remowac LOKAL_NAME !!! if proc then tmp:=proc_name+lokal_name+a else tmp:=lokal_name+a; s_lab( tmp, ad, ba, old, a[1] ); end; end; procedure save_arr(const a:cardinal; var b:integer); begin t_arr[array_idx].adr:=a; t_arr[array_idx].bnk:=b; t_arr[array_idx].ofs:=org_ofset; inc(array_idx); if array_idx>High(t_arr) then SetLength(t_arr, array_idx+1); end; procedure save_hea; begin t_hea[hea_i]:=adres-1 - fill; fill:=0; inc(hea_i); if hea_i>High(t_hea) then SetLength(t_hea,hea_i+1); end; procedure save_par(var a: string); var i: integer; begin i:=High(t_par); t_par[i]:=a; SetLength(t_par,i+2); end; procedure save_mac(var a: string); var i: integer; begin i:=High(t_mac); t_mac[i]:=a; SetLength(t_mac,i+2); end; procedure save_end(const a: byte); begin t_end[end_idx].kod := a; t_end[end_idx].adr := adres; t_end[end_idx].sem := false; // semicolon { inc(end_idx); if end_idx>High(t_end) then SetLength(t_end, end_idx+1); end; procedure dec_end(var zm: string; const a: byte); begin dec(end_idx); if t_end[end_idx].kod <> a then case a of __endpg: blad(zm,64); // Missing .PAGES __ends: blad(zm,55); // Missing .STRUCT __endm: blad(zm,97); // Missing .MACRO __endw: blad(zm,88); // Missing .WHILE __endt: blad(zm,95); // Missing .TEST __enda: blad(zm,59); // Missing .ARRAY __endr: blad(zm,51); // Missing .REPT end; end; procedure save_pub(var a,zm: string); (*----------------------------------------------------------------------------*) (* zapisujemy symbol .PUBLIC *) (* jesli ADD = FALSE to w przypadku powtorzenia symbolu wystapi blad *) (*----------------------------------------------------------------------------*) var i: integer; begin for i:=pub_idx-1 downto 0 do // symbole public nie moga sie powtarzac if t_pub[i].nam=a then blad_und(zm,a,2); t_pub[pub_idx].nam := a; inc(pub_idx); if pub_idx>High(t_pub) then SetLength(t_pub,pub_idx+1); end; procedure save_rel(var a:integer; const idx, b:integer; var reloc_value:relVal); begin if dreloc.use or dreloc.sdx then begin if vector then t_rel[rel_idx].adr:=a-rel_ofs else t_rel[rel_idx].adr:=a-rel_ofs+1; t_rel[rel_idx].blk:=b; if not(empty) then t_rel[rel_idx].idx:=idx else t_rel[rel_idx].idx:=-100; t_rel[rel_idx].blo:=blok; if dreloc.use then begin t_rel[rel_idx].idx:=siz_idx; t_rel[rel_idx].bnk:=bank; inc(siz_idx); rel_used:=true; // pozwalamy na zapis rozmiaru do T_SIZ if siz_idx>High(t_siz) then SetLength(t_siz,siz_idx+1); end; inc(rel_idx); if rel_idx>High(t_rel) then SetLength(t_rel,rel_idx+1); reloc:=true; reloc_value.use:=true; inc(reloc_value.cnt); end; end; procedure save_relAddress(const arg:integer; var reloc_value: relVal); begin if not(branch) then if t_lab[arg].rel then begin save_rel(adres, -1, t_lab[arg].blk, reloc_value); end; end; function wartosc(var a:string; var v:Int64; const o:char): cardinal; (*----------------------------------------------------------------------------*) (* sprawdzamy zakres wartosci zmiennej 'V' na podstawie kodu w 'O' *) (*----------------------------------------------------------------------------*) var x: Boolean; i: int64; begin Result:=cardinal( v ); i:=abs(v); // koniecznie ABS inaczej nie zadziala prawidlowo case o of 'B' : x := i > $FF; 'A','V' : x := i > $FFFF; 'E','T' : x := i > $FFFFFF; // 'F','G','L','H' : x := i > $FFFFFFFF; // !!! nie realne !!! zaremowac aby dzialalo odejmowanie else x:=false; end; if x then blad(a,0); end; function _ope(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* dopuszczalne operandy *) (*----------------------------------------------------------------------------*) begin Result := (a in ['=','<','>','!']) end; function _eol(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* test konca linii *) (*----------------------------------------------------------------------------*) begin Result := (a in [#0,#9,' ']) end; function _dec(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* dopuszczalne znaki dla liczb decymalnych *) (*----------------------------------------------------------------------------*) begin Result := (a in ['0'..'9']) end; function _lab(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* dopuszczalne znaki dla etykiet *) (*----------------------------------------------------------------------------*) begin Result := (UpCase(a) in ['A'..'Z','0'..'9','_','?','@','.']) end; function _bin(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* dopuszczalne znaki dla liczb binarnych *) (*----------------------------------------------------------------------------*) begin Result := (a in ['0'..'1']) end; function _hex(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* dopuszczalne znaki dla liczb heksadecymalnych *) (*----------------------------------------------------------------------------*) begin Result := (UpCase(a) in ['0'..'9','A'..'F']) end; function _first_char(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* pierwsze dopuszczalne znaki dla linii *) (*----------------------------------------------------------------------------*) begin Result := (UpCase(a) in ['A'..'Z','_','?','@','.','+','-','=','*',':']) end; function _dir_first(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* pierwsze dopuszczalne znaki dla dyrektyw *) (*----------------------------------------------------------------------------*) begin Result := (a in ['.','#']) end; function _lab_first(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* pierwsze dopuszczalne znaki dla etykiet *) (*----------------------------------------------------------------------------*) begin Result := (UpCase(a) in ['A'..'Z','_','?','@']) end; function _lab_firstEx(var a: char): Boolean; (*----------------------------------------------------------------------------*) (* pierwsze dopuszczalne znaki dla etykiet w wyrazeniach *) (*----------------------------------------------------------------------------*) begin Result := (UpCase(a) in ['A'..'Z','_','?','@',':']) end; function test_char(i:integer; var a:string; const sep,sep2:Char): Boolean; (*----------------------------------------------------------------------------*) (* test konca linii, linie moga konczyc znaki #0, #9, ' ', ';', '//','/*','\' *) (*----------------------------------------------------------------------------*) var txt: string; begin if a='' then begin Result:=false; exit end; if (a[i]='/') and (a[i+1]='*') then begin // !!! omin_spacje !!! tutaj niemozliwe txt:=''; ___search_comment_block(i,a, txt); { inc(i,2); while i<=length(a) do begin if a[i]='*' then if a[i+1]='/' then begin inc(i); if i=length(a) then begin Result:=true; exit end else begin __inc(i,a); Break end; end; __inc(i,a); end;} end; Result := (a[i] in [#0,#9,'\',';',sep,sep2]) or ((a[i]='/') and (a[i+1] in ['/'{,'*'}])); end; procedure test_eol(const i:integer; var a,old:string; const b:char); (*----------------------------------------------------------------------------*) (* sprawdzamy czy nie ma niepoprawnych znakow na koncu linii *) (* linia moze konczyc sie znakami #0,#9,';',' ','//' lub przecinkiem ',' *) (*----------------------------------------------------------------------------*) begin if not(a[i] in [#0,#9,'\',';',' ',b]) and not((a[i]='/') and (a[i+1] in ['/','*'])) then blad(old,4) end; function get_directive(var i:integer; var a:string): string; (*----------------------------------------------------------------------------*) (* pobierz dyrektywe zaczynajaca sie znakami '.', '#' *) (*----------------------------------------------------------------------------*) begin Result:=''; if _dir_first(a[i]) then begin Result:=a[i]; inc(i); while _lab(a[i]) do begin Result:=Result+UpCase(a[i]); inc(i) end; end; end; function get_lab(var i:integer; var a:string; const tst:Boolean): string; (*----------------------------------------------------------------------------*) (* pobierz etykiete zaczynajaca sie znakami 'A'..'Z','_','?','@' *) (* jesli TST = TRUE to etykieta musi zawierac jakies znaki *) (*----------------------------------------------------------------------------*) begin Result:=''; if a<>'' then begin if tst then omin_spacje(i,a); if _lab_first(a[i]) then while _lab(a[i]) do begin Result:=Result+UpCas_(a[i]); inc(i) end; end; if tst then if Result='' then blad(a,15); end; function get_string(var i:integer; var a,old:string; const test:Boolean): string; (*----------------------------------------------------------------------------*) (* pobiera ciag znakow, ograniczony znakami '' lub "" *) (* podwojny '' oznacza literalne ' *) (* podwojny "" oznacza literalne " *) (* TEST = TRUE sprawdza czy ciag jest pusty *) (*----------------------------------------------------------------------------*) var len: integer; znak, gchr: char; begin Result:=''; omin_spacje(i,a); if not(a[i] in ['''','"']) then exit; gchr:=a[i]; len:=length(a); while i<=len do begin inc(i); // omijamy pierwszy znak ' lub " znak:=a[i]; if znak=gchr then begin inc(i); if a[i]=gchr then znak:=gchr else begin if test then if Result='' then blad(old,3); exit; end; end; Result:=Result+znak; end; if not(komentarz) then blad(a,3); // nie napotkal znaku konczacego ciag ' lub " end; function get_datUp(var i:integer; var a:string; const sep:Char; const tst:Boolean): string; (*----------------------------------------------------------------------------*) (* pobieramy ciag znakow (dyrektywy), zmieniamy wielkosc liter na duze *) (* jeli TST = TRUE to ciag musi byc niepusty *) (*----------------------------------------------------------------------------*) begin Result:=''; omin_spacje(i,a); if a<>'' then while (a[i]<>'=') and not(test_char(i,a,' ',sep)) do begin Result := Result + UpCase(a[i]); inc(i); end; if tst then if Result='' then blad(a,23); end; function get_type(var i:integer; var zm,old: string; const tst:Boolean): byte; (*----------------------------------------------------------------------------*) (* sprawdzamy czy odczytany ciag znakow oznacza dyrektywe typu danych *) (* akceptowane dyrektywy typu to .BYTE, .WORD, .LONG, .DWORD *) (*----------------------------------------------------------------------------*) var txt: string; begin omin_spacje(i,zm); // txt:=get_datUp(i,zm,#0,false); txt:=get_directive(i,zm); if (txt='') and not(tst) then begin Result:=0; exit end; // wyjatek dla .RELOC [.BYTE] [.WORD] Result := fCRC16(txt); if not(Result in [__byte..__dword]) then blad_und(old,txt,46); dec(Result, __byteValue); end; function get_typeExt(var i:integer; var zm:string): byte; (*----------------------------------------------------------------------------*) (* sprawdzamy czy odczytany ciag znakow oznacza dyrektywe typu danych dla EXT *) (* akceptowane dyrektywy typu to .BYTE, .WORD, .LONG, .DWORD, .PROC *) (*----------------------------------------------------------------------------*) var txt: string; begin omin_spacje(i,zm); // txt:=get_datUp(i,zm,'(',false); txt:=get_directive(i,zm); Result := fCRC16(txt); if not(Result in [__byte..__dword, __proc]) then blad_und(zm,txt,46); end; function ciag_ograniczony(var i:integer; var a:string; const cut:Boolean): string; (*----------------------------------------------------------------------------*) (* pobiera ciag ograniczony dwoma znakami 'LEWA' i 'PRAWA' *) (* znaki 'LEWA' i 'PRAWA' moga byc zagniezdzone *) (* jesli CUT = TRUE to usuwamy poczatkowy i koncowy nawias *) (*----------------------------------------------------------------------------*) var nawias, len: integer; znak, lewa, prawa: char; petla: Boolean; begin Result:=''; if not(a[i] in ['[','(','{']) then exit; lewa:=a[i]; if lewa='(' then prawa:=')' else prawa:=chr(ord(lewa)+2); nawias:=0; petla:=true; len:=length(a); while petla and (i<=len) do begin znak := a[i]; if znak=lewa then inc(nawias) else if znak=prawa then dec(nawias); // if not(zag) then // if nawias>1 then test_nawias(a,lewa,0); // if nawias=0 then petla:=false; petla := not(nawias=0); if znak='\' then begin petla:=false; Break; end else if znak in ['''','"'] then begin Result := Result + znak + get_string(i,a,a,false) + znak end else begin Result := Result + UpCas_(znak); inc(i) end; end; if petla and not(komentarz) then case lewa of '[': blad(a,6); '(': blad(a,7); '{': blad(a,20); end; if cut then if Result<>'' then Result:=copy(Result,2,length(Result)-2); end; function test_param(var i:integer; var a:string): Boolean; (*----------------------------------------------------------------------------*) (* test na obecnosc parametrow makra, czyli ':0..9', '%%0..9' *) (*----------------------------------------------------------------------------*) begin Result := ((a[i]=':') and _dec(a[i+1])) or ((a[i]='%') and (a[i+1]='%') and _dec(a[i+2])) end; function get_dat(var i:integer; var a:string; const Sep:Char; const spacja:Boolean): string; (*----------------------------------------------------------------------------*) (* wczytaj dowolne znaki, oprocz spacji, tabulatora i 'Sep' *) (* jesli wystepuja znaki otwierajace ciag, czytaj taki ciag *) (*----------------------------------------------------------------------------*) var znak: char; len: integer; begin Result:=''; len:=length(a); while i<=len do if a[i]=Sep then exit else case UpCase(a[i]) of '[','(','{': if not(komentarz) then Result:=Result + ciag_ograniczony(i,a,false) else begin Result:=Result+a[i]; inc(i); end; 'A'..'Z': Result:=Result + get_lab(i,a, false); '''','"': if not(komentarz) then begin znak:=a[i]; Result:=Result + znak + get_string(i,a,a,false) + znak; end else begin Result:=Result+a[i]; inc(i); end; '/': case a[i+1] of '/': exit; '*': begin ___search_comment_block(i,a, Result); if komentarz then exit end; else begin Result:=Result+'/'; inc(i); end; end; ';','\': exit; ' ',#9: if spacja then exit else begin Result:=Result+a[i]; inc(i) end; else begin // if a[i]=Sep then exit; Result := Result + UpCas_(a[i]); inc(i); end; end; end; function get_dat_noSPC(var i:integer; var a:string; const sep,sep2:Char; var old:string): string; (*----------------------------------------------------------------------------*) (* wczytujemy ciag znakow pomijajac znaki spacji *) (*----------------------------------------------------------------------------*) var len: integer; begin Result:=''; omin_spacje(i,a); len:=length(a); while i<=len do begin case a[i] of ' ',#9: if sep=' ' then exit else __inc(i,a); '.','$','%': if a[i]=sep then exit else begin if (test_char(i+1,a,' ',#0)) and not(komentarz) then blad(old,4); Result:=Result+a[i]; __inc(i,a); end; '/': case a[i+1] of '/': exit; '*': begin ___search_comment_block(i,a, Result); if komentarz then exit end; else begin Result:=Result+'/'; __inc(i,a); end; end; ';','\': exit; else if a[i] in [sep,sep2] then exit else Result := Result + get_dat(i,a,sep,true); end; end; end; function OperExt(var i:integer; var old:string; const a,b:char; var value:Boolean): char; (*----------------------------------------------------------------------------*) (* operatory zlozone zamieniamy na odpowiedni jednoliterowy kod *) (*----------------------------------------------------------------------------*) var x: integer; begin Result:=' '; x:=ord(a) shl 8+ord(b); case x of 15422,8509: Result := 'A'; // '<>', '!=' 15421: Result := 'B'; // '<=' 15933: Result := 'C'; // '>=' 15420: Result := 'D'; // '<<' 15934: Result := 'E'; // '>>' 15677: Result := '='; // '==' 9766: Result := 'F'; // '&&' 31868: Result := 'G'; // '||' end; if not(value) or (Result=' ') then begin str_blad:=a+b; blad(old,8); end; inc(i,2); value:=false; end; function OperNew(var i:integer; var old:string; const a:char; var value:Boolean; const b:Boolean): char; begin if value<>b then blad_ill(old,a); Result:=a; inc(i); value:=false; end; function test_string(var i:integer; var a:string; const typ:Char): integer; (*----------------------------------------------------------------------------*) (* obliczamy wartosc ktora zmodyfikuje ciag znakowy lub plikowy *) (* dla '*' jest to wartosc 128, czyli invers *) (*----------------------------------------------------------------------------*) begin Result:=0; // wynik jest typem ze znakiem, koniecznie !!! omin_spacje(i,a); case a[i] of '*': begin Result := 128; inc(i); end; '+','-': Result := integer( ___wartosc_noSPC(a,a,i,',',typ) ); end; omin_spacje(i,a); end; procedure subrange_bounds(var a:string; const v,y:integer); begin if (v<0) or (v>y) then blad(a,62); end; procedure save_dtaS(war:cardinal; ile:integer); begin while ile>0 do begin save_dst( byte(war) ); war:=war shr 8; inc(adres); dec(ile); end; end; procedure save_dta(const war:cardinal; var tmp:string; const op_:char; const invers:byte); (*----------------------------------------------------------------------------*) (* zapisujemy bajty danych do .ARRAY w zaleznosci od ustawionego typu danych *) (*----------------------------------------------------------------------------*) var k, i: integer; v: byte; begin if aray or put_used then if array_used.idx>$FFFF then exit else begin if op_ in ['C','D'] then begin i:=length(tmp); for k:=1 to i do begin v:=byte( ord(tmp[k])+invers ); if op_='D' then v:=ata2int(v); {if not(loop_used) and not(FOX_ripit) then} just_t(v); if aray then t_tmp[array_used.idx]:=v else t_get[array_used.idx]:=v; inc(array_used.idx); if array_used.idx>array_used.max then array_used.max:=array_used.idx; end; exit; end; {if not(loop_used) and not(FOX_ripit) then} just_t(war); if aray then t_tmp[array_used.idx]:=cardinal(war) else t_get[array_used.idx]:=byte(war); inc(array_used.idx); if array_used.idx>array_used.max then array_used.max:=array_used.idx; exit; end; case op_ of 'L','B': begin save_dst( byte(war) ); inc(adres); end; 'H': begin save_dst( byte(war shr 8) ); inc(adres); end; 'A','V': begin save_dst( byte(war) ); save_dst( byte(war shr 8) ); inc(adres,2); end; 'T','E': begin save_dst( byte(war) ); save_dst( byte(war shr 8) ); save_dst( byte(war shr 16) ); inc(adres,3); end; 'F': begin save_dst( byte(war) ); save_dst( byte(war shr 8) ); save_dst( byte(war shr 16) ); save_dst( byte(war shr 24) ); inc(adres,4); end; 'G': begin save_dst( byte(war shr 24) ); save_dst( byte(war shr 16) ); save_dst( byte(war shr 8) ); save_dst( byte(war) ); inc(adres,4); end; 'C','D': begin i:=length(tmp); for k:=1 to i do begin v:=byte( ord(tmp[k])+invers ); if op_='D' then v:=ata2int(v); save_dst(v); end; inc(adres,i); end; end; end; function oblicz_wartosc_ogr(var zm,old:string; var i:integer): Int64; (*----------------------------------------------------------------------------*) (* obliczamy wartosc ograniczona nawiasami '[' lub '(' *) (*----------------------------------------------------------------------------*) var txt: string; k: integer; begin Result:=0; omin_spacje(i,zm); if zm[i] in ['[','('] then begin txt:=ciag_ograniczony(i,zm,true); k:=1; Result:=___wartosc_noSPC(txt,old,k,#0,'F') end; end; function get_labelEx(var i:integer; var a:string): string; begin Result:=''; if _lab_firstEx(a[i]) then begin Result:=Result+UpCas_(a[i]); inc(i); while _lab(a[i]) do begin Result:=Result+UpCas_(a[i]); inc(i) end; end; //if not( _eol(a[i]) ) then blad_ill(old,a[i]); // z tym testem nie policzy ciagu wyr|wyr end; function get_labEx(var i:integer; var a,old:string): string; (*----------------------------------------------------------------------------*) (* pobierz etykiete zaczynajaca sie znakami 'A'..'Z','_','?','@',':' *) (* jesli wystepuja nawiasy '( )' lub '[ ]' to usuwamy je *) (*----------------------------------------------------------------------------*) var tmp: string; k: integer; begin omin_spacje(i,a); if a[i] in ['(','['] then begin tmp := ciag_ograniczony(i,a,true); k:=1; omin_spacje(k,tmp); Result := get_labelEx(k, tmp); end else Result := get_labelEx(i, a); if Result='' then blad(old,15); end; function load_label_ofset(a:string; var old:string; const test:Boolean): integer; (*----------------------------------------------------------------------------*) (* znajdujemy indeks do tablicy T_LAB *) (*----------------------------------------------------------------------------*) var b: integer; begin if a='' then blad(old,23); if a[1]=':' then begin b := bank; bank := 0; // wymuszamy BANK=0 aby odczytac etykiete z najnizszego poziomu a:=copy(a,2,length(a)); Result:=l_lab(a); bank := b; // przywracamy poprzednia wartosc BANK end else Result:=load_lab(a,true); if test then if (Result<0) and (pass=pass_end) then blad_und(old,a,5); end; procedure testRange(var old:string; var i:integer; const b:byte); begin if (i<0) or (i>$FFFF) then begin blad(old,b); i:=0; end; end; function read_HEX(var i:integer; var a,old: string): string; begin inc(i); // omin pierwszy znak '$' Result:=''; while _hex(a[i]) do begin Result:=Result+UpCase(a[i]); inc(i) end; if not(test_param(i,a)) then if Result='' then blad_ill(old,a[i]); Result:='$'+Result; end; procedure save_lst(const c:char); (*----------------------------------------------------------------------------*) (* formatowanie wierszy listingu przed zapisaniem ich do pliku .LST *) (*----------------------------------------------------------------------------*) var i: byte; begin if pass=pass_end then begin if not(loop_used) and not(FOX_ripit) then begin t:=IntToStr(line); while length(t)<6 do t:=' '+t; t:=t+' '; end; case c of 'l': if not(FOX_ripit) then begin t:=t+'= '; bank_adres(nul.i) end; 'i': bank_adres(adres); 'a': begin if not(hea) and not(loop_used) and not(FOX_ripit) and not(struct.use) and (adres>=0) then bank_adres(adres); if nul.l>0 then begin data_out:=true; for i:=0 to nul.l-1 do save_dst(nul.h[i]); end; end; end; // end case end; inc(adres,nul.l); // to zawsze musi sie wykonac niezaleznie od przebiegu end; procedure zapisz_lokal; begin t_loc[lokal_nr].nam := lokal_name; inc(lokal_nr); if lokal_nr>High(t_loc) then SetLength(t_loc,lokal_nr+1); end; procedure oddaj_lokal(var a: string); begin if lokal_nr=0 then blad(a,28); dec(lokal_nr); lokal_name := t_loc[lokal_nr].nam; end; procedure new_DOS_header; var old_opt: byte; begin old_opt:=opt; opt:=opt or 1; // wymuszamy zapis naglowka DOS-a save_hea; org:=true; opt:=old_opt; end; function oblicz_wartosc(var a:string; var old:string): Int64; (*----------------------------------------------------------------------------*) (* obliczamy wartosc wyrazenia, uwzgledniajac operacje arytmetyczne *) (* w 'J' jest licznik dla STOS'u *) (* zamiast tablic dynamicznych wprowadzilem tablice statyczne i ograniczylem *) (* maksymalna liczbe operacji i operatorow w wyrazeniu do 512 *) (*----------------------------------------------------------------------------*) type znak_wart = record znak: char; wart: Int64; end; _typCash = array [0..16] of char; // taka sama liczba elementow jak PRIOR _typOper = array [0..511] of char; _typStos = array [0..511] of znak_wart; var i, j, b, x, k, v, pomoc, ofset, _hlp, len, op_idx, arg: integer; old_reloc_value_cnt: integer; tmp, txt: string; iarg, war: Int64; petla, value, old_reloc_value_use: Boolean; oper, byt: char; fsize: file; reloc_value: relVal; stos_: _carArray; cash : _typCash; stos : _typStos; op : _typOper; const prior: array [0..16] of char= // piorytet operatorow ('D','E','&','|','^','/','*','%','+',{'-',}'=','A','B','<','C','>','F','G'); begin if a='' then blad(old,23); Result:=0; // init tablicy dynamicznej OP // SetLength(op,2); op[0]:='+'; oper:='+'; op_idx:=1; i:=1; war:=0; b:=0; // fillchar(cash,sizeof(cash),' '); // wypelniamy spacjami cash[0]:=' '; cash[1]:=' '; cash[2]:=' '; cash[3]:=' '; cash[4]:=' '; cash[5]:=' '; cash[6]:=' '; cash[7]:=' '; cash[8]:=' '; cash[9]:=' '; cash[10]:=' '; cash[11]:=' '; cash[12]:=' '; cash[13]:=' '; cash[14]:=' '; cash[15]:=' '; cash[16]:=' '; value:=false; reloc_value.use:=false; reloc_value.cnt:=0; j:=1; // na pozycji zerowej (J=0) tablicy 'STOS' dopiszemy '+0' // !!! zmienne I,J uzywane sa przez petle WHILE !!! // SetLength(stos,3); len:=length(a); while (i<=len) and not(overflow) do begin case UpCase(a[i]) of '#': begin if ___rept_ile<0 then blad(old,116); war:=___rept_ile; value:=true; __inc(i,a); end; // odczytaj operator '<' '<': if a[i+1] in ['<','=','>'] then oper:=OperExt(i,old,'<',a[i+1],value) else if value then oper:=OperNew(i,old,'<',value,true) else oper:=OperNew(i,old,'M',value,false); // odczytaj operator '>' '>': if a[i+1] in ['=','>'] then oper:=OperExt(i,old,'>',a[i+1],value) else if value then oper:=OperNew(i,old,'>',value,true) else oper:=OperNew(i,old,'S',value,false); // odczytaj operator '=' '=': if a[i+1]='=' then oper:=OperExt(i,old,'=','=',value) else if value then oper:=OperNew(i,old,'=',value,true) else oper:=OperNew(i,old,'X',value,false); // odczytaj operator '&' '&': if a[i+1]='&' then oper:=OperExt(i,old,'&','&',value) else oper:=OperNew(i,old,'&',value,true); // odczytaj operator '|' '|': if a[i+1]='|' then oper:=OperExt(i,old,'|','|',value) else oper:=OperNew(i,old,'|',value,true); // odczytaj operator '!' '!': if a[i+1]='=' then oper:=OperExt(i,old,'!','=',value) else oper:=OperNew(i,old,'!',value,false); // odczytaj operator '^' '^': if not(value) then begin oper:='H'; inc(i) end else oper:=OperNew(i,old,'^',value,true); // odczytaj operator '/' '/': if a[i+1]='*' then begin omin_spacje(i,a); value:=false; end else oper:=OperNew(i,old,'/',value,true); // odczytaj operator '*' '*': if not(value) then begin b:=bank; war:=adres; inc(i); value:=true; label_type:='V'; if not(branch) then begin save_rel(adres, -1, bank, reloc_value); end; end else oper:=OperNew(i,old,'*',value,true); // odczytaj operator '~' '~': oper:=OperNew(i,old,'~',value,false); // odczytaj operatory '+' '-' '+','-': oper:=OperNew(i,old,a[i],value,value); // odczytaj wartosc decymalna lub wyjatkowo hex 0x... '0'..'9': begin if value then blad(old,4); if (UpCase(a[i+1])='X') and (a[i]='0') then begin // 0x... inc(i); tmp:=read_HEX(i,a,old); end else begin // 0..9 tmp:=''; while _dec(a[i]) do begin tmp:=tmp+a[i]; __inc(i,a) end; end; war:=StrToInt(tmp); value:=true; end; // odczytaj .R, .OR, .LO, .HI, .GET, .AND, .XOR, .NOT, .LEN, .ADR, .DEF '.': if a[i+1] in ['r','R'] then begin // .R if ___rept_ile<0 then blad(old,116); war:=___rept_ile; inc(i,2); value:=true; if not(loop_used) and not(FOX_ripit) then t:=t+' #'+Hex(cardinal(war),2); // zapisz w pliku LST #numer end else begin tmp:='.'+UpCase(a[i+1])+UpCase(a[i+2]); _hlp:=ord(tmp[2]) shl 16+ord(tmp[3]) shl 8; case _hlp of $4F5200: begin oper:=OperExt(i,old,'|','|',value); // .OR inc(i); end; $4C4F00: begin // .LO (expression) inc(i,3); old_reloc_value_cnt := reloc_value.cnt; old_reloc_value_use := reloc_value.use; war:=byte( oblicz_wartosc_ogr(a,old,i) ); reloc_value.use := old_reloc_value_use; inc(reloc_value.cnt, old_reloc_value_cnt); value:=true; end; $484900: begin // .HI (expression) inc(i,3); old_reloc_value_cnt := reloc_value.cnt; old_reloc_value_use := reloc_value.use; war:=byte( oblicz_wartosc_ogr(a,old,i) shr 8 ); reloc_value.use := old_reloc_value_use; inc(reloc_value.cnt, old_reloc_value_cnt); value:=true; end; else begin tmp:=tmp+UpCase(a[i+3]); inc( _hlp , ord(tmp[4]) ); case _hlp of $474554: begin // .GET inc(i,4); omin_spacje(i,a); arg:=0; old_reloc_value_cnt := reloc_value.cnt; old_reloc_value_use := reloc_value.use; if a[i] in ['[','('] then arg:=integer( oblicz_wartosc_ogr(a,old,i) ); subrange_bounds(old,arg,$FFFF); // !!! konieczny test reloc_value.use := old_reloc_value_use; inc(reloc_value.cnt, old_reloc_value_cnt); war:=t_get[arg]; value:=true; end; $414E44: begin oper:=OperExt(i,old,'&','&',value); // .AND inc(i,2); end; $584F52: begin oper:=OperNew(i,old,'^',value,true); // .XOR inc(i,3); end; $4E4F54: begin oper:=OperNew(i,old,'!',value,false); // .NOT inc(i,3); end; $4C454E: // .LEN label begin // omijamy 4 znaki dyrektywy '.LEN' // i odczytujemy nazwe etykiety inc(i,4); if a[i] in ['''','"'] then begin // file size txt:=get_string(i,a,old,true); txt:=GetFile(txt,a); if not(TestFile(txt)) then blad(txt,18); assignfile(fsize, txt); FileMode:=0; Reset(fsize, 1); war:=FileSize(fsize); CloseFile(fsize); end else begin // var size txt:=get_labEx(i,a, old); arg:=load_label_ofset(txt, old, true); if arg>=0 then case t_lab[arg].bnk of __id_proc: war:=t_prc[t_lab[arg].adr].len; // dlugosc bloku .PROC __id_array: war:=t_arr[t_lab[arg].adr].len; // dlugosc bloku .ARRAY __id_struct: war:=t_str[t_lab[arg].adr].siz; // dlugosc bloku .STRUCT else war:=t_lab[arg].lln; // dlugosc bloku .LOCAL end; end; value:=true; end; $414452: begin // .ADR label // omijamy 4 znaki dyrektywy '.ADR' // i odczytujemy nazwe etykiety inc(i,4); txt:=get_labEx(i,a, old); arg:=load_label_ofset(txt, old, true); war:=0; if arg>=0 then begin old_reloc_value_cnt := reloc_value.cnt; old_reloc_value_use := reloc_value.use; war:= oblicz_wartosc(txt,old); reloc_value.use := old_reloc_value_use; inc(reloc_value.cnt, old_reloc_value_cnt); case t_lab[arg].bnk of __id_proc: dec(war, t_prc[t_lab[arg].adr].ofs); else dec(war, t_lab[arg].ofs) end; end; value:=true; end; $444546: begin // .DEF label // omijamy 4 znaki dyrektywy '.DEF' // i odczytujemy nazwe etykiety inc(i,4); txt:=get_labEx(i,a, old); arg:=load_label_ofset(txt, old, false); // war:=ord(arg>=0); // !!! nie dziala prawidlowo dla .IFNDEF z Exomizera !!! if arg>=0 then // !!! koniecznie ta wersja !!! war := ord( t_lab[arg].pas>0 ) else war:=0; value:=true; end; else begin tmp:=tmp+UpCase(a[i+4])+UpCase(a[i+5]); if tmp<>'.ZPVAR' then blad_und(old,tmp,68) else begin inc(i,6); war:=zpvar; value:=true; end; end; end; end; end; end; // odczytaj etykiete i okresl jej wartosc // znak ':' oznacza etykiete globalna lub parametr makra 'A'..'Z','_','?','@',':': begin petla:=false; b:=0; war:=0; //pomoc:=0; if a[i]=':' then if _lab_first(a[i+1]) then begin petla:=true; inc(i) end else if _dec(a[i+1]) then begin if run_macro then begin value:=false; oper:=' '; Break; //i:=len+1 end else blad_ill(old,':'); end else blad(old,4); if i<=len then begin if value then blad(old,4); tmp:=get_lab(i,a, false); if petla then tmp:=':'+tmp; arg:=load_label_ofset(tmp, old, true); { if arg>=0 then // skladnia dla enum label1::label2 if t_lab[arg].bnk=__id_enum then // usunieta w celu zachowania spojnosci if (a[i]=':') and (a[i+1]=':') then begin // akceptowany jest znak '.' zamiast '::' inc(i, 2); tmp:=tmp+'.'+get_lab(i,a, false); if petla then tmp:=':'+tmp; arg:=load_label_ofset(tmp, old, true); end; } // jesli przetwarzamy makro to nie musza byc zdefiniowane wartosci etykiet // w pozostalych przypadkach wystapi blad 'Undeclared label ????' if arg<0 then begin undeclared:=true; // wystapila niezdefiniowana etykieta value:=false; oper:=' '; Break // przerywamy obliczanie wyrazenia end else if (pass=pass_end) and (t_lab[arg].bnk<__id_param) and t_lab[arg].sts then blad_und(old,tmp,113); undeclared:=t_lab[arg].sts; // aktualny status etykiety pomoc:=t_lab[arg].adr; if (t_lab[arg].typ in ['P','V']) then variable:=true; t_lab[arg].use:=true; if arg>=0 then case t_lab[arg].bnk of __id_struct: // zamiana struktur na dane DTA, na poczatku sprawdzimy czy 'DTA_USED = true' if not(dta_used) then begin b := t_str[pomoc].bnk; war := t_str[pomoc].siz; end else if pass=0 then begin // teraz nie znamy wszystkich struktur, musimy kończyc if a[i]<>'[' then warning(102); // 'Constant expression expected', brakuje indeksu [idx] end else begin // w drugim przebiegu mamy pewnosc ze poznalismy wszystkie struktury dta_used:=false; struct_used.use:=true; save_lst('i'); // odczytujemy ofset do tablicy 'T_STR' ofset:=t_lab[arg].adr; struct_used.idx:=ofset; // w OFSET indeks do pierwszego pola struktury // liczba pol struktury b := t_str[ofset].ofs; inc(ofset); txt:=''; // odczytujemy zadeklarowana liczbe elementow danych strukturalnych [?] arg:=integer( oblicz_wartosc_ogr(a,old,i) ); testRange(old, arg, 62); struct_used.cnt:=arg; omin_spacje(i,a); // odczytujemy wartosci elementow ograniczone nawiasami ( ) while a[i] ='(' do begin tmp:=ciag_ograniczony(i,a,true); k:=1; tmp:=get_dat_noSPC(k,tmp,#0,#0,old); k:=1; SetLength(stos_,1); // wczytujemy elementy ograniczone nawiasami, w 'X' jest licznik x:=0; while k<=length(tmp) do begin pomoc:=loa_str_no(t_str[ofset].id, x); // zawsze musi odnalezc wlasciwe pole struktury v:=t_str[pomoc].siz; byt:=tType[v]; war:=___wartosc_noSPC(tmp,old,k,',',byt); _hlp:=t_str[pomoc].rpt * v; save_dtaS(cardinal(war), _hlp); inc(x); // if pass>0 then if x>b then blad(old,40); // jesli liczba podanych elementow jest wieksza niz w strukturze pomoc:=High(stos_); stos_[pomoc]:=cardinal( war ); SetLength(stos_,pomoc+2); omin_spacje(k,tmp); if tmp[k]=',' then __inc(k,tmp) else Break; end; // if pass>0 then if x<>b then blad(old,40); // zmniejszamy licznik elementow dec(arg); if arg<-1 then blad(old,40); omin_spacje(i,a); end; omin_spacje(i,a); value:=( High(stos_) = b ); // jesli podalismy jakies wartosci poczatkowe to VALUE=TRUE if not(value) then new_DOS_header; // jesli nie podalismy wartosci to musimy wymusic ORG-a // !!! nie mozna domyslnie zapisywac zer dla zmiennej strukturalnej !!! // !!! bo nie zawsze mozna zapisywac pamiec pod aktualnym adresem !!! // reszte elementow struktury wypelniamy ostatnimi wartosciami lub zerami while arg>=0 do begin for x:=0 to b-1 do begin pomoc:=loa_str_no(t_str[ofset].id, x); v:=t_str[pomoc].siz; //byt:=tType[v]; _hlp:=t_str[pomoc].rpt * v; if value then begin war:=stos_[x]; save_dtaS(cardinal(war), _hlp); // nowy adres i zapisanie wartosci poczatkowej struktury end else begin war:=0; inc(adres, _hlp); // nowy adres bez zapisywania wartosci poczatkowej end; end; dec(arg); end; b:=bank; value:=false; oper:=' '; end; __id_enum: begin omin_spacje(i,a); if a[i] in ['(','['] then begin _hlp:=usi_idx; // dla enum_name(label1|label2|...) t_usi[usi_idx].lok:=end_idx; t_usi[usi_idx].lab:=tmp; if proc then t_usi[usi_idx].nam:=proc_name else t_usi[usi_idx].nam:=lokal_name; inc(usi_idx); SetLength(t_usi, usi_idx+1); war:=oblicz_wartosc_ogr(a,old,i); usi_idx:=_hlp; end; end; __id_proc: begin b:=t_prc[pomoc].bnk; war:=t_prc[pomoc].adr; if ExProcTest then t_prc[pomoc].use:=true; // procedura .PROC musi byc asemblowana save_relAddress(arg, reloc_value); end; __id_ext: begin if blocked then blad_und(old,tmp,41); if not(branch) then begin if vector then _hlp:=adres else _hlp:=adres+1; if dreloc.use then dec(_hlp, rel_ofs); t_ext[ext_idx].adr := _hlp; t_ext[ext_idx].bnk := bank; t_ext[ext_idx].idx := pomoc; inc(ext_idx); if ext_idx>High(t_ext) then SetLength(t_ext,ext_idx+1); end; ext_used.use:=true; ext_used.idx:=pomoc; ext_used.siz:=t_extn[pomoc].siz; inc(reloc_value.cnt); end; __id_smb: begin if blocked then blad_und(old,tmp,41); if not(branch) then begin save_rel(adres,pomoc,0, reloc_value); t_smb[pomoc].use:=true; war:=__rel; end; end; __id_array: begin b:=t_arr[pomoc].bnk; war:=t_arr[pomoc].adr; omin_spacje(i,a); if a[i]='[' then begin ofset:=integer( oblicz_wartosc_ogr(a,old,i) ); subrange_bounds(old,ofset,t_arr[pomoc].idx); inc(war, Int64(ofset)*t_arr[pomoc].siz); end; save_relAddress(arg, reloc_value); end; __dta_struct: begin save_relAddress(arg, reloc_value); b:=t_str[pomoc].bnk; war:=t_str[pomoc].adr; ofset:=integer( oblicz_wartosc_ogr(a,old,i) ); subrange_bounds(old,ofset,t_str[pomoc].ofs); arg:=t_str[t_lab[arg].adr].idx; ofset:=ofset * t_str[arg].siz; // indeks * dlugosc_struktury if a[i]='.' then begin inc(i); txt:=get_lab(i,a, false); // szukamy w T_STR pomoc:=loa_str(txt, t_str[arg].id); if pomoc>=0 then inc(ofset,t_str[pomoc].ofs) else if pass=pass_end then blad_und(old,txt,46); end; inc(war,ofset); end; else begin // wystapi blad 'Address relocation overload' // jesli dokonujemy operacji na wiecej niz jednej relokowalnej etykiecie save_relAddress(arg, reloc_value); if dreloc.use or dreloc.sdx then if reloc_value.use and (reloc_value.cnt>1) then blad(old,85); b:=t_lab[arg].bnk; war:=t_lab[arg].adr; while pos('.',tmp)>0 do begin obetnij_kropke(tmp); k:=length(tmp); // usun ostatni znak kropki SetLength(tmp,k-1); arg:=l_lab(tmp); pomoc:=t_lab[arg].adr; if (arg>=0) and ExProcTest then if t_lab[arg].bnk=__id_proc then begin t_prc[pomoc].use:=true; // procedura .PROC musi byc asemblowana Break; end; end; end; end; value:=true; end; // wyjatkowo dla PASS=0 i prawdopodobnego odwolania do tablicy przyjmij wartosc =0 omin_spacje(i,a); if a[i]='[' then if pass'' then begin k:=Length(tmp); //remove leading zeros pomoc:=1; while tmp[pomoc]='0' do inc(pomoc); //do the conversion for ofset:=k downto pomoc do if tmp[ofset]='1' then war:=war+(1 shl (k-ofset)); end; value:=true; end; // odczytaj string ograniczony apostrofami '' '''','"': begin if value then blad(old,4); k:=ord(a[i]); tmp:=get_string(i,a,old,true); if length(tmp)>1 then blad(old,3); // maksymalnie 1 znak if chr(k)='''' then war:=ord(tmp[1]) else war:=ata2int(ord(tmp[1])); byt:=a[i+1]; if not(_lab_firstEx(byt) or _dec(byt) or (byt in ['$','%'])) then inc(war,test_string(i,a,'F')); value:=true; end; // odczytaj wartosc miedzy { } '{': begin if value then blad(old,4); klamra_used := true; petla:=dreloc.use; // blokujemy relokowalnosc DRELOC.USE=FALSE dreloc.use:=false; tmp:=ciag_ograniczony(i,a,true); // test na poprawnosc nawiasow k:=1; nul:=oblicz_mnemonik__(k,tmp,old); dreloc.use:=petla; // przywracamy poprzednia wartosc DRELOC.USE klamra_used := false; war:=nul.h[0]; nul.l:=0; value:=true; end; // odczytaj wartosc miedzy [ ] ( ) '[','(': begin if value then blad(old,4); old_reloc_value_cnt := reloc_value.cnt; old_reloc_value_use := reloc_value.use; war:=oblicz_wartosc_ogr(a,old,i); reloc_value.use := old_reloc_value_use; inc(reloc_value.cnt, old_reloc_value_cnt); value:=true; end; // jesli napotkasz spacje to zakoncz przetwarzanie // do 'value' wpisz 'false' aby nie traktowal tego jako liczby ' ',#9: begin value:=false; oper:=' '; Break; //i:=len+1 end; else blad_ill(old,a[i]); end; // jesli przetwarzamy wartosc numeryczna to zapisz na stosie // tą wartosc i operator if value then begin op[op_idx]:='+'; // przetworz operatory z 'OP' cofajac sie for k:=op_idx downto 1 do case op[k] of '-': war := -war; 'M': war := byte(war); 'S': war := byte(war shr 8); 'H': war := byte(war shr 16); // 'I': war := byte(war shr 24); '!': war := ord(war=0); '~': war := not(war); 'X': war := b; end; if op[0]='-' then begin war:=-war; op[0]:='+' end; stos[j].znak := op[0]; stos[j].wart := war; cash[pos(op[0],prior)-1]:=op[0]; // zeruj indeks do tablicy dynamicznej OP op_idx:=0; oper:=' '; inc(j); // if j>High(stos) then SetLength(stos,j+1); end else begin op[op_idx] := oper; inc(op_idx); // if op_idx>High(op) then SetLength(op,op_idx+1); end; end; if not(overflow) then if oper<>' ' then blad(old,23); if reloc_value.cnt>1 then blad(old,85); // obliczenie wartosci wg piorytetu obliczen // na koncu dodawaj tak dlugo az nie uzyskasz wyniku len:=0; war:=0; while cash[len]=' ' do inc(len); // omijaj puste operatory if len>=sizeof(cash) then exit; // nie wystapil zaden operator stos[0].znak:='+'; stos[0].wart:=0; stos[j].znak:='+'; stos[j].wart:=0; inc(j); // SetLength(stos,j+1); while j>1 do begin // 'petla=true' jesli nie wystapi zaden operator // 'petla=false' jesli wystapi operator i:=0; petla:=true; while i<=j-2 do begin war := stos[i].wart; oper := stos[i+1].znak; iarg := stos[i+1].wart; // obliczaj wg kolejnosci operatorow z 'prior' // operatory '/','*','%' maja ten sam piorytet, stanowią wyjątek if (oper=cash[len]) or ((oper in ['/','*','%']) and (len in [5..7])) then begin case oper of '+': war := war + iarg; '&': war := war and iarg; '|': war := war or iarg; '^': war := war xor iarg; '*': war := war * iarg; '/','%': if iarg=0 then begin overflow:=true; if pass=pass_end then blad(old,26) else war:=0; end else case oper of '/': war := war div iarg; '%': war := war mod iarg; end; '=': war := ord(war=iarg); 'A': war := ord(war<>iarg); 'B': war := ord(war<=iarg); '<': war := ord(war=iarg); '>': war := ord(war>iarg); 'D': war := war shl iarg; 'E': war := war shr iarg; 'F': war := ord(war<>0) and ord(iarg<>0); 'G': war := ord(war<>0) or ord(iarg<>0); end; // obliczyl nowa wartosc, skasuj znak stos[i].wart := war; stos[i+1].znak := ' '; inc(i); petla:=false; end; inc(i) end; // przepisz elementy ktore maja niepusty znak na poczatek tablicy STOS k:=0; for i:=0 to j-1 do if stos[i].znak<>' ' then begin stos[k] := stos[i]; inc(k) end; j:=k; if petla and (len',' then blad(old,52) else inc(i); end; procedure put_lst(const a:string); (*----------------------------------------------------------------------------*) (* zapisujemy wiersze listingu po asemblacji do pliku .LST *) (*----------------------------------------------------------------------------*) begin if (pass=pass_end) and (a<>'') then begin if run_macro then // nie zapisuj zawartosci makra jesli bit5 OPT skasowany if (opt and $20=0) and not(data_out) then exit; if (opt and 4>0) and not(FOX_ripit) then writeln(lst,a); if (opt and 8>0) and not(FOX_ripit) then writeln(a); if not(FOX_ripit) then t:=''; end; end; procedure zapisz_lst(var a: string); (*----------------------------------------------------------------------------*) (* wymuszenie zapisania wiersza listingu do pliku .LST *) (*----------------------------------------------------------------------------*) begin if (pass=pass_end) then begin justuj; put_lst(t+a); a:=''; end; end; procedure wymus_zapis_lst(var a: string); (*----------------------------------------------------------------------------*) (* dodatkowe wymuszenie zapisania wiersza listingu do pliku .LST *) (*----------------------------------------------------------------------------*) begin if pass=pass_end then begin save_lst(' '); justuj; put_lst(t+a); end; end; procedure _siz(const t: Boolean); begin if t then t_siz[siz_idx-1].siz:=dreloc.siz else t_siz[siz_idx].siz:=dreloc.siz; end; procedure _sizm(const a: byte); begin t_siz[siz_idx-1].lsb:=a; end; procedure oblicz_dane(var i:integer; var a,old:string; const typ: byte); (*----------------------------------------------------------------------------*) (* zwracamy wartosci liczbowe dla ciagu DTA, .BYTE, .WORD, .LONG, .DWORD *) (*----------------------------------------------------------------------------*) (* B( -> BYTE, A( -> WORD, V( -> VECTOR (WORD) *) (* L( -> BYTE, H( -> BYTE *) (* T( -> 24bit, E( -> 24bit *) (* F( -> DWORD *) (* G( -> DWORD (odwrocona kolejnosc) *) (* C' -> ATASCII *) (* D' -> INTERNAL *) (* sin(centre,amp,size[,first,last]) *) (*----------------------------------------------------------------------------*) var op_, default: char; sin_a, sin_b, sin_c, sin_d, sin_e, x, len, k: integer; war: Int64; invers: byte; value, nawias, ciag: Boolean; tmp: string; begin omin_spacje(i,a); if empty or enum.use then blad(old,58); war:=0; invers:=0; value:=false; nawias:=false; ciag:=false; if not(pisz) then branch:=false; reloc := false; data_out := true; tmp:=' '; // ------------------ okreslenie domyslnego typu wartosci --------------------- default := tType[typ]; op_:=default; dreloc.siz:=relType[typ]; // ---------------------------------------------------------------------------- if not(pisz) and test_char(i,a,#0,#0) then begin // jesli brakuje danych to generuj domyslnie zera save_dta(cardinal(war),tmp,op_,invers); exit; end; if struct.use then blad(old,58); vector:=true; if not(pisz) then dta_used:=true; len:=length(a); while i<=len do begin // SIN, RND if UpCase(a[i]) in ['S','R'] then begin x:=ord(UpCase(a[i+1])) shl 16+ord(UpCase(a[i+2])) shl 8+ord(a[i+3]); CASE x of // IN( $494E28: begin inc(i,3); // sprawdzamy poprawnosc nawiasow k:=i; tmp:=ciag_ograniczony(k,a,true); value:=true; invers:=0; tmp:=''; inc(i); sin_a:=integer( get_expres(i,a,old,true) ); sin_b:=integer( get_expres(i,a,old,true) ); sin_c:=integer( get_expres(i,a,old,false) ); if sin_c<=0 then blad(old,0); sin_d:=0; sin_e:=sin_c-1; if a[i]=',' then begin inc(i); sin_d:=integer( get_expres(i,a,old,true) ); sin_e:=integer( get_expres(i,a,old,false) ); inc(i); end else inc(i); while sin_d <= sin_e do begin war:= sin_a + round(sin_b * sin(sin_d * 2 * pi / sin_c)); war:=wartosc(old,war,op_); save_dta(cardinal(war),tmp,op_,invers); inc(sin_d); end; omin_spacje(i,a); end; // ND( $4E4428: begin inc(i,3); // sprawdzamy poprawnosc nawiasow k:=i; tmp:=ciag_ograniczony(k,a,true); value:=true; invers:=0; tmp:=''; inc(i); sin_a:=integer( get_expres(i,a,old,true) ); sin_b:=integer( get_expres(i,a,old,true) ); sin_c:=integer( get_expres(i,a,old,false) ); inc(i); sin_d:=sin_b-sin_a; randomize; for x:=0 to sin_c-1 do begin war:=sin_a+Int64(random(sin_d+1)); war:=wartosc(old,war,op_); save_dta(cardinal(war),tmp,op_,invers) end; omin_spacje(i,a); end; END; //end case end; case UpCase(a[i]) of 'A','B','E','F','G','H','L','T','V': begin k:=i; if a[i+1] in [' ',#9] then begin __inc(i,a); if a[i]='(' then dec(i) else i:=k; end; if a[i+1]='(' then begin // pobierz ciag ograniczony nawiasami ( ) if value then blad(old,4); op_:=UpCase(a[k]); inc(i); // sprawdzamy poprawnosc k:=i; tmp:=ciag_ograniczony(k,a,true); nawias:=true; // dane inne niz 2 bajtowe nie sa relokowalne w przypadku SPARTA DOS X // relokowalne sa wszystkie jesli uzylismy dyrektywy .RELOC if dreloc.use then begin // if op_='G' then branch:=true else branch:=false; branch := (op_='G'); case op_ of 'E','T': dreloc.siz:=relType[3]; 'A','V': dreloc.siz:=relType[2]; 'F': dreloc.siz:=relType[4]; 'L': dreloc.siz:='<'; 'H': dreloc.siz:='>'; else dreloc.siz:=relType[1]; end; _siz(false); end else // if op_ in ['E','F','G','T'] then branch:=true else branch:=false; branch := (op_ in ['E','F','G','T']); inc(i); // omin nawias otwierajacy end else begin if dreloc.use then _siz(false); if value then blad(old,4); war:=get_expres(i,a,old, false); value:=true; { if reloc and not(nawias) then ???????????????????????? if pass=pass_end then warning(116); } if pisz then end_string := end_string + '$' + hex(cardinal(war),4); end; end; 'C','D': begin k:=i; if a[i+1] in [' ',#9] then begin __inc(i,a); if a[i] in ['''','"'] then dec(i) else i:=k; end; if a[i+1] in ['''','"'] then begin // pobierz ciag ograniczony apostrofami '' lub "" op_:=UpCase(a[k]); inc(i); end else begin if dreloc.use then _siz(false); if value then blad(old,4); war:=get_expres(i,a,old, false); value:=true; { if reloc and not(nawias) then ???????????????????????? if pass=pass_end then warning(116); } if pisz then end_string := end_string + '$' + hex(cardinal(war),4); end; end; '''','"': begin if value then blad(old,4); // if aray then if not(op_ in ['C','D']) then if a[i]='"' then op_:='D' else op_:='C'; tmp:=get_string(i,a,old,true); war:=0; ciag:=true; invers:=byte( test_string(i,a,'B') ); value:=true; if pisz then end_string := end_string + tmp; end; '(': begin nawias:=true; inc(i) end; ')': if nawias and value then begin value:=false; nawias:=false; inc(i); omin_spacje(i,a); if not(test_char(i,a,#0,#0)) then // jesli nie ma konca linii to jedynym if a[i]<>',' then blad(old,107); // akceptowanym znakiem jest znak ',' end else blad(old,4); ',': begin inc(i); invers:=0; value:=false; omin_spacje(i,a); if test_char(i,a,#0,#0) then blad(old,23); // jesli koniec linii to blad 'Unexpected end of line' if not(nawias) then op_:=default; end; ' ',#9: omin_spacje(i,a); '/': case a[i+1] of '/': Break; '*': begin tmp:=''; ___search_comment_block(i,a, tmp); if komentarz then Break end; else blad(old,4); // value:=false; i:=length(a)+1 end; ';','\': Break; // value:=false; i:=length(a)+1 else begin if _eol(a[i]) then Break; if dreloc.use then _siz(false); if value then blad(old,4); war:=get_expres(i,a,old, false); value:=true; if pisz then end_string := end_string + '$' + hex(cardinal(war),4); end; end; if dta_used then if value then begin if not(ciag) then if op_ in ['C','D'] then op_:='B'; if reloc and dreloc.use then begin dec(war,rel_ofs); reloc:=false; _sizm(byte(war)); end; if not(pisz) then begin if ext_used.use and (op_ in ['L','H']) then case op_ of 'L': t_ext[ext_idx-1].typ:='<'; 'H': begin t_ext[ext_idx-1].typ:='>'; t_ext[ext_idx-1].lsb:=byte(war) end; end; war:=wartosc(old,war,op_); save_dta(cardinal(war),tmp,op_,invers); end else branch:=true; // jesli PISZ=TRUE to nie ma relokowalnosci ciag:=false; end; omin_spacje(i,a); end; vector:=false; dta_used:=false; end; function value_code(var a: Int64; var old: string; const test:Boolean): char; (*----------------------------------------------------------------------------*) (* przedstawiamy wartosc w postaci kodu literowego 'Z', 'Q', 'T' , 'D' *) (* kody literowe symbolizuja typ wartosci BYTE, WORD, LONG, DWORD *) (*----------------------------------------------------------------------------*) var x: cardinal; begin Result:='D'; x:=cardinal( abs(a) ); case x of 0..$FF: Result:='Z'; $100..$FFFF: Result:='Q'; $10000..$FFFFFF: if test then Result:='T' else blad(old,14); // $1000000..$FFFFFFFF: Result:='D'; else if not(test) then blad(old,0); end; end; procedure reg_size(const i:byte; const a:Boolean); (*----------------------------------------------------------------------------*) (* nowe rozmiary rejestrow dla operacji sledzenia SEP, REP *) (*----------------------------------------------------------------------------*) begin if i in [$10,$30] then begin regX:=a; regY:=a end; if i in [$20,$30] then regA:=a; end; procedure test_reg_size(var a:string; const b:Boolean; const i:byte); (*----------------------------------------------------------------------------*) (* sprawdzamy rozmiar rejestrow dla wlaczonej opcji sledzenia SEP, REP *) (*----------------------------------------------------------------------------*) begin if b then begin if i>2 then blad(a,63); end else if i<3 then blad(a,63); end; function macro_rept_if_test: Boolean; begin Result := (not(rept) and if_test) end; procedure test_siz(var a:string; var siz:Char; const x:Char; var pomin:Boolean); (*----------------------------------------------------------------------------*) (* sprawdzamy identyfikator rozmiaru *) (*----------------------------------------------------------------------------*) begin if siz in [' ',x] then siz:=x else blad(a,14); pomin:=true; end; function adr_label(const n: byte; const tst:Boolean): cardinal; (*----------------------------------------------------------------------------*) (* szukamy wartosci dla etykiety o nazwie z MADS_STACK[N], jesli nie zostaly *) (* zdefiniowane etykiety z MADS_STACK wowczas przypisujemy im wartosci *) (* z MADS_STACK_DEFAULT[N] *) (*----------------------------------------------------------------------------*) var i: integer; txt: string; const mads_stack_default: array [0..2] of cardinal = ($fe, $0500, $0600); begin Result:=0; txt:=mads_stack[n]; i:=load_lab(txt,false); if tst then if i<0 then begin Result:=mads_stack_default[n]; // brak deklaracji dla etykiety z TXT s_lab(txt,Result,bank,txt,'@'); end; if i>=0 then Result:=t_lab[i].adr; // odczytujemy wartosc etykiety end; procedure test_skipa; begin if t_bck[1]=adres then exit; t_bck[0] := t_bck[1]; t_bck[1] := adres; if skip.use then begin t_skp[skip.idx] := adres; inc(skip.idx); if skip.idx>High(t_skp) then SetLength(t_skp,skip.idx+1); inc(skip.cnt); if skip.cnt>1 then begin skip.use := false; skip.xsm := false; end; end; end; procedure addResult(var hlp, Res: int5); var i: integer; begin for i:=0 to hlp.l-1 do Res.h[Res.l+i]:=hlp.h[i]; inc(Res.l, hlp.l); end; function asm_mnemo(var txt, old:string): int5; var i: integer; begin i:=1; Result:=oblicz_mnemonik__(i,txt, old); inc(adres, Result.l); end; function moveAXY(var mnemo,zm,zm2, old: string): int5; var tmp: string; hlp: int5; r: byte; v: integer; begin mnemo[1]:='L'; mnemo[2]:='D'; // LD? tmp:=mnemo + #32 + zm; Result:=asm_mnemo(tmp,old); if regAXY_opty and not(dreloc.use) and not(dreloc.sdx) then if zm[1] in ['#','<','>'] then begin v:=Result.h[1]; case mnemo[3] of 'A': r := 0; 'X': r := 1; // 'Y': r := 2; else r:=2; end; if regOpty.use then if regOpty.reg[r]=v then Result.l:=0; regOpty.reg[r]:=v; end; mnemo[1]:='S'; mnemo[2]:='T'; // ST? tmp:=mnemo + #32 + zm2; hlp:=asm_mnemo(tmp,old); addResult(hlp, Result); Result.tmp:=hlp.h[0]; end; function adrMode(var a: string): byte; begin Result:=fCRC16(a); if Result in [$60..$7e] then dec(Result,$60) else Result:=0; end; procedure save_fake_label(var ety,old:string; const tst:cardinal); var war: integer; begin war:=load_lab(ety,false); // uaktualniamy wartosc etykiety if war<0 then s_lab(ety,tst,bank,old,ety[1]) else t_lab[war].adr:=tst; end; procedure __next(var i:integer; var zm:string); begin omin_spacje(i,zm); if zm[i]=',' then __inc(i,zm); omin_spacje(i,zm); end; procedure get_parameters(var j:integer; var str:string; var par:_strArray; const mae:Boolean; const sep1,sep2: char); (*----------------------------------------------------------------------------*) (* jesli wystepuje znak '=' to omijamy spacje sprzed i zza znaku '=' *) (* zapamietamy wszystkie etykiety (parametry) w tablicy dynamicznej *) (*----------------------------------------------------------------------------*) var txt: string; i: integer; begin SetLength(par,1); if str='' then exit; omin_spacje(j,str); while not(test_char(j,str, sep1,sep2)) do begin txt:=get_dat(j,str,',',true); // TRUE - konczy gdy napotka biala spacje i:=length(txt); // wyjatek jesli odczytal ciag znakow zakonczony // znakiem '=', np. 'label=' if i>0 then if txt[i]='=' then begin SetLength(txt, i-1); dec(j); end; i := j; omin_spacje(j,str); if str[j]='=' then begin // '=' nowa wartosc dla etykiety __inc(j,str); txt:=txt+'='; txt:=txt+get_dat(j,str,',',true); end else j := i; // jesli nie odczytal znaku '=' // if txt<>'' then begin // !!! inaczej nie bedzie pomijal parametrow PROC !!! // np. proc_label ,1 i:=High(par); par[i]:=txt; SetLength(par,i+2); // end; if str[j] in [',',' ',#9] then __next(j,str) else if mae and test_char(j,str,#0,#0) then Break; end; end; function TypeToByte(const a: char): byte; begin case a of 'B': Result := 1; 'W': Result := 2; 'L': Result := 3; 'D': Result := 4; else Result := 0; end; end; function ValueToType(const a: Int64): byte; begin case abs(a) of 0..$FF: Result:=1; $100..$FFFF: Result:=2; $10000..$FFFFFF: Result:=3; else Result:=4 end; end; function getByte(var pom: string; const ile: byte; const ch: Char): string; begin Result:=''; case ch of 'W': case ile of 2: pom[1]:='>'; 1: pom[1]:='<'; end; 'L': case ile of 3: pom[1]:='^'; 2: pom[1]:='>'; 1: pom[1]:='<'; end; 'D': case ile of 4: Result:='>>24'; 3: pom[1]:='^'; 2: pom[1]:='>'; 1: pom[1]:='<'; end; end; end; function oblicz_mnemonik(var i:integer; var a,old:string): int5; (*----------------------------------------------------------------------------*) (* funkcja zwraca wartosc typu INT5 *) (* INT5.L -> liczba bajtow *) (* INT5.H -> kod maszynowy mnemonika, ARGUMENTY *) (*----------------------------------------------------------------------------*) var j, m, idx, len: integer; op_, mnemo, mnemo_tmp, zm, tmp, str, pom, add: string; war, war_roz, help: Int64; code, ile, k, byt: byte; op, siz: char; test, zwieksz, incdec, mvnmvp, mSEP, mREP, pomin, opty, isvar: Boolean; branch_run: Boolean; tryb: cardinal; hlp: int5; par: _strArray; const maska: array [1..23] of cardinal=( $01,$02,$04,$08,$10,$20,$40,$80,$100,$200,$400,$800,$1000,$2000, $4000,$8000,$10000,$20000,$40000,$80000,$100000,$200000,$400000); addycja: array [1..24] of byte=( 0,0,4,8,8,12,16,20,20,24,28,44,0,0,8,4,8,16,20,24,24,32,32,32); addycja_16: array [1..207] of byte=( 0,0,0,2,2,4,6,8,8,12,14,16,17,18,20,20,22,24,28,30,32,34,48, 0,0,0,2,2,8,6,4,8,16,14,16,17,18,24,24,22,32,32,30,32,34,48, 0,0,0,0,0,0,0,0,0,0,2,0,0,0,0,0,0,0,0,0,0,0,220, 0,0,0,0,0,0,0,0,0,0,16,0,0,0,0,0,0,0,0,0,32,144,48, 0,0,0,0,0,0,0,101,0,8,0,0,0,0,16,0,0,0,24,0,0,0,0, 0,0,0,0,0,0,0,0,0,56,0,0,0,0,16,0,0,0,58,0,0,0,0, 0,0,0,0,0,0,0,146,0,0,0,0,114,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,140,0,0,0,148,0,0,0,0,156,0,0,0,164,0,0,0,0, 0,0,0,0,0,204,0,0,0,212,0,0,0,0,220,0,0,0,228,0,0,0,0); // kod maszynowy mnemonika w pierwszej adresacji (CPU 6502) kod: array [0..55] of byte=( $A1,$9E,$9C,$81,$82,$80,$61,$21, $02,$E1,$14,$40,$42,$01,$C1,$BC, $DC,$C2,$E2,$41,$22,$62,$00,$18, $58,$B8,$D8,$08,$28,$48,$68,$40, $60,$38,$78,$F8,$C8,$E8,$88,$CA, $8A,$98,$9A,$A8,$AA,$BA,$EA,$10, $30,$D0,$90,$B0,$F0,$50,$70,$20); // kod maszynowy mnemonika w pierwszej adresacji (CPU 65816) kod_16: array [0..91] of byte=( $A1,$9E,$9C,$81,$82,$80,$61,$21, $02,$E1,$20,$4C,$42,$01,$C1,$BC, $DC,$3A,$1A,$41,$22,$62,$00,$18, $58,$B8,$D8,$08,$28,$48,$68,$40, $60,$38,$78,$F8,$C8,$E8,$88,$CA, $8A,$98,$9A,$A8,$AA,$BA,$EA,$10, $30,$D0,$90,$B0,$F0,$50,$70,$24, $64,$DE,$BE,$10,$00,$80,$FE,$54, $44,$62,$8B,$0B,$4B,$DA,$5A,$AB, $2B,$FA,$7A,$6B,$DB,$5B,$1B,$7B, $3B,$9B,$BB,$CB,$42,$EB,$FB,$3A, $1A,$14,$4E,$80); // mozliwe adresacje rozkazu (10 bitow) CPU6502 // bity w najstarszym bajcie oznaczaja przesuniecie w tablicy 'ADDYCJA' ads: array [0..55] of cardinal=( $000006ED,$8000032C,$800004AC,$000006E5,$00000124,$000000A4,$000006ED,$000006ED, $000004B4,$000006ED,$00000020,$00000820,$000004B4,$000006ED,$000006ED,$8000002C, $8000002C,$000004A4,$000004A4,$000006ED,$000004B4,$000004B4,$00000000,$00000000, $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000, $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000, $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000002, $00000002,$00000002,$00000002,$00000002,$00000002,$00000002,$00000002,$00000024); // mozliwe adresacje rozkazu (32 bity) CPU65816 // bity w najstarszym bajcie oznaczaja przesuniecie w tablicy 'ADDYCJA_16' ads_16: array [0..91] of cardinal=( $000F7EE9,$800282A0,$800442A0,$000F7E69,$00008220,$00004220,$000F7EE9,$000F7EE9, $00044320,$000F7EE9,$40400600,$20700600,$00044320,$000F7EE9,$000F7EE9,$800002A0, $800002A0,$02044320,$01044320,$000F7EE9,$00044320,$00044320,$00000000,$00000000, $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000, $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000, $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000002, $00000002,$00000002,$00000002,$00000002,$00000002,$00000002,$00000002,$100442A0, $08044220,$80000080,$80000080,$00000220,$00000220,$00000012,$80000080,$00000004, $00000004,$04001090,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000, $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000, $00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000,$00000000, $00000000,$00000400,$00000400,$00000010); begin Result.l:=0; if a='' then blad(old,12); op_:=''; siz:=' '; op:=' '; war_roz:=0; mvnmvp:=true; mSEP:=false; mREP:=false; pomin:=false; ext_used.use:=false; zwieksz:=false; incdec:=false; reloc:=false; branch:=false; mne_used:=false; omin_spacje(i,a); m:=i; // zapamietaj pozycje // pobierz nazwe rozkazu, oblicz jego CRC16 mnemo:=''; mnemo_tmp:=''; if _lab_first(a[i]) then while _lab(a[i]) or (a[i] in [':','%']) do begin mnemo:=mnemo+UpCase(a[i]); mnemo_tmp:=mnemo_tmp+UpCas_(a[i]); inc(i); end; // asemblujemy procedury .PROC do ktorych wystapilo odwolanie w programie // przelacznik -x 'Exclude unreferenced procedures' musi byc uaktywniony if exclude_proc then if proc and (pass>0) then if not(t_prc[proc_nr-1].use) then begin if VerifyProc then begin exProcTest := false; exclude_proc:= false; Result:=oblicz_mnemonik(m,a,old); // dodatkowy test linii gdy EXCLUDE_PROC:=FALSE if Result.l<__equ then Result.l:=0; exProcTest := true; exclude_proc:= true; i:=m; end; exit; end; // jesli czytamy tablice ARRAY to linia zaczyna sie znakiem '(' lub '[' // jesli innym niz znaki konca linii to blad 'Improper syntax' if aray then begin Result.l:=__array_run; i:=1; exit end; // jesli brakuje mnemonika to sprawdz czy nie jest to cyfra (blad 'Illegal instruction') // w innym przypadku nie przetwarzamy tego i wychodzimy if mnemo='' then if _dec(a[i]) or (a[i] in ['$','%']) then blad(old,12) else exit; // wyjatek znak '=' jest rownowazny 'EQU' // dla etykiety zaczynajacej sie od pierwszego znaku w wierszu if mnemo='=' then begin Result.l:=__equ; exit end; // jesli wystepuje znak ':' tzn ze laczymy mnemoniki w stylu XASM'a j:=pos(':',mnemo); if j>0 then begin Result.i:=i; i:=m; // modyfikujemy wartosc spod adresu 'i' Result.l:=__xasm; exit; end; // sprawdz czy to operacja przypisania '=' , 'EQU' , '+=' , '-=' , '++' , '--' // dla etykiety poprzedzonej minimum jedna spacja lub tabulatorem j:=i; omin_spacje(i,a); tmp:=''; if UpCase(a[i])='E' then begin tmp:=get_datUp(i,a,#0,false); k:=fASC(tmp); end else begin while a[i] in ['=','+','-'] do begin tmp:=tmp+a[i]; if a[i]='=' then Break; __inc(i,a); end; k:=fCRC16(tmp); end; // if (tmp='EQU') or (tmp='=') or (tmp='+=') or (tmp='-=') or (tmp='++') or (tmp='--') then begin if k in [__equ+1, __nill] then begin i:=m; // modyfikujemy wartosc spod adresu 'i' Result.l:=__addEqu; exit; end; i:=j; len:=length(mnemo); // sprawdz czy wystapilo rozszerzenie mnemonika if len=5 then if a[i-2]='.' then case UpCase(a[i-1]) of 'A','W','Q': siz:='Q'; 'B','Z': siz:='Z'; 'L','T': siz:='T'; end; // poszukaj mnemonika w tablicy HASH k:=0; if len=3 then k:=fASC(mnemo) else if siz<>' ' then begin // jesli SIZ<>' ' tzn ze jest to 3-literowy mnemonik z rozszerzeniem k:=fASC(mnemo); if k>0 then SetLength(mnemo,3); // jesli taki mnemonik istnieje to OK, // !!! w przeciwnym wypadku zapewne jest to jakies makro !!! end; if not(opt and 16>0) then if k in [57..92] then k:=0; // symbole mnemonikow maja kody <1..91> // symbole mnemonikow 6502 <1..56> // symbole mnemonikow 65816 <57..92> // w IDX przechowujemy aktualny adres asemblacji, tej zmiennej nie uzyjemy w innym celu if k in [__cpbcpd..__jskip] then begin if adres<0 then if pass=pass_end then blad(old,10); if siz<>' ' then blad(old,33); if not(k in [__BckSkp, __phrplr]) then begin // __BckSkp i __phrplr nie potrzebuja parametrow omin_spacje(i,a); SetLength(par, 1); while not(test_char(i,a,#0,#0)) do begin idx:=High(par); par[idx]:=get_dat(i,a,' ',true); //if par[idx][1] in ['<','>'] then insert('#',par[idx],1); // !!! zaremowac !!! bo zle liczy "mva >$e000+3 $80" SetLength(par, idx+2); omin_spacje(i,a); end; tmp:=par[0]; end; idx := adres; Result.l:=0; case k of // obsluga PHR, PLR __phrplr: begin Result.l:=5; if mnemo[2]='H' then begin Result.h[0]:=$48; Result.h[1]:=$8a; Result.h[2]:=$48; Result.h[3]:=$98; Result.h[4]:=$48; end else begin Result.h[0]:=$68; Result.h[1]:=$a8; Result.h[2]:=$68; Result.h[3]:=$aa; Result.h[4]:=$68; end; end; // obsluga INW, INL, IND, DEW, DEL, DED __inwdew: begin if High(par)<1 then blad(old,23); Result.l:=0; ile:=TypeToByte(mnemo[3]); mnemo[3]:='C'; if mnemo[1]='I' then begin // INW, INL, IND str:='##INC#DEC'+IntToStr(ora_nr); j:=load_lab(str,false); // odczytujemy wartosc etykiety if j>=0 then tryb:=t_lab[j].adr else tryb:=0; j:=0; while ile>0 do begin zm:=mnemo + #32 + tmp + '+' + IntToStr(j); hlp:=asm_mnemo(zm,old); addResult(hlp, Result); if ile>1 then begin zm:='BNE '+IntToStr(tryb); hlp:=asm_mnemo(zm,old); addResult(hlp, Result); end; inc(j); dec(ile); end; save_fake_label(str,old, adres); inc(ora_nr); end else begin // DEW, DEL, DED byt:=0; while byt=0 then tryb:=t_lab[j].adr else tryb:=0; zm:='BNE '+IntToStr(tryb); hlp:=asm_mnemo(zm,old); addResult(hlp, Result); inc(byt); end; inc(byt); while byt<>0 do begin if byt<>ile then begin str:='##INC#DEC'+IntToStr(Int64(ora_nr)+byt-1); save_fake_label(str,old, adres); end; zm:='DEC ' + tmp + '+' + IntToStr(Int64(byt)-1); hlp:=asm_mnemo(zm,old); addResult(hlp, Result); dec(byt); end; inc(ora_nr, ile-1); end; end; // obsluga ADW, SBW __adwsbw: begin if High(par)<2 then blad(old,23); str:=par[1]; pom:=par[2]; test:=false; if pom='' then pom:=tmp // w POM wynik operacji else test:=true; if tmp[1]='#' then blad(old,14); mnemo[3] := 'C'; // ADC, SBC if mnemo[1]='S' then zm:='SEC' else zm:='CLC'; Result:=asm_mnemo(zm,old); zm:='LDA ' + tmp; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); ile:=hlp.h[0]; opty:=false; if ile=$B1 then opty:=true; // wystepuje LDA(),Y if not(ile in [$A5,$AD,$B5,$BD]) then test:=true; // nie przejdzie krotsza wersja z SCC, SCS if str[1]='#' then begin str[1]:='+'; branch:=true; // nie relokujemy, testujemy tylko wartosc war:=oblicz_wartosc(str,old); wartosc(old,war,'A'); str[1]:='<'; zm:=mnemo + #32 + str; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); zm:='STA '+pom; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); if not(test) and (war<256) then begin if mnemo[1]='S' then zm:='SCS' else zm:='SCC'; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); test_skipa; if mnemo[1]='S' then zm:='DEC ' + tmp + '+1' else zm:='INC ' + tmp + '+1'; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); end else begin if opty then begin zm:='iny'; // tylko w ten sposob przez ASM_MNEMO hlp:=asm_mnemo(zm, old); // inaczej nie bedzie relokowalnosci addResult(hlp,Result); { hlp.l:=1; hlp.h[0]:=$c8; // $C8 = INY addResult(hlp,Result);} add:=''; end else add:='+1'; zm:='LDA ' + tmp + add; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); str[1]:='>'; zm:=mnemo + #32 + str; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); zm:='STA ' + pom + add; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); end; end else begin zm:=mnemo + #32 + str; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); byt:=hlp.h[0]; zm:='STA ' + pom; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); if opty then begin zm:='iny'; hlp:=asm_mnemo(zm, old); addResult(hlp,Result); { hlp.l:=1; hlp.h[0]:=$c8; // $C8 = INY addResult(hlp,Result);} add:=''; end else add:='+1'; if byt in [$71,$F1] then begin // $71 = ADC(),Y ; $F1 = SBC(),Y if not(opty) then begin zm:='iny'; hlp:=asm_mnemo(zm, old); addResult(hlp,Result); { hlp.l:=1; hlp.h[0]:=$c8; // $C8 = INY addResult(hlp,Result);} if (ile in [$b6,$b9,$be]) then add:=''; end; end else if not(opty and (byt=$79)) then str:=str+'+1'; zm:='LDA ' + tmp + add; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); zm:=mnemo + #32 + str; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); zm:='STA ' + pom + add; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); end; case pom[length(pom)] of '+': zm:='iny'; '-': zm:='dey'; else zm:=''; end; if zm<>'' then begin hlp:=asm_mnemo(zm, old); addResult(hlp,Result); end; end; // obsluga ADB, SBB __adbsbb: begin if High(par)<2 then blad(old,23); str:=par[1]; pom:=par[2]; Result.l:=0; if pom='' then begin pom:=tmp; if tmp[1]='#' then if str[1]<>'#' then pom:=str; end; if tmp<>'@' then begin zm:='LDA ' + tmp; Result:=asm_mnemo(zm,old); end; if mnemo[1]='S' then zm:='SUB ' else zm:='ADD '; zm:=zm + str; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); if pom<>'@' then begin zm:='STA ' + pom; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); end; end; // obsluga ADD, SUB __addsub: begin if High(par)<1 then blad(old,23); inc(adres); mnemo[2]:=mnemo[3]; mnemo[3]:='C'; Result.l:=1; if mnemo[1]='A' then Result.h[0]:=$18 // kod dla CLC else Result.h[0]:=$38; // kod dla SEC zm:=mnemo + #32 + tmp; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); end; // obsluga MVA, MVX, MVY, MWA, MWX, MWY __movaxy: begin if High(par)<2 then blad(old,23); zm:=par[1]; op:=tmp[1]; Result.l:=0; opty:=false; if op='#' then regOpty.blk:=true; // wlaczamy przetwarzanie makro-rozkazow MW?#, MV?# if mnemo[2]='W' then begin // MW? if op='#' then begin variable:=false; // domyslnie VARIABLE=FALSE, czyli nie jest to zmienna tmp[1]:='+'; branch:=true; // nie relokujemy, testujemy tylko wartosc war:=oblicz_wartosc(tmp,old); wartosc(old,war,'A'); // if not(dreloc.use) and not(dreloc.sdx) then if not(variable) then // jesli nie jest to zmienna to testujemy dalej if byte(war)=byte(war shr 8) then opty:=true; tmp[1]:='<'; end; Result:=moveAXY(mnemo,tmp,zm,old); test:=false; if not(opty) then if op='#' then tmp[1]:='>' else // wyjątek MWA (ZP),Y ADR if Result.h[0]<>$B1 then begin // $B1 = LDA(ZP),Y if Result.tmp=$91 then begin if not(Result.h[0] in [$b6,$b9,$be]) then tmp:=tmp+'+1'; end else tmp:=tmp+'+1'; end else begin // $C8 = INY if Result.h[Result.l-1]<>$c8 then begin pom:='iny'; // tylko w ten sposob przez ASM_MNEMO hlp:=asm_mnemo(pom, old); // inaczej nie bedzie relokowalnosci addResult(hlp,Result); end; test:=true; end; if Result.tmp=$91 then begin // $91 = STA(ZP),Y if (Result.h[0]<>$B1) and (Result.h[Result.l-1]<>$c8) then begin pom:='iny'; hlp:=asm_mnemo(pom, old); addResult(hlp,Result); end; end else if test then begin // $96 = STX Z,Y if not(Result.tmp in [$96,$99]) then zm:=zm+'+1'; // $99 = STA Q,Y end else zm:=zm+'+1'; end; if opty then begin tmp:=mnemo + #32 + zm; hlp:=asm_mnemo(tmp, old); end else hlp:=moveAXY(mnemo,tmp,zm,old); // MV? addResult(hlp,Result); regOpty.blk:=false; // wylaczamy przetwarzanie makro-rozkazow MWA, MVA itp. end; // obsluga JEQ, JNE, JPL, JMI, JCC, JCS, JVC, JVS __jskip: begin mnemo[1]:='B'; // zamieniamy pseudo rozkaz na mnemonik k:=fASC(mnemo); // wyliczamy kod dla mnemonika branch:=true; // nie relokujemy war:=oblicz_wartosc(tmp,old); test:=false; war:=war-2-adres; if (war<0) and (abs(war)-128>0) then test:=true; if (war>0) and (war-127>0) then test:=true; if not(test) then begin Result.l:=2; Result.h[0]:=kod[k-1] {xor $20}; // kod maszynowy mnemonika w pierwszej adresacji 6502 Result.h[1]:=byte(war); end else begin inc(adres,2); Result.l:=2; Result.h[0]:=kod[k-1] xor $20; // kod maszynowy mnemonika w pierwszej adresacji 6502 Result.h[1]:=3; zm:='JMP ' + tmp; hlp:=asm_mnemo(zm,old); addResult(hlp,Result); end; end; // sprawdzamy czy nie sa to pseudo rozkazy skoku // req, rne, rpl, rmi, rcc, rcs, rvc, rvs -> b?? skok do tylu // seq, sne, spl, smi, scc, scs, svc, svs -> b?? skok do przodu __BckSkp: begin if mnemo[1]='R' then begin if (pass=pass_end) and skip.xsm then warning(99); // Repeating only the last instruction if t_bck[0]<0 then begin if pass=pass_end then blad(old,110); // No instruction to repeat war:=0; end else war:=t_bck[0]; end else begin if skip.idx+1<=High(t_skp) then war:=t_skp[skip.idx+1] else war:=adres; skip.use:=true; skip.cnt:=0; end; war:=war-2-adres; if (war<0) and (abs(war)-128>0) then war:=abs(war)-128; if (war>0) and (war-127>0) then dec(war, 127); //war:=war-127; mnemo[1]:='B'; // zamieniamy pseudo rozkaz na mnemonik k:=fASC(mnemo); // wyliczamy kod dla mnemonika code:=kod[k-1]; // kod maszynowy mnemonika w pierwszej adresacji 6502 Result.l := 2; Result.h[0] := code; Result.h[1] := byte(war); inc(adres,2); end; // CPB, CPW, CPL, CPD __cpbcpd: begin if High(par)<2 then blad(old,23); pom:=par[1]; ile:=TypeToByte(mnemo[3]); Result.l:=0; str:='##CMP#'+IntToStr(ora_nr); j:=load_lab(str,false); // odczytujemy wartosc etykiety if j>=0 then tryb:=t_lab[j].adr else tryb:=0; test := (tmp[1]='#'); opty := (pom[1]='#'); if (tmp='@') and (ile<>1) then blad(old,58); variable:=false; // domyslnie VARIABLE=FALSE, czyli nie jest to zmienna if opty then begin pom[1]:='+'; branch:=true; // nie relokujemy, testujemy tylko wartosc war:=oblicz_wartosc(pom,old); pom[1]:='#'; end; isvar:=variable or TestWhileOpt; while ile>0 do begin if test then add:=getByte(tmp, ile, mnemo[3]) else add:='+'+IntToStr(Int64(ile)-1); if tmp<>'@' then begin zm:='LDA '+tmp + add; hlp:=asm_mnemo(zm,old); addResult(hlp, Result); end; if opty then add:=getByte(pom, ile, mnemo[3]) else add:='+'+IntToStr(Int64(ile)-1); zm:='CMP '+pom + add; hlp:=asm_mnemo(zm,old); if not(isvar) and (hlp.l=2) and (hlp.h[0]=$c9) and (hlp.h[1]=0) then dec(adres, 2) // jesli CMP #0 to anuluj else addResult(hlp, Result); if ile>1 then begin zm:='BNE '+IntToStr(tryb); hlp:=asm_mnemo(zm,old); addResult(hlp, Result); end; dec(ile); end; str:='##CMP#'+IntToStr(ora_nr); save_fake_label(str,old, adres); TestWhileOpt:=true; inc(ora_nr); end; end; adres := idx; regOpty.use := ( k = __movaxy ); mne_used := true; // zostal odczytany jakis mnemonik exit; // !!! KONIEC !!! zostal odczytany i zdekodowany makro-rozkaz end; // sprawdz czy to nazwa makra if k=0 then begin idx:=load_lab(mnemo_tmp,false); // poszukaj w etykietach if idx<0 then begin if pass=pass_end then blad_und(old,mnemo,35); exit; end; if t_lab[idx].bnk=__id_ext then // symbol external if t_extn[t_lab[idx].adr].prc then begin tmp:='##'+t_extn[t_lab[idx].adr].nam; Result.i:=t_lab[l_lab(tmp)].adr; Result.l:=__proc_run; exit; end; // if (t_lab[idx].bnk=__id_macro) then begin Result.l:=__nill; exit end; if t_lab[idx].bnk>=__id_macro then begin Result.l:=byte(t_lab[idx].bnk); Result.i:=t_lab[idx].adr; end else blad_und(old,mnemo,35); exit; end; dec(k); // !!! koniecznie // znalazl pseudo rozkaz if k>=__equ then if siz<>' ' then blad(old,33) else begin Result.l:=k; exit end; if first_org and (opt and 1>0) then blad(old,10); // jesli nie przetwarzamy makro-rozkazow MWA, MVA itp. to blokujemy optymalizacje rejestrow if not(regOpty.blk) then begin regOpty.use:=false; regOpty.reg[0]:=-1; regOpty.reg[1]:=-1; regOpty.reg[2]:=-1; end; //!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!// // na podstawie kodu maszynowego CODE mozna juz okreslic jaki to rozkaz // // nie trzeba porownywac stringow, czy zamieniac mnemonik na wartosc cyfrowa // // w celu pozniejszego porownania // //!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!// if (opt and 16>0) then begin code:=kod_16[k]; // kody maszynowe 65816 sa z przedzialu <0..91> tryb:=ads_16[k]; // kod maszynowy mnemonika w pierwszej adresacji 65816 end else begin // if k>55 then blad(a,14); // kody maszynowe 6502 sa z przedzialu <0..55> code:=kod[k]; // kod maszynowy mnemonika w pierwszej adresacji 6502 tryb:=ads[k]; end; // w .STRUCT i .ARRAY nie ma mozliwosci uzywania rozkazow CPU // podobnie w bloku EMPTY (.ds) nie moga wystepowac rozkazy CPU if struct.use or aray or enum.use or empty then blad(old,58); // jesli mnemonik nie wymaga argumentu to skoncz if tryb=0 then begin if siz<>' ' then blad(old,33); test_eol(i,a,a,#0); Result.l:=1; Result.h[0]:=code; mne_used := true; // zostal odczytany jakis mnemonik exit; end; // omin spacje i przejdz do argumentu omin_spacje(i,a); // jesli wystepuja operatory #<, #> to omin pierwszy znak i pozostaw <,> { if a[i]='#' then begin // jesli odremowac to zle liczy !!! lda #>dl1^>dl2 !!! idx:=i; // !!! tak musi zostac !!! __inc(i,a); // lda #> nie moze byc tym samym co if not(a[i] in ['<','>','^']) then i:=idx; // lda > ta operacja end; } // pobierz operator argumentu do 'OP' // nie dotyczy to rozkazow MVN i MVP (65816) // tst:=ord(mnemo[1]) shl 16+ord(mnemo[2]) shl 8+ord(mnemo[3]); // if (mnemo<>'MVN') and (mnemo<>'MVP') then begin // if (tst<>$4D564E) and (tst<>$4D5650) then begin if not(code in [68,84]) then begin mvnmvp:=false; if a[i] in ['#','<','>','^'] then begin if not(dreloc.use) then branch:=true; // nie relokuj tego rozkazu op:=a[i]; inc(i) end else op:=' '; if (a[i]='@') and (_eol(a[i+1])) then begin op:='@'; inc(i) end; if (op='@') then if (siz<>' ') then blad(old,33) else test_eol(i,a,a,#0); end; omin_spacje(i,a); // wyjatki dla ktorych rozmiar rejestru jest staly if (opt and 16>0) and (op='#') then case code of 98: test_siz(a,siz,'Q',pomin); // PEA #Q 254: test_siz(a,siz,'Z',pomin); // COP #Z 190: begin test_siz(a,siz,'Z',pomin); mREP:=true end; // REP #Z 222: begin test_siz(a,siz,'Z',pomin); mSEP:=true end; // SEP #Z end; zm:=get_dat_noSPC(i,a,';',#0,old); tmp:=''; // jesli brak argumentu przyjmij domyslnie aktualny adres '*' // lub operator '@' gdy ASL , ROL , LSR , ROR // lub operator '@' dla INC, DEC gdy CPU=65816 if (zm='') and (op=' ') then begin if (code in [2,34,66,98]) or ((opt and 16>0) and (code in [26,58])) then op:='@' else begin zm:='*'; if not(klamra_used) then if pass=0 then blad(old,23); // 'Default addressing mode' -67- wycofany end; end; // jesli jest nawias otwierajacy '(' lub '[' to sprawdz poprawnosc // i czy nie ma miedzy nimi spacji if zm<>'' then begin j:=1; if (op=' ') and (zm[1] in ['[','(']) then begin tmp:=get_dat_noSPC(j,zm,',',#0,a); if length(tmp)=2 then blad(old,14); // nie bylo argumentu pomiedzy nawiasami // jesli po nawiasie wystapi znak inny niz ',',' ',#0 to BLAD omin_spacje(j,zm); test_eol(j,zm,a,','); // przepisz znak nastepujacy po ',' do 'OP_' if zm[j]=',' then begin __inc(j,zm); if test_param(j,zm) then begin Result.l:=__nill; exit end else if UpCase(zm[j]) in ['X','Y','S'] then begin op_:=op_+UpCase(zm[j]); //zm[j]:=' '; if zm[j+1] in ['+','-'] then begin if UpCase(zm[j])='S' then blad(old,4); // + - nie moze byc dla 'S' incdec:=true; case zm[j+1] of '-': //war_roz:=oblicz_wartosc('{de'+zm[j]+'}',a); if UpCase(zm[j])='X' then war_roz:=$CA else war_roz:=$88; // dex, dey '+': //war_roz:=oblicz_wartosc('{in'+zm[j]+'}',a); if UpCase(zm[j])='X' then war_roz:=$E8 else war_roz:=$C8; // inx, iny end; test_eol(j+2,zm,a,#0); end else test_eol(j+1,zm,a,#0); end else blad(old,14); end; // usun z ciagu znaki '()' lub '[]' i przepisz do 'OP_' op_:=op_+zm[1]; zm:=copy(tmp,2,length(tmp)-2); j:=1; end; tmp:=get_dat_noSPC(j,zm,',',#0,a); // teraz jesli wystapi znak inny niz ',' to BLAD case op of '#','<','>','@','^': test_eol(j,zm,a,#0); else test_eol(j,zm,a,','); end; // przepisz znak nastepujacy po ',' do 'OP_', jesli jest to 'XYS' // w przeciwnym wypadku wylicz wartosc po przecinku if zm[j]=',' then if mvnmvp then begin // inc(j); __inc(j,zm); str:=get_dat(j,zm,' ',true); war_roz:=oblicz_wartosc(str,a); op_:=op_+value_code(war_roz,a,true); end else begin __inc(j,zm); if test_param(j,zm) then begin Result.l:=__nill; exit end else if UpCase(zm[j]) in ['X','Y','S'] then begin op_:=op_+UpCase(zm[j]); if zm[j+1] in ['+','-'] then begin if _eol(zm[j+2]) then begin if UpCase(zm[j])='S' then blad(old,4); // + - nie moze byc dla 'S' incdec:=true; case zm[j+1] of '-': //war_roz:=oblicz_wartosc('{de'+zm[j]+'}',a); if UpCase(zm[j])='X' then war_roz:=$CA else war_roz:=$88; // dex, dey '+': //war_roz:=oblicz_wartosc('{in'+zm[j]+'}',a); if UpCase(zm[j])='X' then war_roz:=$E8 else war_roz:=$C8; // inx, iny end; inc(j,2); end else begin zwieksz:=true; inc(j); war_roz:=___wartosc_noSPC(zm,a,j,#0,'F'); end; end else inc(j); end else blad(old,14); end; // end; test_eol(j,zm,a,#0); end; // jesli to rozkaz skoku lub PEA to nie relokujemy (BRANCH=TRUE) 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 branch:=true; branch_run:=true; end else branch_run:=false; if adres<0 then if pass=pass_end then blad(old,10); // adres<0 na pewno nie bylo ORG'a // oblicz wartosc argumentu mnemonika, jesli brak argumentu to 'WAR=0' war:=0; if not((tmp='') and (op='#')) then if op<>'@' then war:=oblicz_wartosc(tmp,old); if zwieksz then inc(war, war_roz); //war:=war+war_roz; op_:=op_+value_code(war,a,true); if mvnmvp then war:=war_roz + byte(war) shl 8; (*----------------------------------------------------------------------------*) (* wyjatki dotycza skokow warunkowych B?? (6502) ; BRA, BRL, PEA (65816) *) (*----------------------------------------------------------------------------*) if branch_run then begin op_:='B'; if siz<>' ' then if siz='Q' then op_:='W' else if siz<>'Z' then blad(old,31); j:=adrMode(op_); // dowiemy sie ktory to tryb adresowania war:=war-2-adres; if tryb and maska[j]=2 then idx:=128 else begin op_:='W'; if siz<>' ' then if siz<>'Q' then blad(old,31); dec(war); idx:=65536; end; test:=false; if (war<0) and (abs(war)-idx>0) then begin war:=abs(war)-idx; test:=true end; if (war>0) and (war-idx+1>0) then begin war:=war-idx+1; test:=true end; if (pass=pass_end) and test then blad(old,integer(-war)); end; // na podstawie 'OP' okresl adresacje 'OP_' case op of '#','<','>','^': op_:='#'; '@': op_:='@'; end; // znajdz obliczona adresacje w tablicy 'adresacja' // oraz sprawdz czy dla tego mnemonika jest mozliwa ta adresacja // // jesli nie znalazl to zmien rodzaj argumentu Z->Q // jesli 65816 to wstaw znak '~' if (opt and 16>0) then op_:='~'+op_; len:=length(op_); // jesli rozkaz relokowalny (RELOC=TRUE) wymus rozmiar 'Q' if reloc and not(dreloc.use) then if siz='T' then blad(old,12) else if not(op in ['<','>','^']) then siz:='Q'; // jesli wystapila etykieta external (EXT_USED.USE=TRUE) wymus rozmiar EXT_USED.SIZ if ext_used.use and (ext_used.siz in ['B','W','L']) then begin if op='^' then blad(old,85); if op in ['<','>'] then begin t_ext[ext_idx-1].typ:=op; ext_used.siz:='B'; if op='>' then t_ext[ext_idx-1].lsb:=byte(war); end; case ext_used.siz of 'B': siz:='Z'; 'W': siz:='Q'; 'L': siz:='T'; end; end; // sprawdz czy wystapilo rozszerzenie mnemonika // zmodyfikuj wielkosc operandu na podstawie 'SIZ' if siz<>' ' then case op_[len] of 'Q': if siz<>'Z' then op_[len]:=siz else if pass=pass_end then blad(old,31); 'T': if not(siz='T') then if pass=pass_end then blad(old,31); '#': if siz='T' then blad(old,14) else if (siz='Z') and (abs(war)>$FF) then blad(old,31); 'Z': op_[len]:=siz; end; j:=adrMode(op_); while (j=0) or (tryb and maska[j]=0) do begin case op_[len] of // zmien rozmiar operandu 'Z': op_[len]:='Q'; 'Q': op_[len]:='T'; else if pass=pass_end then blad(old,14) else Break; end; // sprawdz czy nowy operand nie kloci sie z zadeklarowanym rozmiarem if (siz<>' ') and (pass=pass_end) then if not(siz=op_[len]) then blad(old,31); j:=adrMode(op_); // sprawdz czy dla nowego rozmiaru operandu istnieje tryb adresowania end; if opt and 16>0 then begin ile:=0; for k:=8 downto 1 do if ((tryb shr 24) and maska[k]>0) then ile:=byte( (9-k)*23 ); { if tryb and $80000000>0 then ile:=23; if tryb and $40000000>0 then ile:=2*23; if tryb and $20000000>0 then ile:=3*23; if tryb and $10000000>0 then ile:=4*23; if tryb and $08000000>0 then ile:=5*23; if tryb and $04000000>0 then ile:=6*23; if tryb and $02000000>0 then ile:=7*23; if tryb and $01000000>0 then ile:=8*23;} inc(code, addycja_16[j+ile]) //code:=byte( code+addycja_16[j+ile] ) end else if (tryb and $80000000>0) then inc(code, addycja[j+12]) //code:=code+addycja[j+12] else inc(code, addycja[j]); //code:=code+addycja[j]; // obliczenie wartosci 'WAR' na podstawie 'OP' // WAR moze byc dowolna wartoscia typu D-WORD help:=war; if dreloc.use and rel_used then dec(help,rel_ofs); case op of '<': war := byte( wartosc(a,help,'D') ); '>': begin war := byte( wartosc(a,help,'D') shr 8 ); _sizm( byte(help) ) end; '^': begin war := byte( wartosc(a,help,'D') shr 16 ); _sizm( byte(help) ) end; end; // policz z ilu bajtow sklada sie rozkaz wraz z argumentem ile:=1; if not(mvnmvp) then if incdec then begin inc(ile); case op_[len] of 'Z': war := war + byte(war_roz) shl 8; 'Q': war := war + byte(war_roz) shl 16; 'T': war := war + byte(war_roz) shl 24; end; end; if op_='~ZZ' then inc(ile,2) else case op_[len] of '#': begin if siz=' ' then siz:=value_code(war,a,false); case siz of 'Z': begin war:=wartosc(a,war,'B'); inc(ile) end; 'Q': if (opt and 16=0) then blad(old,0) else begin war:=wartosc(a,war,'A'); inc(ile,2) end; end; end; 'Z','B': inc(ile); 'Q','W': inc(ile,2); 'T': inc(ile,3); end; // okreslamy rozmiar relokowalnego argumentu B,W,L,<,> if dreloc.use and rel_used then begin case op_[len] of '#': if (op in ['<','>','^']) then dreloc.siz:=op; 'Z','B': dreloc.siz:=relType[1]; 'Q','W': dreloc.siz:=relType[2]; 'T': dreloc.siz:=relType[3]; end; if not(ext_used.use) then dec(war,rel_ofs); // nie wolno modyfikowac argumentu symbolu EXTERNAL _siz(true); rel_used:=false; end; // tutaj przeprowadzamy operacje sledzenia rozmiaru rejestrow A,X,Y // modyfikowanych przez rozkazy REP, SEP if (opt and $40>0) and (pass=pass_end) and macro_rept_if_test then begin // wlaczona opcja sledzenia rozkazow SEP, REP if mSEP then reg_size( byte(war),true ) else if mREP then reg_size( byte(war),false ); // sprawdzamy rozmiar rejestrow dla trybu adresowania natychmiastowego '#' if not(pomin) then if op_[len]='#' then case mnemo[3] of 'A','C','D','P','R','T': test_reg_size(a,regA,ile); // lda, adc, sbc, and, cmp, ror, bit 'X': test_reg_size(a,regX,ile); // ldx 'Y': test_reg_size(a,regY,ile); // ldy end; end; // preparujemy wynik, rozkaz CPU + argumenty Result.l := ile; Result.h[0] := code; Result.h[1] := byte(war); Result.h[2] := byte(war shr 8); Result.h[3] := byte(war shr 16); Result.h[4] := byte(war shr 24); mne_used := true; // zostal odczytany jakis mnemonik end; function reserved(var ety: string): Boolean; var v: byte; begin v:=fASC(ety); Result := (v in [$80..$9f]); // PSEUDO if Result then exit; if opt and 16>0 then Result := (v in [1..92]) // 65816 else Result := (v in [1..56]); // 6502 end; procedure reserved_word(var ety, zm: string{; const skip: Boolean}); (*----------------------------------------------------------------------------*) (* testuj czy nie zostala uzyta zarezerwowana nazwa, np. nazwa pseudorozkazu *) (* lub czy nazwa zostala juz wczesniej uzyta *) (*----------------------------------------------------------------------------*) begin if ety[1]='?' then warning(8); if length(ety)=3 then if reserved(ety) then blad_und(zm,ety,9); if rept then blad(zm,51); //if skip and proc then blad(zm,17); if load_lab(ety,true)>=0 then blad_und(zm,ety,2); // nazwa w uzyciu end; procedure create_struct_variable(var zm,ety: string; var mne: int5; const head: Boolean; var adres: integer); (*----------------------------------------------------------------------------*) (* wykonaj .STRUCT (np. deklaracja pola struktury za pomoca innej struktury) *) (* możliwe jest przypisanie pol zdefiniowanych przez strukture nowej zmiennej*) (*----------------------------------------------------------------------------*) var indeks, _doo, j, k, idx: integer; txt, str: string; begin indeks:=mne.i; if mne.l=__enum_run then begin save_lst('a'); for k:=0 to indeks-1 do save_dst(0); inc(adres, indeks); exit; end; // sprawdzamy czy struktura nie wywoluje sama siebie if t_str[indeks].lab+'.'=lokal_name then blad(zm,57); _doo := adres-struct.adres; if mne.l=__struct_run then if struct.use then save_lab(ety, _doo, bank, zm) // nowe pole w strukturze else save_lab(ety, adres, bank, zm); // definicja zmiennej typu strukturalnego save_lst('a'); // odczytujemy liczbe pol struktury k:=t_str[indeks].ofs; inc(indeks); for idx:=indeks to indeks+k-1 do begin txt:=t_str[idx].lab; if mne.l=__struct_run_noLabel then str:=txt else begin //_odd:=pos('.',txt); //??? //if _odd>0 then txt:=copy(txt,_odd,length(txt)); //??? if txt[1]<>'.' then txt:='.'+txt; str:=ety+txt; end; j:=t_str[idx].siz; if struct.use then begin k:=t_str[idx].ofs+_doo; // konieczna operacja, bo STRUCT.ADRES nie zostal zwiekszony save_str(str,k,j,1,adres,bank); // tutaj zwiekszony zostaje STRUCT.ADRES save_lab(str,adres-struct.adres,bank,zm); // tutaj operujemy na nowej wartosci STRUCT.ADRES inc(struct.cnt); // zwiekszamy licznik pol w strukturze end else begin save_lab(str,adres,bank,zm); if dreloc.use or dreloc.sdx then for k:=0 to j-1 do save_dst(0) else if head then new_DOS_header; // wymuszamy zapis naglowka DOS-a end; inc(adres, j); end; end; procedure create_struct_data(var i: integer; var zm, ety: string; v: byte); (*----------------------------------------------------------------------------*) (* dla DTA STRUCT_NAME [EXPRESSION] tworzymy dane typu strukturalnego *) (*----------------------------------------------------------------------------*) var _doo, _odd, k, idx: integer; war: Int64; tmp: string; begin struct_used.use:=false; _odd:=adres; war:=adres; _doo:=bank; k:=bank; save_lst('a'); if v>=__byte then dec(v, __byteValue) else v:=1; test_skipa; oblicz_dane(i,zm,zm,v); // jesli stworzylismy strukture to odpowiednio zapamietaj // jej dane, adres, stworzyciela itp. if struct_used.use then begin if ety='' then blad(zm,15); if (pass<2) and (ety[1]='?') then warning(8); idx:=load_lab(ety,true); // jesli etykieta byla juz zadeklarowana i to jest PASS=0 // tzn ze mamy blad LABEL DECLARED TWICE if (pass=0) and (idx>=0) then blad_und(zm,ety,2); _doo:=__dta_struct; if t_lab[idx].bnk=__dta_struct then begin // wystapila juz ta deklaracja danych strukturalnych _odd:=t_lab[idx].adr; t_str[_odd].adr := cardinal( war ); t_str[_odd].bnk := integer( k ); end else begin // w TMP tworzymy nazwe uwzgledniającą lokalnosc 'TMP:= ??? + ETY' if run_macro then tmp:=macro_nr+{lokal_name+}ety else if proc then tmp:=proc_name+lokal_name+ety else tmp:=lokal_name+ety; // nie wystapila jeszcze ta deklaracja danych strukturalnych save_str(tmp,struct_used.cnt,0,1, integer(war), integer(k)); _odd:=loa_str(tmp, struct.id); t_str[_odd].idx:=struct_used.idx; end; end; save_lab(ety,cardinal(_odd),integer(_doo),zm); // zapisujemy etykiete normalnie poza strukturą end; procedure oddaj_var; var i, y, x: integer; txt, tmp: string; old_run_macro: Boolean; mne: int5; begin if var_idx>0 then begin old_run_macro := run_macro; run_macro := false; tmp:=''; for i:=0 to var_idx-1 do if t_var[i].lok = end_idx then begin // zmienne odkladamy w odpowiednim obszarze lokalnym txt := t_var[i].nam; // nazwa zmiennej .VAR if t_var[i].adr>=0 then // zmienne .VAR z okreslonym adresem umiejscowienia nul.i:=t_var[i].adr else nul.i:=adres; // zmienne .VAR alokowane dynamicznie if nul.i<0 then blad(global_name,87); // Undefined variable address save_lst('l'); case t_var[i].typ of 'V': begin save_lab(txt,nul.i,bank,txt); if t_var[i].adr<0 then // T_VAR[I].ADR<0 oznacza brak okreslonej wartosci for y:=t_var[i].cnt-1 downto 0 do save_dta(t_var[i].war , tmp , tType[t_var[i].siz] , 0); end; 'S': begin y:=load_lab(t_var[i].str, false); mne.i:=t_lab[y].adr; // znajdz indeks do struktury mne.l:=byte(__struct_run); if t_var[i].zpv or (t_var[i].adr>=0) then begin // jesli .ZPVAR lub okreslony adres x:=t_var[i].adr; create_struct_variable(txt, txt, mne, false, x); end else create_struct_variable(txt, txt, mne, true, adres); end; end; tmp:=txt; zapisz_lst(txt); t_var[i].lok:=-1; end; nul.i:=0; save_lst(' '); // koniecznie musi to tutaj byc run_macro := old_run_macro; end; end; procedure add_blok(var a: string); begin inc(blok); if blok>$FF then blad(a,45); end; procedure save_blk(const kod:integer; var a:string; const h:Boolean); (*----------------------------------------------------------------------------*) (* BLK UPDATE ADDRESS *) (*----------------------------------------------------------------------------*) var x, y, i, j, k: integer; hea_fd, hea_fe, ok, tst: Boolean; txt: string; begin txt:=a; for k:=blok downto 0 do begin hea_fd:=false; ok:=false; // szukaj w glownym bloku for y:=0 to rel_idx-1 do if t_rel[y].idx=kod then if t_rel[y].blo=0 then if t_rel[y].blk=k then begin if not(hea_fd) then begin if h then begin save_lst('a'); save_dstW( $fffd ); save_dst( byte(K) ); save_dstW( $0000 ); zapisz_lst(txt); end; hea_fd:=true; ok:=true; end; save_lst('a'); save_dst($fd); save_dstW( t_rel[y].adr ); // save_dst(byte(t_rel[y].adr shr 8)); zapisz_lst(txt); t_rel[y].idx:=-100; // wylacz z poszukiwan end; // szukaj w blokach relokowalnych for x:=1 to blok do begin hea_fe:=false; j:=0; tst:=false; for y:=0 to rel_idx-1 do if t_rel[y].idx=kod then if t_rel[y].blo=x then if t_rel[y].blk=k then begin if not(tst) then begin save_lst('a'); tst:=true; end; if not(hea_fe) then begin if not(hea_fd) and h then begin save_dstW( $fffd ); save_dst( byte(K) ); save_dstW( $0000 ); hea_fd:=true; end; save_dst($fe); save_dst(byte(x)); hea_fe:=true; ok:=true; end; j:=t_rel[y].adr-j; if j>=$fa then for i:=0 to (j div $fa)-1 do begin save_dst($ff); dec(j,$fa); end; save_dst(byte(j)); j:=t_rel[y].adr; t_rel[y].idx:=-100; // wylacz z poszukiwan end; if tst then zapisz_lst(txt); end; if ok then begin save_lst('a'); save_dst($fc); zapisz_lst(txt); end; end; end; function get_pubType(var txt,zm:string; var _odd:integer): byte; (*----------------------------------------------------------------------------*) (* odczytujemy typ etykiety public, _ODD = indeks do etykiety w tablicy T_LAB *) (*----------------------------------------------------------------------------*) begin Result:=0; _odd:=load_lab(txt,false); if _odd<0 then blad_und(zm,txt,73); // symbolami publicznymi nie moga byc etykiety przypisane do // SMB, STRUCT, PARAM, EXT, MACRO if t_lab[_odd].bnk>=__id_param then begin Result := byte( t_lab[_odd].bnk ); if not( Result in [__proc_run, __array_run, __struct_run]) then blad_und(zm,txt,103); end; end; function get_smb(var i:integer; var zm:string): string; (*----------------------------------------------------------------------------*) (* pobieramy 8 znakowy symbol SMB *) (*----------------------------------------------------------------------------*) var txt: string; x: integer; begin txt:=get_string(i,zm,zm,true); if length(txt)>8 then blad(zm,44); // za dluga nazwa etykiety while length(txt)<8 do txt:=txt+' '; // wyrownaj do 8 znakow for x:=1 to 8 do txt[x]:=UpCase(txt[x]); Result:=txt; end; procedure blk_update_new(var i:integer; var zm:string); var txt, str: string; war, k: integer; begin txt:=zm; zapisz_lst(txt); str:=''; omin_spacje(i,zm); txt:=get_dat(i,zm,' ',true); if txt='' then blad(zm,23); if test_symbols then for war:=High(t_sym)-1 downto 0 do if txt=t_sym[war] then begin blad_und(zm,txt,2); exit end; war:=l_lab(txt); if war<0 then blad_und(zm,txt,5); k:=t_lab[war].blk; if k=0 then blad(zm,53); save_lst('a'); // dta a($fffc),b(blk_num),a(smb_off) // dta c'SMB_NAME' save_dstW( $fffc ); save_dst(byte(k)); save_dstW( t_lab[war].adr ); // save_dst(byte(t_lab[war].adr shr 8)); zapisz_lst(str); save_lst('a'); txt:=get_smb(i,zm); for k:=1 to 8 do save_dst( ord(txt[k]) ); zapisz_lst(txt); bez_lst:=true; end; procedure oddaj_sym; var txt: string; i, k: integer; begin if sym_idx>0 then begin if adres<0 then blad(global_name,10); test_symbols := false; for i:=sym_idx-1 downto 0 do begin // preparujemy linie dla NEW SYMBOL txt:='BLK UPDATE NEW ' + t_sym[i] + ' ' + '''' + t_sym[i] + ''''; save_lst('a'); k:=16; blk_update_new(k,txt); end; end; end; procedure blk_empty(const idx: integer; var zm: string); var indeks, tst: cardinal; _doo: integer; txt: string; begin txt:=zm; save_lst('a'); add_blok(zm); // a($fffe),b(blk_num),b(blk_id) // a(blk_off),a(blk_len) save_dstW( $fffe ); save_dst(byte(blok)); save_dst(memType or $80); save_dstW( adres ); //save_dst(byte(adres shr 8)); save_dstW( idx ); //save_dst(byte(idx shr 8)); // jesli deklaracja etykiet wystapila przed blokiem EMPTY // znajdz je i popraw im numer bloku indeks:=adres; tst:=adres+idx; for _doo:=0 to High(t_lab)-1 do if (t_lab[_doo].adr>=indeks) and (t_lab[_doo].adr<=tst) then t_lab[_doo].blk:=blok; zapisz_lst(txt); end; procedure oddaj_ds; var zm, txt: string; begin if ds_empty>0 then begin dec(adres, ds_empty); zm:='BLK EMPTY'; if dreloc.sdx then begin // dreloc.sdx BLOK EMPTY blk_empty(ds_empty, zm); end else begin // dreloc.use BLOK EMPTY save_lst('a'); save_dstW( __hea_address ); save_dst( byte('E') ); save_dstW( 1 ); // word(adres - rel_ofs) ); save_dstW( ds_empty ); txt:=zm; zapisz_lst(txt); end; ds_empty:=0; end; end; procedure blk_update_symbol(var zm:string); var txt: string; k: byte; _doo: integer; begin if smb_idx>0 then begin txt:=zm; zapisz_lst(txt); for _doo:=0 to smb_idx-1 do if t_smb[_doo].use then begin save_lst('a'); // a($fffb),c'SMB_NAME',a(blk_len) save_dstW( $fffb ); txt:=t_smb[_doo].smb; for k:=1 to 8 do save_dst( ord(txt[k]) ); save_dstW( $0000 ); zapisz_lst(txt); save_blk(_doo,txt,false); end; bez_lst:=true; // smb_idx:=0; end; end; procedure blk_update_address(var zm:string); var txt: string; idx, i, _odd: integer; v: byte; ch: Boolean; tst: cardinal; begin if not(dreloc.use) then save_blk(-1,zm,true) // dla bloku Sparta DOS X else begin txt:=zm; zapisz_lst(txt); // naglowek $FFEF, typ, liczba adresow, adresy { if rel_idx>0 then begin Writeln(rel_idx); for i:=0 to rel_idx-1 do 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)); end; } for i:=1 to sizeof(relType) do begin // dostepne typy B,W,L,D,<,>,^ ch:=false; for idx:=0 to rel_idx-1 do if t_siz[t_rel[idx].idx].siz=relType[i] then begin ch:=true; Break end; if ch then begin save_lst('a'); // A(HEADER = $FFEF) save_dstW( __hea_address ); // najpierw zapiszemy do bufora aby dowiedziec sie ile ich jest // maksymalnie mozemy zapisac $FFFF adresow _odd:=0; // old_case:=false; // jesli bank=0 to FALSE for idx:=0 to rel_idx-1 do if t_siz[t_rel[idx].idx].siz=relType[i] then begin // if t_rel[idx].bnk>0 then old_case:=true; // jesli bank>0 to TRUE tst:= (t_rel[idx].adr and $FFFF) or (t_siz[t_rel[idx].idx].lsb shl 16); t_tmp[_odd] := tst; inc(_odd); testRange(zm, _odd, 13); // koniecznie blad 13 aby natychmiast zatrzymac end; v:=ord(relType[i]); //if old_case then v:=v or $80; save_dst(v); // TYPE //+ MODE zapisz_lst(txt); save_lst('a'); // zapisujemy informacje o liczbie adresow DATA_LENGTH save_dstW( _odd ); // teraz zapisujemy informacje o adresach for idx:=0 to _odd-1 do begin // bank etykiety external jesli MODE=1 // if old_case then save_dst( byte(t_tmp[idx] shr 16) ); // adres do relokacji save_dstW( t_tmp[idx] ); case relType[i] of '>': save_dst( byte(t_tmp[idx] shr 16) ); '^': blad(zm,27); end; end; zapisz_lst(txt); end; //if ch then begin end; end; bez_lst:=true; first_org:=true; end; procedure blk_update_external(var zm:string); var txt: string; idx, _doo, _odd, i: integer; v: byte; ch: Boolean; tst: cardinal; const typExt: array [0..2] of char = (#0,'<','>'); begin if dreloc.sdx then exit; if not(dreloc.use) then blad(zm,53); if extn_idx>0 then begin txt:=zm; zapisz_lst(txt); save_lst('a'); { Writeln(ext_idx); for i:=0 to ext_idx-1 do Writeln(hex(t_ext[i].adr,4),',',t_extn[t_ext[i].idx].nam); } for _doo:=0 to extn_idx-1 do begin for i:=0 to 2 do begin ch:=false; for idx:=0 to ext_idx-1 do if (t_ext[idx].idx=_doo) and (t_ext[idx].typ=typExt[i]) then begin ch:=true; Break end; if ch then begin // czy wystapily w programie odwolania do etykiet external save_lst('a'); // A(HEADER = $FFEE),b(TYPE) save_dstW( __hea_external ); // najpierw zapiszemy do bufora aby dowiedziec sie ile ich jest // maksymalnie mozemy zapisac $FFFF adresow i ich numerow bankow _odd:=0; // old_case:=false; // jesli bank=0 to FALSE for idx:=0 to ext_idx-1 do if (t_ext[idx].idx=_doo) and (t_ext[idx].typ=typExt[i]) then begin // if t_ext[idx].bnk>0 then old_case:=true; // jesli bank>0 to TRUE tst:= (t_ext[idx].adr and $FFFF) or (t_ext[idx].lsb shl 16) {(t_ext[idx].bnk shl 16)}; t_tmp[_odd] := tst; inc(_odd); testRange(zm, _odd, 13); // koniecznie blad 13 aby natychmiast zatrzymac end; if typExt[i]=#0 then v:=ord(t_extn[_doo].siz) //if old_case then v:=v or $80; else v:=ord(typExt[i]); save_dst(v); // ext_label TYPE //+ MODE zapisz_lst(txt); save_lst('a'); // zapisujemy informacje o liczbie adresow save_dstW( _odd ); // A(EXT_LABEL_LENGTH) , C'EXT_LABEL' txt:=t_extn[_doo].nam; save_dstS(txt); // ext_label length, string // teraz zapisujemy informacje o adresach for idx:=0 to _odd-1 do begin // bank etykiety external // if old_case then save_dst( byte(t_tmp[idx] shr 16) ); // adres etykiety external save_dstW( t_tmp[idx] ); if typExt[i]='>' then save_dst( byte(t_tmp[idx] shr 24) ); end; zapisz_lst(txt); end; //for i:=0 to 3 do begin end; //if ch then begin end; // extn_idx:=0; bez_lst:=true; end; end; procedure blk_update_public(var zm:string); var txt, ety, str, tmp: string; x, idx, j, k, indeks, _odd, _doo, i, len, old_rel_idx, old_siz_idx: integer; sid, sno, six: integer; v, sv: byte; ch, tp: char; test: Boolean; war: Int64; old_sizm0, old_sizm1: rSizTab; begin if dreloc.sdx then exit; if pub_idx>0 then begin txt:=zm; zapisz_lst(txt); save_lst('a'); _odd:=0; _doo:=-1; // test obecnosci etykiet publicznych oraz test parametrow procedur __pVar for idx:=pub_idx-1 downto 0 do begin txt:=t_pub[idx].nam; v := get_pubType(txt,zm, _odd); // dodajemy do upublicznienia parametry procedury __pVar // pod warunkiem ze ich wczesniej jeszcze nie upublicznialismy if v = __proc_run then if t_prc[t_lab[_odd].adr].typ = __pVar then begin k:=t_prc[t_lab[_odd].adr].par; // liczba parametrow indeks:=t_prc[t_lab[_odd].adr].str; if k>0 then for j:=0 to k-1 do begin ety:=t_par[j+indeks]; // omijamy pierwszy znak okreslajacy typ parametru // i czytamy az nie napotkamy znakow nie nalezacych do nazwy etykiety str:=''; i:=2; len:=length(ety); while i<=len do begin if _lab(ety[i]) then str:=str+ety[i] else Break; inc(i); end; // str:=copy(ety,2,length(ety)); // poprawiamy nazwe parametru _doo:=l_lab(str); test:=false; for x:=pub_idx-1 downto 0 do if t_pub[x].nam=str then begin test:=true; Break end; if (_doo>=0) and not(test) then // dopisujemy do T_PUB jesli nie zostala wczesniej upubliczniona if (t_lab[_doo].bnk<>__id_ext) {and not(test)} then save_pub(str,zm); end; if _doo<0 then blad_und(zm,str,5); end; end; // okreslamy typ etykiety PUBLIC, czy jest relokowalna branch:=false; // umożliwiamy relokowalnosc old_rel_idx := rel_idx; old_siz_idx := siz_idx; old_sizm0 := t_siz[siz_idx]; old_sizm1 := t_siz[siz_idx-1]; for _odd:=pub_idx-1 downto 0 do begin txt:=t_pub[_odd].nam; reloc:=false; oblicz_wartosc(txt,zm); t_pub[_odd].typ := reloc; end; branch:=true; // blokujemy relokowalnosc rel_idx := old_rel_idx; siz_idx := old_siz_idx; t_siz[siz_idx] := old_sizm0; t_siz[siz_idx-1] := old_sizm1; { Writeln(pub_idx); for x:=0 to pub_idx-1 do Writeln(t_pub[x].nam,',',t_pub[x].typ); } // A(HEADER = $FFED) , a(LENGTH) save_dstW( __hea_public ); save_dstW( pub_idx ); for idx:=0 to pub_idx-1 do begin txt:=t_pub[idx].nam; ety:=txt; save_lst('a'); v := get_pubType(txt,zm, _odd); // V to typ, _ODD to indeks do T_LAB case v of __proc_run: ch:='P'; // P-ROCEDURE __array_run: ch:='A'; // A-RRAY __struct_run: ch:='S'; // S-TRUCT else if t_pub[idx].typ then ch := 'V' // V-ARIABLE else ch := 'C'; // C-ONSTANT end; tp:='W'; if ch='C' then begin // type B-YTE, W-ORD, L-ONG, D-WORD war:=t_lab[_odd].adr; tp:=relType [ ValueToType(war) ]; save_dst(ord(tp)); // type end else save_dst( byte('W') ); // type W-ORD dla V-ARIABLE, P-ROCEDURE, A-RRAY, S-TRUCT save_dst(ord(ch)); // label_type V-ARIABLE, C-ONSTANT, P-ROCEDURE, A-RRAY, S-TRUCT save_dstS(txt); // label_name [length + atascii] case v of __proc_run: k:=t_prc[t_lab[_odd].adr].adr; // PROC address __array_run: k:=t_arr[t_lab[_odd].adr].adr; // ARRAY address __struct_run: k:=t_str[t_lab[_odd].adr].ofs; // liczba pol STRUCT else k:=t_lab[_odd].adr; // variable address end; if not(ch in ['C','S']) then dec(k,rel_ofs); // wartosci C-ONSTANT i S-TRUCT nie modyfikujemy for sv:=1 to TypeToByte(tp) do begin // wartosc zmiennej, stalej lub procedury save_dst( byte(k) ); // o rozmiarze TP (B-YTE, W-ORD, L-ONG, D-WORD) k := k shr 8; end; // S-TRUCT if v = __struct_run then begin sid:=t_str[t_lab[_odd].adr].id; sno:=t_str[t_lab[_odd].adr].ofs; for j:=0 to sno-1 do begin six:=loa_str_no(sid, j); txt:=t_str[six].lab; save_dst ( byte( relType[t_str[six].siz] ) ); save_dstS ( txt ); save_dstW ( word(t_str[six].rpt) ); { write(t_str[six].lab); // nazwa struktury write(',',t_str[six].ofs); // ofset lub liczba pol struktury write(',',t_str[six].siz); // dlugosc calkowita w bajtach write(',',hex(t_str[six].rpt,4)); writeln(',',t_str[six].no); } end; end else // A-RRAY if v = __array_run then begin save_dstW( t_arr[t_lab[_odd].adr].idx ); // maksymalny indeks tablicy save_dst( ord ( relType[t_arr[t_lab[_odd].adr].siz] ) ); // rozmiar pol end else // P-ROCEDURE if v = __proc_run then begin k:=t_prc[t_lab[_odd].adr].reg; save_dst( byte(k) ); // kolejnosc rejestrow ch:=t_prc[t_lab[_odd].adr].typ; save_dst( ord(ch) ); // typ procedury ' '__pDef, 'R'__pReg, 'V'__pVar k:=t_prc[t_lab[_odd].adr].par; // liczba parametrow indeks:=t_prc[t_lab[_odd].adr].str; if (k>0) and (ch=__pVar) then // jesli __pVar to wliczamy tez dlugosc for j:=0 to k-1 do begin // nazw pametrow tmp:=t_par[j+indeks]; inc(k,length(tmp)+2-1); end; save_dstW( k ); // liczba danych na temat parametrow k:=t_prc[t_lab[_odd].adr].par; // liczba parametrow jeszcze raz if k>0 then // jesli sa parametry to je zapiszemy for j:=0 to k-1 do begin tmp:=t_par[j+indeks]; save_dst(ord(tmp[1])); if ch=__pVar then begin // dodatkowo dlugosc i nazwe etykiety jesli to __pVar txt:=copy(tmp,2,length(tmp)); // omijamy pierwszy znak typu save_dstS( txt ); end; end; end; zapisz_lst(ety); end; bez_lst:=true; end; end; procedure operator_zlozony(var i:integer; var zm,ety:string; const glob:Boolean); var txt: string; begin if ety[1]<>'?' then blad(zm,58); // te operacje dotycza etykiet tymczasowych if glob then txt:=':' else txt:=''; txt:=txt+ety+zm[i]; if if_test then if zm[i+1]='=' then begin insert(txt,zm,i+2); // modyfikujemy linie np. ?tmp+=3 -> ?tmp=?tmp+3 delete(zm,i,1) end else begin zm:=ety+'='+txt+'1'; // modyfikujemy linie ?tmp++ -> ?tmp=?tmp+1 i:=length(ety)+1 // modyfikujemy linie ?tmp-- -> ?tmp=?tmp-1 end; end; procedure get_data_array(var i:integer; var zm:string; const max:integer; const typ:byte); var ety, str: string; k, j: integer; _odd: integer; begin save_lst(' '); omin_spacje(i,zm); if not(zm[i] in ['[','(']) then begin ety:='['+IntToStr(array_used.max)+']'; if zm[i]='=' then __inc(i,zm); end else begin ety:=get_dat_noSPC(i,zm,'=',#0,zm); if ety='' then ety:='[0]'; if zm[i]<>'=' then blad(zm,58) else __inc(i,zm); end; str:=get_dat_noSPC(i,zm,'\',#0,zm); k:=1; while true do begin _odd:=integer( oblicz_wartosc_ogr(ety,zm,k) ); // ___wartosc_noSPC(txt,zm,k,#0,'F'); subrange_bounds(zm,_odd,max); array_used.idx:=_odd; array_used.typ:=tType[ typ ]; if not(loop_used) and not(FOX_ripit) and (length(t)+7<32) then t:=t+' ['+hex(cardinal(_odd),4)+']'; j:=1; oblicz_dane(j,str,zm,typ); omin_spacje(k,ety); if ety[k]<>':' then Break else __inc(k,ety); end; if k<=length(ety) then blad_ill(zm,ety[k]); end; procedure add_proc_nr; (*----------------------------------------------------------------------------*) (* zwiekszamy licznik PROC_IDX a przez to i PROC_NR *) (*----------------------------------------------------------------------------*) begin inc(proc_idx); proc_nr:=proc_idx; // PROC_IDX to pierwszy wolny wpis do T_PRC // kazdy nowy blok .PROC musi otrzymac nowy niepowtarzalny numer if proc_idx>High(t_prc) then SetLength(t_prc, proc_idx+1); end; procedure upd_procedure(var ety,zm:string; const a:integer); (*----------------------------------------------------------------------------*) (* uaktualniamy wartosc BANK, ADRES i parametry procedury typu ' ' *) (*----------------------------------------------------------------------------*) var str, txt, b, tmp, add: string; _doo, _odd, idx, i, len: integer; tst: cardinal; old_bool, old_macro: Boolean; begin t_prc[proc_nr].bnk:=bank; t_prc[proc_nr].adr:=a; t_prc[proc_nr].ofs:=org_ofset; str:=lokal_name+ety; zapisz_etykiete(str,a,bank,ety[1]); old_macro := run_macro; run_macro := false; old_bool := dreloc.use; // aby parametry procedury nie byly relokowalne dreloc.use := false; _doo:=t_prc[proc_nr].par; // liczba zadeklarowanych parametrow w aktualnej procedurze if _doo>0 then case t_prc[proc_nr].typ of __pDef: begin // jesli procedura miala zadeklarowane parametry to // odczytamy adres dla parametrow zawarty w @PROC_VARS_ADR // i zaktualizujemy adresy parametrow procedury tst:=adr_label(2,true); // @proc_vars_adr proc:=true; // PROC=TRUE i PROC_NAME proc_name:=ety+'.'; // umozliwia uaktualnienie adresow etykiet // wymus wykonanie makr @PULL 'I' // wymus_zapis_lst(zm); zm:=' @PULL ''I'','+IntToStr(t_prc[proc_nr].ile); idx:=t_prc[proc_nr].str; for _odd:=0 to _doo-1 do begin // !!! koniecznie taka kolejnosc petli FOR !!! txt:=t_par[idx+_odd]; str:=copy(txt,2,length(txt)); // uaktualnimy adresy etykiet parametrow procedury save_lab(str , tst , __id_param , zm); inc( tst , TypeToByte(txt[1]) ); end; end; __pVar: begin idx:=t_prc[proc_nr].str; for _odd:=_doo-1 downto 0 do begin txt:=t_par[idx+_odd]; // wczytamy nazwe parametru, usuwamy pierwszy znak okreslajacy typ // oraz znaki ktore nie naleza do nazwy etykiety str:=''; add:=''; i:=2; len:=length(txt); while i<=len do begin if _lab(txt[i]) then str:=str+txt[i] else Break; inc(i); end; while i<=len do begin add:=add+txt[i]; inc(i); end; b:=lokal_name+ety+'.'; tmp:=b+str; i:=l_lab(tmp); // szukamy najblizszej sciezki dla parametru while (i<0) and (pos('.',b)>0) do begin obetnij_kropke(b); tmp:=b+str; i:=l_lab(tmp); end; t_par[idx+_odd] := txt[1]+tmp+add; end; end; end; dreloc.use := old_bool; run_macro := old_macro; save_lst(' '); end; function ByteToReg(var a: byte): char; begin case (a and $c0) of $40: Result := 'X'; $80: Result := 'Y'; else Result := 'A'; end; a:=byte( a shl 2 ); end; function RegToByte(const a: char): byte; begin case a of 'A': Result := $00; 'X': Result := $55; 'Y': Result := $aa; else Result := $ff; end; end; procedure get_procedure(var ety,nam,zm: string; var i:integer); (*----------------------------------------------------------------------------*) (* odczytujemy i zapamietujemy typy i nazwy parametrow w deklaracji .PROC *) (* w zaleznosci od sposobu przekazywania parametrow zwiekszana jest liczba *) (* przebiegow asemblacji PASS_END *) (*----------------------------------------------------------------------------*) type _typBool = array [0..2] of Boolean; var k, l, nr_param, j: integer; txt, str: string; ch, ptype: char; v: byte; old_bool: Boolean; treg: _typBool; all : _typStrREG; begin reserved_word(ety,zm{, true}); // sprawdz czy nazwa .PROC jest dozwolona old_bool := run_macro; run_macro := false; save_lab(ety,proc_nr,__id_proc,zm); // aktualny indeks do T_PRC = PROC_NR run_macro := old_bool; old_bool := dreloc.use; // koniecznie aby parametry procedury dreloc.use := false; // nie byly relokowalne t_prc[proc_nr].nam := nam; // wlasciwa nazwa procedury t_prc[proc_nr].bnk := bank; // zapisanie banku procedury t_prc[proc_nr].adr := adres; // zapisanie adresu procedury t_prc[proc_nr].typ := __pDef; // domyslny typ procedury 'D' t_prc[proc_nr].str := High(t_par); // indeks do T_PAR, beda tam parametry procedury omin_spacje(i,zm); k:=0; nr_param:=0; str:=zm[i]; if not(test_char(i,zm,'(',#0)) then blad_und(zm,str,8); // odczytujemy deklaracje parametrow ograniczonych nawiasami ( ) if zm[i] = '(' then begin all:=''; // tutaj zapiszemy kombinacje rejestrow CPU // fillchar(treg,sizeof(treg),false); treg[0]:=false; treg[1]:=false; treg[2]:=false; proc:=true; proc_name:=ety+'.'; // sprawdzamy poprawnosc nawiasow, usuwamy poczatkowy i koncowy nawias txt:=ciag_ograniczony(i,zm,true); omin_spacje(i,zm); ptype := __pDef; // domyslny typ procedury __pDef // sprawdzamy czy jest okreslony typ procedury .REG if zm[i]='.' then begin //str:=get_datUp(i,zm,#0,false); str:=get_directive(i,zm); v := fCRC16(str); if not(v in [__reg, __var]) then blad_und(zm,str,68); ptype := str[2]; t_prc[proc_nr].typ := ptype; end; if ptype=__pVar then if pass_end<3 then pass_end:=3; // jesli sa parametry .VAR to musza byc conajmniej 3 przebiegi // sprawdzamy obecnosc deklaracji dla programowego stosu MADS'a if ptype=__pDef then begin adr_label(0,true); // @stack_pointer, test obecnosci deklaracji etykiety adr_label(1,true); // @stack_address, test obecnosci deklaracji etykiety adr_label(2,true); // @proc_vars_adr, test obecnosci deklaracji etykiety end; j:=1; ch:=' '; // jesli ch=' ' to odczytuj typ parametru while j<=length(txt) do begin if ch=' ' then begin v:=get_type(j,txt,zm,true); ch:=relType[ v ]; // typ parametru 'B', 'W', 'L', 'D' z relType end; // odczytujemy nazwe parametru lub !!! wyrazenie !!! (np. label+1) // parametry możemy rozdzielac znakiem przecinka // spacja sluzy do okreslenia nowego typu parametru omin_spacje(j,txt); str:=get_dat(j,txt,',',true); // parametr lub wyrazenie if str='' then blad(zm,15); // jesli .REG to nazwy parametrow sa 1-literowe A,X,Y lub 2-literowe AX, AY itp. // nazwy parametrow moga powtorzyc sie tylko raz // dla .REG dopuszczalne sa tylko parametry typu .BYTE, .WORD, .LONG if ptype=__pReg then begin if not(TypeToByte(ch)=length(str)) then blad_und(zm,str,41); for l:=1 to length(str) do begin v:=RegToByte(UpCase(str[l])) and 3; if v=3 then blad_und(zm,str[l],61) // CPU doesn't have register ? else if treg[v] then blad(zm,11) // CPU doesn't have so many registers else treg[v]:=true; end; end; omin_spacje(j,txt); // wstepnie zapamietujemy etykiety parametrow jako wartosc NR_PARAM dla __pDef case ptype of __pDef: save_lab(str , nr_param , __id_param , zm); __pReg: all:=all+str; // __pVar: str:=proc_name+lokal_name+str; // potem poszukamy "sciezki" do nazwy parametru end; str:=ch+str; save_par(str); inc(k); // zwiekszamy licznik odczytanych parametrow procedury inc( nr_param , TypeToByte(ch) ); // zwiekszamy NR_PARAM o dlugosc danych if txt[j]<>',' then ch:=' ' else inc(j); end; // while end; // if zm[i] = '(' if t_prc[proc_nr].typ = __pReg then begin // maksymalnie 3 bajty mozna przekazac za pomoca rejestrow if nr_param>3 then blad(zm,11); // zapisujemy kolejnosc rejestrow t_prc[proc_nr].reg := (RegToByte(all[1]) and $c0) or (RegToByte(all[2]) and $30) or (RegToByte(all[3]) and $0c); end; t_prc[proc_nr].par := k; t_prc[proc_nr].ile := nr_param; dreloc.use := old_bool; end; procedure test_wyjscia(var zm:string; const wyjscie:Boolean); (*----------------------------------------------------------------------------*) (* testowanie zakonczenia asemblacji pliku *) (*----------------------------------------------------------------------------*) begin if not(wyjscie) then if not(run_macro) and not(icl_used) then if ifelse<>0 then blad(zm,1) else if proc or macro then blad(zm,17) else // !!! koniecznie !!! ... or macro if struct.use then blad(zm,56) else if aray then blad(zm,60) else if rept then blad(zm,43) else if lokal_nr>0 then blad(zm,29) else if pag_idx>0 then blad(zm,65) else if whi_idx>0 then blad(zm,89) else if test_idx>0 then blad(zm,96); end; function fgetB(var i:integer): byte; begin Result := t_lnk[i]; inc(i); end; function fgetW(var i:integer): integer; begin Result := t_lnk[i] + t_lnk[i+1] shl 8; inc(i,2); end; function fgetL(var i:integer): cardinal; begin Result := t_lnk[i] + t_lnk[i+1] shl 8 + t_lnk[i+2] shl 16; inc(i,3); end; function fgetD(var i:integer): cardinal; begin Result := t_lnk[i] + t_lnk[i+1] shl 8 + t_lnk[i+2] shl 16 + t_lnk[i+3] shl 24; inc(i,4); end; function fgetS(var i:integer): string; var x, y: integer; begin Result:=''; x:=fgetW(i); for y:=x-1 downto 0 do Result:=Result+chr( fgetB(i) ); end; procedure flush_link; var j, k: integer; begin k:=dlink.len; save_lst('a'); if k>0 then for j:=0 to k-1 do save_dst(t_ins[j]); inc(adres,k); if dlink.emp>0 then begin save_hea; org:=true; inc(adres,dlink.emp); dlink.emp:=0; end; end; procedure get_address(var i:integer; var zm:string); // nowy adres asemblacji dla .PROC lub .LOCAL var txt: string; begin t_end[end_idx].old:=adres; // sprawdzamy czy jest nowy adres asemblacji dla .PROC lub .LOCAL omin_spacje(i,zm); if zm[i]=',' then begin __inc(i,zm); txt:=get_dat(i,zm,'(',true); blokuj_zapis:=true; // wymuszamy zapis ORG-a jesli wystapil wczesniej save_dst(0); blokuj_zapis:=false; org_ofset := adres; adres := integer( oblicz_wartosc(txt,zm) ); org_ofset := adres - org_ofset; omin_spacje(i,zm); end; end; procedure get_address_update; begin dec(adres, t_end[end_idx-1].adr); inc(adres, t_end[end_idx-1].old); dec(end_idx); end; procedure save_extLabel(k:integer; var ety,zm:string; v:byte); var txt: string; len: byte; isProc: Boolean; begin omin_spacje(k,zm); if v=__proc then begin // etykieta external deklaruje procedure proc_nr:=proc_idx; // koniecznie przez ADD_PROC_NR if pass=0 then begin txt:='##'+ety; // zapisujemy etykiete ze znakami ## get_procedure(txt,ety,zm,k); // odczytujemy parametry proc:=false; // koniecznie wylaczamy PROC proc_name:=''; // i koniecznie PROC_NAME:='' end; add_proc_nr; // zwiekszamy numer koniecznie save_lab(ety,extn_idx,__id_ext,zm); len:=2; // typu .WORD isProc:=true; end else begin dec(v, __byteValue); // normalna etykieta external save_lab(ety, extn_idx, __id_ext, zm); len:=v; isProc:=false; end; t_extn[extn_idx].nam:=ety; // SAVE_EXTN t_extn[extn_idx].siz:=relType[len]; // t_extn[extn_idx].prc:=isProc; // inc(extn_idx); if extn_idx>High(t_extn) then SetLength(t_extn,extn_idx+1); end; procedure get_maeData(var zm:string; var i:integer; const typ:char); var _odd, _doo, idx, j, tmp: integer; txt, hlp: string; v, war: byte; par: _strArray; begin save_lst('a'); get_parameters(i,zm,par,true, '.',':'); _doo:=High(par); if _doo>0 then begin _odd:=0; war:=0; if (typ in ['B','S']) and (_doo>1) then begin txt:=par[0]; // mozliwa wartosc, ktora bedziemy dodawac do reszty ciagu // pod warunkiem ze ciag liczy wiecej niz 1 element if txt[1] in ['+','-'] then begin j:=1; war:=byte( ___wartosc_noSPC(txt,zm,j,#0,'B') ); inc(_odd); end; end; for idx:=_odd to _doo-1 do begin // wlasciwe dekodowanie ciagu txt:=par[idx]; if txt[1] in ['''','"'] then begin j:=1; hlp:=get_string(j,txt,zm,true); omin_spacje(j,txt); if length(txt)>=j then if not(txt[j] in ['*','+','-']) then blad_ill(zm,txt[j]); v:=war; inc(v, test_string(j,txt,'F')); if typ='S' then save_dta(0,hlp,'D', v) else save_dta(0,hlp,'C', v); end else case typ of 'B', 'H', 'S': begin if typ='H' then txt:='$'+txt; j:=1; v := byte( ___wartosc_noSPC(txt,zm,j,#0,'B') ); if typ='S' then v:=ata2int(v); inc(v, war); //v:=v + war; save_dst(v); inc(adres); end; 'W': begin j:=1; tmp := integer( ___wartosc_noSPC(txt,zm,j,#0,'A') ); save_dstW( tmp ); inc(adres,2); end; end; end; end; end; function asm_test(var lar,rar,old, jump:string; const typ,op:byte): int5; (*----------------------------------------------------------------------------*) (* generujemy kod testujacy warunek dla .WHILE, .TEST *) (*----------------------------------------------------------------------------*) var hlp: int5; txt: string; adr: integer; begin adr:=adres; if lar[1]='#' then blad(old,58); // argument nierealny :) case typ of 1: txt:='CPB'; 2: txt:='CPW'; 3: txt:='CPL'; else txt:='CPD'; end; TestWhileOpt:=not(op in [0,4]); // krótszy kod jesli operator '=', '<>' txt:=txt+#32+lar+#32+rar; Result:=asm_mnemo(txt, old); (*----------------------------------------------------------------------------*) (* 0 <> 4 = xor 4 *) (* 1 >= 5 < *) (* 2 <= 6 > *) (*----------------------------------------------------------------------------*) case op of 0: txt:='JNE'; // <> 1: txt:='JCS'; // >= 2: txt:='JCC '+jump; // <= 4: txt:='JEQ'; // = 5: txt:='JCC'; // < 6: txt:='SEQ'; // > end; if op in [2,6] then begin hlp:=asm_mnemo(txt,old); addResult(hlp,Result); if op=2 then txt:='JEQ' else begin test_skipa; txt:='JCS'; end; end; txt:=txt+#32+jump; hlp:=asm_mnemo(txt,old); addResult(hlp,Result); adres := adr; // przywracamy poczatkowa wartosc ADRES end; procedure create_long_test(const _v, _r:byte; var long_test, _lft, _rgt:string); var txt: string; begin case _v xor 4 of 0: txt:='<>'; 1: txt:='>='; 2: txt:='<='; 4: txt:='='; 5: txt:='<'; 6: txt:='>'; end; if long_test<>'' then long_test:=long_test+'\'; long_test:=long_test+'.TEST '+mads_param[_r]+_lft+txt+_rgt+'\ LDA:SNE#1\.ENDT\ LDA#0'; 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\'; end; procedure wyrazenie_warunkowe(var i:integer; var long_test, zm,left,right:string; var v,r:byte; const strend: string); (*----------------------------------------------------------------------------*) (* generowanie kodu dla warunku .WHILE, .TEST *) (*----------------------------------------------------------------------------*) var str, txt, _lft, _rgt, kod: string; k, j : integer; _v, _r: byte; begin if zm='' then blad(zm,23); r:=get_type(i,zm,zm,true); omin_spacje(i,zm); str:=get_dat(i,zm,#0, false); k:=1; right:=''; left:=''; // czytamy do LEFT dopóki nie napotkamy operatorów '=', '<', '>', '!' if str<>'' then while not(_ope(str[k])) and not(test_char(k,str,#0,#0)) do begin if str[k] in ['[','(','{'] then left:=left + ciag_ograniczony(k,str,false) else begin if str[k]<>' ' then left:=left + str[k]; inc(k); end; end; omin_spacje(k,str); v:=$ff; if left<>'' then begin (*----------------------------------------------------------------------------*) (* 0 <> 4 = xor 4 *) (* 1 >= 5 < *) (* 2 <= 6 > *) (*----------------------------------------------------------------------------*) case str[k] of // szukamy znanej kombinacji operatorów #0: v:=$80; // koniec ciągu '=': case str[k+1] of '=': begin v:=4; // == inc(k); end; else v:=4; // = end; '!': case str[k+1] of '=': v:=0; // != end; '<': case str[k+1] of '>': v:=0; // <> '=': v:=2; // <= else v:=5; // < end; '>': case str[k+1] of '=': v:=1; // >= else v:=6; // > end; end; if v<$80 then begin if v<4 then inc(k,2) else inc(k); if _ope(str[k]) then blad_ill(zm, str[k]); v:=v xor 4; omin_spacje(k,str); right:=get_dat(k,str,#0,true); //get_dat_noSPC(k,str,#0,#0,zm); end else if v=$80 then begin // dla pustego ciagu domyslna operacja '<>0' v:=4; right:='#0'; end; end; // V = $FF oznacza brak operatora if (left='') or (right='') or (v=$ff) then begin blad(zm,58); koniec(2); end; // jesli występują operatory .OR, .AND to generujemy specjalny kod omin_spacje(k,str); kod:=''; if not(test_char(k,str,#0,#0)) then begin txt:=get_dat(k,str,#0,true); if txt='.OR' then kod:='9' else if txt='.AND' then kod:='41'; { else blad(zm,58);} end; if kod<>'' then begin if long_test='' then long_test:=long_test+'.LOCAL\.PUT[0]=0\?I=1\?J=0'; omin_spacje(k,str); txt:=get_dat(k,str,#0,false); j:=1; wyrazenie_warunkowe(j, long_test, txt,_lft,_rgt, _v, _r, '.PUT[?I]='+kod+'\ ?I++'); end; if (long_test<>'') then begin create_long_test(v, r, long_test, left, right); long_test:=long_test+strend; end; end; function BCD(const l,r:char): byte; begin Result:=byte( (ord(l)-ord('0')) shl 4 + (ord(r)-ord('0')) ); end; procedure save_fl(var a,old:string); (*----------------------------------------------------------------------------*) (* zapisujemy liczbe real w formacie FP Atari *) (*----------------------------------------------------------------------------*) var i, c, e: integer; fl, tmp: string; x: real; v: byte; begin val(a, x,i); if i>0 then blad_ill(old,a[i]); str(x, fl); tmp:=copy(fl,pos('E',fl)+1,length(fl)); // odczytujemy wartosc E e:=integer( StrToInt(tmp) ); c:=pos('.',fl); // pozycja znaku '.' if e and 1<>0 then // jesli E jest nieparzyste to modyfikujemy while c<>4 do begin if c<4 then begin fl[c]:=fl[c+1]; // przesuwamy w prawo fl[c+1]:='.'; dec(e); inc(c); end else begin fl[c]:=fl[c-1]; // przesuwamy w lewo fl[c-1]:='.'; inc(e); dec(c); end; end; e:=e div 2; if (c>4) or (abs(e)>64) then blad(old,0); // przekroczony zakres FP Atari v:=byte(64+e); if fl[1]='-' then v:=v or $80; save_dst(v); if c=4 then // dwie cyfry v:=BCD(fl[2],fl[3]) else // jedna cyfra v:=BCD('0',fl[2]); save_dst(v); i:=c+1; v:=BCD(fl[i], fl[i+1]); inc(i,2); save_dst(v); v:=BCD(fl[i], fl[i+1]); inc(i,2); save_dst(v); v:=BCD(fl[i], fl[i+1]); inc(i,2); save_dst(v); v:=BCD(fl[i], fl[i+1]); save_dst(v); inc(adres,6); // zapisalismy 6 bajtow end; function getMemType(var i: integer; var zm: string): byte; begin omin_spacje(i,zm); Result := 0; case UpCase(zm[i]) of 'M': Result:=0; // M[ain] 'E': Result:=2; // E[xtended] else blad(zm,23); end; memType := Result; end; function directive(var zm:string; const kod:byte): byte; (*----------------------------------------------------------------------------*) (* odczyt dyrektywy lub innego ciagu znakowego i obliczenie kodu *) (*----------------------------------------------------------------------------*) var i: integer; z: string; old_case, space: Boolean; label LOOP; begin Result:=0; LOOP: if zm<>'' then begin i:=1; omin_spacje(i,zm); space:=i<>1; // sprawdzamy czy wystepuja spacje ("biale znaki") old_case := case_used; // zapamietujemy poprzednia wartosc CASE_USED case_used := false; // wymuszamy duze litery CASE_USED = FALSE z:=get_lab(i,zm,false); case_used := old_case; if space or labFirstCol then begin Result:=fASC(z); if Result<>0 then exit; end; omin_spacje(i,zm); if zm[i]='{' then begin if end_idx>0 then begin if t_end[end_idx-1].sem then blad(zm,58); t_end[end_idx-1].sem:=true; wymus_zapis_lst(zm); zm:=copy(zm, i+1, length(zm)); goto LOOP; end else blad(zm,58); end else if zm[i]='}' then begin if end_idx>0 then if t_end[end_idx-1].sem then begin __inc(i,zm); if not(test_char(i,zm,#0,#0)) then blad(zm,58); Result:=__dend; end else blad(zm,58); end else if i0) then begin if t_end[end_idx-1].kod = kod then Result:=kod; end; end; end; function dirMACRO(var zm:string): byte; (*----------------------------------------------------------------------------*) (* odczyt makra zdefiniowanego przez dyrektywy .MACRO, .ENDM [.MEND] *) (* !!! wyjatkowo dyrektywa .END nie może kończyc definicji makra !!! *) (*----------------------------------------------------------------------------*) begin save_lst(' '); // .MACRO Result:=directive(zm, __endm); if (Result=__macro) and macro then blad(zm,17); if Result=__endm then macro := false; if (pass=0) and if_test then save_mac(zm); // !!! makra zapisujemy tylko w 1 przebiegu !!! zapisz_lst(zm); end; procedure dirENDR(var zm,a,old_str:string; var rept_nr,rept_ile:integer); (*----------------------------------------------------------------------------*) (* .ENDR - wykonanie petli .REPT *) (*----------------------------------------------------------------------------*) var tmp, lntmp: integer; txt: string; old_if_test: Boolean; begin if if_test then if not(rept) then blad(zm,51) else begin wymus_zapis_lst(zm); rept := false; rept_run := true; tmp := ___rept_ile; lntmp := line_add; ___rept_ile := StrToInt(t_mac[rept_nr]); line_add := StrToInt(t_mac[rept_nr+1]); old_if_test := if_test; if not(run_macro) then begin txt := 'REPT'; put_lst(show_full_name(txt,false,true)); end; analizuj_mem__(rept_nr+2,High(t_mac), zm,a,old_str, 0,rept_ile, true); rept_run := false; if not(run_macro) and not(rept) then put_lst(show_full_name(a,full_name,true)); line_add := lntmp; if_test := old_if_test; ___rept_ile := tmp; SetLength(t_mac, rept_nr+1); dec_end(zm, __endr); end; end; procedure reptLine(var txt: string); (*----------------------------------------------------------------------------*) (* podstawianie parametrow w bloku .REPT *) (*----------------------------------------------------------------------------*) var ety, tmp: string; j, k, war: integer; begin j:=1; while j<=length(txt) do if test_param(j,txt) then begin k:=j; if txt[j]=':' then inc(j) else inc(j,2); ety:=''; while _dec(txt[j]) do begin ety:=ety+txt[j]; inc(j) end; war:=StrToInt(ety); if war__endr then begin if if_test then save_mac(zm); zapisz_lst(zm); end; end; function get_vars_type(var i:integer; var zm:string; var typ:char; var i_str: integer; var n_str: string): integer; (*----------------------------------------------------------------------------*) (* odczytujemy typ dla zmiennych .BYTE, .WORD, .LONG, .DWORD, .STRUCT|.ENUM *) (*----------------------------------------------------------------------------*) var txt: string; k, x: integer; begin omin_spacje(i,zm); Result:=0; k:=i; if zm[i]='.' then begin txt:=get_directive(i,zm); Result:=fCRC16(txt); if Result in [__byte..__dword] then dec(Result, __byteValue) else begin Result:=0; // to nie jest dyrektywa okreslajaca typ danych !!! V=0 !!! i:=k; // przywracamy poprzednie wartosci end; end else begin txt:=get_lab(i,zm, true); // zatrzyma sie jesli brak etykiety x:=load_lab(txt, true); if x<0 then i:=k // etykieta nie zostala zdefiniowana else case t_lab[x].bnk of __id_enum: begin Result:=t_lab[x].adr; n_str := txt; // typ:='E'; end; __id_struct: begin Result:=t_str[t_lab[x].adr].siz; i_str := t_lab[x].adr; n_str := txt; typ:='S'; end; else i:=k; end; end; end; procedure get_vars(var i:integer; var zm:string; var par:_strArray; const mne: byte); (*----------------------------------------------------------------------------*) (* .VAR .TYPE v0 [=expression], v1 [=expression] .TYPE v3 [=expression] v4 *) (* .VAR v0 [=expression] .TYPE v1 [=expression] v2 .TYPE [=address] *) (* *) (* odczyt parametrow dla dyrektywy .VAR *) (*----------------------------------------------------------------------------*) var idx, _doo, _odd, k, v, i_str: integer; txt, str, n_str: string; tst: Int64; typ: char; begin i_str:=0; n_str:=''; typ:='V'; v:=get_vars_type(i,zm, typ, i_str, n_str); get_parameters(i,zm,par,false, '.',':'); idx:=1; if zm[i]=':' then begin // liczba powtorzen inc(i); txt:=get_dat(i,zm,',',true); idx:=integer( oblicz_wartosc(txt,zm) ); testRange(zm, idx, 0); end; _doo:=High(par); if _doo=0 then blad(zm,23); // brak zmiennych - Unexpected end of line omin_spacje(i,zm); if v=0 then if zm[i]='.' then v:=get_type(i,zm,zm,true) // typ zmiennej else begin txt:=par[_doo-1]; k:=1; v:=get_vars_type(k,txt,typ, i_str, n_str); if v=0 then blad_und(zm,txt,50) // nie zostal okreslony typ zmiennej "Missing type label" else begin par[_doo-1]:=copy(txt,k,length(txt)); dec(_doo); // udalo sie, ostatni element pomijamy end; end; for _odd:=0 to _doo-1 do begin txt:=par[_odd]; k:=1; str:=get_lab(k, txt, true); // sprawdzamy czy etykieta posiada poprawne znaki //if str='' then blad_ill(zm,txt[1]); // pierwszy znak etykiety jest niewlasciwy tst:=0; if txt[k]='=' then begin // czy zmienna jest inicjowana ('=') if (mne=__zpvar) and (pass=pass_end) then warning(114); txt:=copy(txt,k+1,length(txt)); tst:=oblicz_wartosc(txt,zm); if ValueToType(tst) > v then blad(zm,0); end else if not(test_char(k,txt,#0,#0)) then blad_ill(zm,txt[k]); // wystapil niedozwolony znak if proc then // SAVE_VAR t_var[var_idx].lok := proc_lokal // else // t_var[var_idx].lok := end_idx; // // if proc and (lokal_name<>'') then // t_var[var_idx].nam := lokal_name+str // else // t_var[var_idx].nam := str; // // t_var[var_idx].siz := v; // t_var[var_idx].cnt := idx; // t_var[var_idx].war := cardinal (tst); // // t_var[var_idx].adr := -1; // // t_var[var_idx].id := var_id; // t_var[var_idx].typ := typ; // t_var[var_idx].idx := i_str; // t_var[var_idx].str := n_str; // inc(var_idx); if var_idx>High(t_var) then SetLength(t_var,var_idx+1); end; end; procedure opt_h_minus; begin opt:=opt and $fe; end; procedure upd_structure(var ety, zm: string); var idx: integer; txt: string; begin struct.cnt := 0; txt:=lokal_name+ety; // pelna nazwa struktury .STRUCT // sprawdzamy czy mamy juz zapamietana ta strukture idx:=loa_str(txt, struct.id); // nie znalazl ofsetu do tablicy (idx = -1) if idx<0 then begin save_str(txt,adres,0,1,adres,bank); // dopisz do tablicy T_STR nowa strukture struct.idx:=loa_str(txt, struct.id); save_lab(ety,struct.idx, __id_struct,zm); end else begin // znalazl ofset do tablicy struct.idx:=idx; save_lab(ety,struct.idx, __id_struct,zm); end; if pass_end<3 then pass_end:=3; // jesli sa struktury to musza byc conajmniej 3 przebiegi end; procedure search_comment_block(var i:integer; var zm,txt:string); var k: integer; begin if (zm<>'') and (i'' then if ((zm[i]=':') and (_eol(zm[i+1]))) or struct.use or enum.use then begin ety:=txt; __inc(i,zm); end else i:=k; end; (*----------------------------------------------------------------------------*) (* etykiety moga byc rozkazami CPU lub pseudo rozkazami jesli labFirstCol=true*) (* etykiet w stylu MAE to nie dotyczy, one sa rozpoznawane klasycznie *) (* nie dotyczy to takze etykiet deklarowanych w .STRUCT *) (*----------------------------------------------------------------------------*) if (length(ety)=3) and not(struct.use) and not(mae_labels) and labFirstCol then if reserved(ety) then begin i:=m; ety:=''; end; (*----------------------------------------------------------------------------*) (* pierwszymi znakami moga byc tylko znaki poczatkujace nazwe etykiety, *) (* znaki konca linii oraz '.', ':', '*', '+', '-', '=' *) (* dopuszczalne sa instrukcje generujace kod 6502 #IF #WHILE #END *) (*----------------------------------------------------------------------------*) // if not(aray) and not(struct.use) and not(enum.use) then if not(_first_char(zm[i])) and not(test_char(i,zm,#0,#0)) then case zm[i] of '#': begin tmp:=get_directive(i,zm); mne.l:=fCRC16(tmp); if not(mne.l in [__test, __while, __dend, __telse]) then blad(zm,12); goto JUMP_2; end; '{': if end_idx>0 then begin if t_end[end_idx-1].sem then blad(zm,58); t_end[end_idx-1].sem:=true; inc(i); goto LOOP; end else blad(zm,12); '}': if end_idx>0 then if t_end[end_idx-1].sem then begin __inc(i,zm); if not(test_char(i,zm,#0,#0)) then blad(zm,58); mne.l:=t_end[end_idx-1].kod; end else blad(zm,12); else if (mne.l=0) and not(aray) and not(struct.use) and not(enum.use) then blad(zm,12); end; (*----------------------------------------------------------------------------*) (* sprawdzamy czy wystapila deklaracja lokalna etykiety *) (* znak '=' moze zastepowac EQU, nie musi byc poprzedzony "bialymi spacjami" *) (* znaki '+=' , '-=' zastepuja dodawanie i odejmowanie wartosci od etykiety *) (* znaki '--' , '++' zastepuja zmniejszanie i zwiekszanie wartosci etykiety *) (*----------------------------------------------------------------------------*) tmpZM:=zm; if zm[i] in ['+','-'] then if (ety<>'') and (zm[i+1] in ['+','-','=']) then operator_zlozony(i,zm,ety, false) else blad(zm,4); if (zm[i]='=') and not(aray) and not(struct.use) and not(enum.use) then begin mne.l:=__addEqu; __inc(i,zm); // wymuszamy wykonanie __addEQU save_lst(' '); goto JUMP; end; if ifelse>0 then save_lst(' '); (*----------------------------------------------------------------------------*) (* znak okreslajacy liczbe powtorzen linii ':' *) (*----------------------------------------------------------------------------*) if (zm[i]=':') then begin save_lst('a'); inc(i); loop_used:=true; txt:=get_dat(i,zm,',',true); _doo:=integer( oblicz_wartosc(txt,zm) ); testRange(zm, _doo, 0); old_rept := ___rept_ile; ___rept_ile := 0; // test obecnosci czegokolwiek k:=i; txt:=get_datUp(i,zm,#0,true); i:=k; if struct.use then begin rpt:=_doo; omin_spacje(i,zm); end else begin old_case := FOX_ripit; FOX_ripit := true; // zwracamy wartosc licznika petli dla '#' indeks := line_add; save_lab(ety,adres,bank,zm); idx:=High(t_mac); txt:=get_dat(i,zm,'\',false); save_mac(txt); line_add:=line-1; _odd := idx+1; analizuj_mem__(idx,_odd, zm,a,old_str, 0,_doo, false); loop_used := false; FOX_ripit := old_case; line_add := indeks; SetLength(t_mac,idx+1); mne.l:=__nill; ety:=''; end; ___rept_ile := old_rept; // FOX_ripit := false; end; (*----------------------------------------------------------------------------*) (* sprawdzamy czy to dyrektywa, tylko niektore dyrektywy moga byc petlone: *) (* .PRINT, .BYTE, .WORD, .LONG, .DWORD, .GET, .PUT, .HE, .BY, .WO, .SB, .FL *) (* innych dyrektyw nie mozemy powtarzac *) (*----------------------------------------------------------------------------*) if zm[i]='.' then begin tmp:=get_directive(i,zm); mne.l:=fCRC16(tmp); if not(mne.l in [__macro..__over]) then blad_und(zm,tmp,68) else if loop_used then if not(mne.l in [__byte..__dword, __print, __sav, __get, __put, __he, __by, __wo, __sb, __fl]) then blad(zm,36); end; (*----------------------------------------------------------------------------*) (* zamiana IFT ELS EIF ELI na ich odpowiedniki .IF .ELSE .ENDIF .ELSEIF *) (* zostala zrealizowane przez modyfikacje tablicy HASH *) (* podobnie dyrektywy .DB i .DW wskazuja na .BYTE i .WORD *) (* !!! koniecznie tylko w tym miejscu, w innym kod nie zostanie wykonany !!! *) (*----------------------------------------------------------------------------*) if UpCase(zm[i]) in ['E','I'] then begin j:=i; txt:=get_datUp(i,zm,#0,false); v:=fASC(txt); if length(txt)<>3 then i:=j else if not(v in [__if,__else,__endif,__elseif]) then i:=j else mne.l:=v; end; (*----------------------------------------------------------------------------*) (* zamiana dyrektywy .OR na pseudo rozkaz ORG *) (* obsluga dyrektywy .NOWARN *) (*----------------------------------------------------------------------------*) case mne.l of __or: mne.l:=__org; __nowarn: begin noWarning:=true; mne.l:=0; // omin_spacje(i,zm); // !!! tutaj omijanie spacji niedopuszczalne !!! goto LOOP end; end; if not(skip.hlt) then test_skipa; (*----------------------------------------------------------------------------*) (* odczytaj mnemonik *) (*----------------------------------------------------------------------------*) if (mne.l=0) and if_test and not(enum.use) then if i<=length(zm) then mne:=oblicz_mnemonik(i,zm,zm); (*----------------------------------------------------------------------------*) (* odczyt etykiet wystepujacych w bloku .ENUM *) (*----------------------------------------------------------------------------*) if enum.use then if (ety<>'') and (mne.l=0) then begin i:=1; get_parameters(i,zm,par,false, '.',':'); old_case := dreloc.use; // deklaracje etykiet w bloku .RELOC nie moga byc relokowalne dreloc.use := false; if High(par)>1 then begin save_lst(' '); justuj; put_lst(t+zm); end; for _odd:=0 to High(par)-1 do begin txt:=par[_odd]; k:=1; ety:=get_lab(k, txt, false); // sprawdzamy czy etykieta posiada poprawne znaki if ety='' then blad_ill(zm,txt[1]); // pierwszy znak etykiety jest niewlasciwy if txt[k]='=' then begin str:=copy(txt,k+1,length(txt)); enum.val:=oblicz_wartosc(str,zm); end else if not(test_char(k,txt,#0,#0)) then blad_ill(zm,txt[k]); // wystapil niedozwolony znak label_type:='C'; branch:=true; // dla etykiet .ENUM nie ma relokowalnosci save_lab(ety, enum.val, bank, zm); bez_lst:=true; if enum.val>enum.max then enum.max:=enum.val; // MAX dla okreslenia rozmiaru ENUM nul.i:=integer( enum.val ); save_lst('l'); if High(par)=1 then zapisz_lst(zm) else zapisz_lst(ety); inc(enum.val); end; dreloc.use := old_case; nul.i:=0; ety:=''; end; (*----------------------------------------------------------------------------*) (* dodatkowy test dla etykiet w bloku .STRUCT *) (*----------------------------------------------------------------------------*) if struct.use then if (ety<>'') and (mne.l=0) then begin idx:=l_lab(ety); if idx<0 then begin if pass=pass_end then blad(zm,58) end else if t_lab[idx].bnk=__id_struct then begin mne.l := __struct_run_noLabel; mne.i := t_lab[idx].adr; end else if pass=pass_end then blad(zm,58); end; JUMP_2: (*----------------------------------------------------------------------------*) (* .END *) (* zastepuje inne dyrektywy .END? *) (*----------------------------------------------------------------------------*) if mne.l=__dend then if end_idx=0 then blad(zm,72) else mne.l:=t_end[end_idx-1].kod; (*----------------------------------------------------------------------------*) (* specjalna forma definicji wartosci etykiety tymczasowej za pomoca znakow *) (* '=' , '+=' , '-=' , '++' , '--' *) (*----------------------------------------------------------------------------*) if mne.l=__addEqu then begin ety:=get_lab(i,zm, true); omin_spacje(i,zm); tmpZM:=zm; if UpCase(zm[i])='E' then inc(i,2) else if zm[i] in ['+','-'] then operator_zlozony(i,zm,ety, false); __inc(i,zm); end; (*----------------------------------------------------------------------------*) (* laczenie mnemonikow za pomoca znaku ':', w stylu XASM'a *) (*----------------------------------------------------------------------------*) if mne.l=__xasm then begin save_lab(ety,adres,bank,zm); if (pass=pass_end) and skip.use then warning(98); // Skipping only the first instruction save_lst('a'); loop_used := true; old_case := case_used; // nie mozemy zamieniac na duze litery case_used := true; // zachowujemy ich oryginalna wielkosc (CASE_USED=TRUE) skip.hlt := true; k:=mne.i; ety:=get_dat(k,zm,'\',false); // odczytujemy argumenty case_used := old_case; // przywracamy stara wartosc CASE_USED line_add:=line-1; // numer linii aktualnie przetwarzanej // przyda sie jesli wystapi blad idx:=High(t_mac); // indeks do wolnego wpisu w T_MAC while true do begin // petla bez konca ;) old_case := case_used; // tutaj takze musimy zachowac wielkosc liter case_used := true; // dlatego wymuszamy CASE_USED=TRUE txt:=get_dat(i,zm,':',true); // odczytujemy mnemonik rozdzielony znakiem ':' case_used := old_case; // przywracamy stara wartosc CASE_USED str:=' '+txt+ety; // preparujemy nowa linie do analizy t_mac[idx]:=str; // zapisujemy ja w T_MAC[IDX] test_skipa; _odd := idx+1; analizuj_mem__(idx,_odd, zm,a,old_str, 0,1, false); if zm[i]=':' then inc(i) else Break; // tutaj konczymy petle jesli brak ':' end; wymus_zapis_lst(zm); line_add:=0; // koniecznie zerujemy LINE_ADD if not(FOX_ripit) then bez_lst := true; loop_used := false; skip.hlt := false; skip.xsm := true; // wystapilo laczenie mnemonikow przez ':' mne.l:=__nill; ety:=''; end else if not(mne.l in [0,__nill]) then skip.xsm:=false; // nie wystapilo laczenie mnemonikow przez ':' (default) JUMP: (*----------------------------------------------------------------------------*) (* jesli mamy uruchomione makro to zapisz jego zawartosc do pliku LST *) (* puste linie nie sa zapisywane, !!! w tej postaci dziala najlepiej !!! *) (*----------------------------------------------------------------------------*) if run_macro and if_test then if ety<>'' then data_out:=true; (*----------------------------------------------------------------------------*) (* BLK (kody __blkSpa, __blkRel, __blkEmp) *) (*----------------------------------------------------------------------------*) if mne.l=__blk then if ety<>'' then blad(zm,38) else if loop_used then blad(zm,36) else begin empty:=false; txt:=get_datUp(i,zm,#0,true); case UpCase(txt[1]) of //BLK D[os] a 'D': mne.l := __org; //BLK S[parta] a 'S': mne.l := __blkSpa; //BLK R[eloc] M[ain]|E[xtended] 'R': mne.l := __blkRel; //BLK E[mpty] a M[ain]|E[xtended] 'E': begin mne.l := __blkEmp; empty:=true end; //BLK N[one] a 'N': begin mne.l := __org; opt_h_minus end; //BLK U[pdate] A[ddress] //BLK U[pdate] E[xternal] //BLK U[pdate] S[ymbols] //BLK U[pdate] N[ew] address text 'U': if pass=pass_end then begin oddaj_var; oddaj_ds; txt:=get_datUp(i,zm,#0,true); save_lst('a'); _doo:=0; // liczba adresow do relokacji _odd:=0; // liczba symboli do relokacji for idx:=0 to rel_idx-1 do if t_rel[idx].idx>=0 then inc(_odd) else if t_rel[idx].idx=-1 then inc(_doo); case UpCase(txt[1]) of 'A': begin // A[ddress] if not(blkupd.adr) then if (_doo>0) or dreloc.use then blk_update_address(zm); blkupd.adr:=true; end; 'E': begin // E[xternal] if not(blkupd.ext) then blk_update_external(zm); blkupd.ext:=true; end; 'P': begin // P[ublic] if not(blkupd.pub) then blk_update_public(zm); blkupd.pub:=true; end; 'S': begin // S[ymbol] if not(blkupd.sym) then if _odd>0 then blk_update_symbol(zm); blkupd.sym:=true; end; 'N': begin // N[ew] test_symbols := true; blk_update_new(i,zm); end; else blad(zm,23); end; end; else blad(zm,0); end; end; (*----------------------------------------------------------------------------*) (* .DS expression *) (* rezerwujemy "expression" bajtow bez ich inicjalizowania *) (*----------------------------------------------------------------------------*) if (mne.l=__ds) and (macro_rept_if_test) then begin // po zmianie adresu asemblacji bloku .PROC, .LOCAL nie ma możliwosci używania dyrektywy .DS if (org_ofset>0) then blad(zm,71); nul.i:=integer( adres ); save_lst('l'); branch:=true; save_lab(ety,adres,bank,zm); _doo:=integer( oblicz_wartosc_noSPC(zm,zm,i,#0,'A') ); if dreloc.sdx or dreloc.use then begin empty:=true; inc(ds_empty, _doo); inc(adres, _doo); end else begin txt:=zm; // !!! tylko tutaj wymuszamy zapis do LST !!! zapisz_lst(txt); NoAllocVar:=true; // dla .DS nie ma alokacji zmiennych .VAR mne.l:=__org; // teraz mozemy wymusic ORG *+ zm:='*+'+IntToStr(_doo); i:=1; bez_lst:=true; end; ety:=''; end; (*----------------------------------------------------------------------------*) (* [label] .ALIGN N[,fill] *) (*----------------------------------------------------------------------------*) if (mne.l=__align) and (macro_rept_if_test) then begin if loop_used then blad(zm,36); save_lst('a'); omin_spacje(i,zm); if test_char(i,zm,#0,#0) then _doo:=$100 else _doo:=integer( oblicz_wartosc_noSPC(zm,zm,i,',','A') ); _odd:=-1; if zm[i]=',' then begin __inc(i,zm); _odd:=integer( oblicz_wartosc_noSPC(zm,zm,i,',','B') ); end; if _doo>0 then idx:=(adres div _doo)*_doo else idx:=adres; if idx<>adres then inc(idx, _doo); if _odd>=0 then begin if pass=pass_end then begin while idx>adres do begin save_dst(byte(_odd)); inc(adres) end; end else adres:=idx; end else begin // wymuszenie ORG justuj; put_lst(t+zm); bez_lst:=true; zm:='$'+hex(idx,4); NoAllocVar:=true; // dla .ALIGN nie ma alokacji zmiennych .VAR mne.l:=__org; i:=1; end; end; (*----------------------------------------------------------------------------*) (* NMB [adres] *) (* RMB [adres] *) (* LMB #expression [,adres] *) (*----------------------------------------------------------------------------*) if macro_rept_if_test then begin ch:=' '; // CH bedzie zawieral znak dyrektywy 'N'MB, 'R'MB, 'L'MB case mne.l of __nmb: begin inc(bank); // zwiekszamy licznik bankow MADS'a ch:='N'; end; __rmb: begin bank:=0; // zerujemy licznik bankow MADS'a ch:='R'; end; __lmb: begin // ustawiamy licznik bankow MADS'a omin_spacje(i,zm); // if zm[i] in ['<','>'] then else // znaki '<', '>' sa akceptowane if zm[i]<>'#' then blad(zm,14) else __inc(i,zm); // pozostale znaki inne niz '#' to blad txt:=get_dat_noSPC(i,zm,' ',#0,zm); k:=1; j:=integer( ___wartosc_noSPC(txt,zm,k,',','B') ); // wartosc licznika bankow = 0..255 bank:=integer( j ); ch:='L'; end; end; (*----------------------------------------------------------------------------*) (* wymuszamy wykonanie makra @BANK_ADD (gdy OPT B+) dla LMB, NMB, RMB *) (*----------------------------------------------------------------------------*) if ch<>' ' then begin if dreloc.use or dreloc.sdx then blad(zm,71); if first_org then blad(zm,10); save_lst('i'); if opt and $80>0 then begin omin_spacje(i,zm); if zm[i]=',' then __inc(i,zm); str:=get_dat_noSPC(i,zm,' ',#0,zm); if str<>'' then str:=','+str; wymus_zapis_lst(zm); txt:='@BANK_ADD '''+ch+''''+str; i:=1; mne:=oblicz_mnemonik(i,txt,zm); zm:=txt; end; end; end; (*----------------------------------------------------------------------------*) (* wykonaj .PROC gdy PASS>0 *) (* wymus wykonanie makra @CALL jesli procedura miala parametry *) (* jesli procedura zostaje wywolana z poziomu innej procedury zapamietaj *) (* parametry procedury na stosie nie modyfikujac wskaznika stosu, *) (* a po powrocie przywroc je takze nie modyfikujac wskaznika stosu *) (*----------------------------------------------------------------------------*) if mne.l=__proc_run then if macro_rept_if_test then begin save_lab(ety,adres,bank,zm); indeks:=mne.i; idx:=t_prc[indeks].par; // liczba parametrow if idx>0 then begin wymus_zapis_lst(zm); ety:=''; str:=''; // jesli nastepuje wywolanie procedury typu T_PRC[].TYP=__pDef, ktora posiada parametry (IDX>0) // z ciala aktualnie przetwarzanej procedury PROC_NR-1 // to odlozymy na stos parametry procedury aktualnej, a po powrocie przywrocimy je if proc and (t_prc[indeks].typ=__pDef) then begin _doo:=t_prc[proc_nr-1].ile; // liczba bajtow przypadajaca na parametry if _doo>0 then begin //str:=copy(proc_name,1,length(proc_name)-1); // obcinamy ostatnia kropke w nazwie aktualnej procedury str:=proc_name; SetLength(str,length(proc_name)-1); ety:=' @PUSH ''I'','+IntToStr(_doo)+' \ '; str:=' \ @PULL ''J'','+IntToStr(_doo); end; end; rodzaj := t_prc[indeks].typ; // rodzaj procedury, sposobu przekazywania parametrow get_parameters(i,zm,par,false, '.',':'); // sprawdzamy liczbe przekazanych parametrow, jesli ich liczba sie nie zgadza to // wystapi blad 'Improper number of actual parameters' // w przypadku procedur typu __pReg, __pVar moze byc mniej parametrow, ale nie wiecej _doo:=High(par); for _odd:=_doo-1 downto 0 do begin txt:=par[_odd]; if txt='' then if rodzaj=__pDef then blad(zm,40) else txt:=';'; // dla __pReg mozemy pomijac parametry if (txt[1]='"') and (length(txt)>2) then txt:=copy(txt,2,length(txt)-2); par[_odd]:=txt; end; // sprawdz typ parametrow i wymus wykonanie makra @CALL_INIT, @CALL, @CALL_END // parametrem @CALL_INIT jest liczba bajtow zajmowanych przez parametry procedury case rodzaj of __pDef: begin if _doo<>idx then blad(zm,40); ety:=ety+' @CALL '+#39+'I'+#39+','+IntToStr(t_prc[indeks].ile); end; __pReg, __pVar: begin if _doo>idx then blad(zm,40) else if (pass=pass_end) and (_doo0 then for k:=0 to _doo-1 do if par[k][1]<>';' then begin txt:=par[k]; case rodzaj of __pDef: ety:=ety+' \ @CALL '; end; ch:=' '; v:=byte(' '); if txt='@' then begin // ety:=ety+#39+'@'+#39+','; v:=byte('@'); war:=0; ch:='Z'; end else if txt[1]='#' then begin // ety:=ety+#39+'#'+#39+','; v:=byte('#'); branch:=true; tmp:=copy(txt,2,length(txt)); war:=oblicz_wartosc(tmp,zm); ch:=value_code(war,zm,true); end; // typ parametru w deklaracji procedury (B,W,L,D) // funkcja VALUE_CODE zwrocila typ parametru (Z,Q,T,D) tmpZM:=copy(t_par[idx+k],2,length(t_par[idx+k])); if ch<>' ' then case t_par[idx+k][1] of 'B': if ch<>'Z' then blad_und(zm,tmpZM,41); 'W': if (ch in ['T','D']) or (txt='@') then blad_und(zm,tmpZM,41); end; if rodzaj<>__pVar then if txt[1]='#' then txt[1]:=' '; case rodzaj of __pDef: ety:=ety+#39+chr(v)+#39+','; __pReg: case chr(v) of '#': case t_par[idx+k][1] of // przez wartosc 'B': ety:=ety+'LD'+t_par[idx+k][2]+'#'+txt; 'W': ety:=ety+'LD'+t_par[idx+k][2]+'>'+txt + '\ LD'+t_par[idx+k][3]+'<'+txt; 'L': ety:=ety+'LD'+t_par[idx+k][2]+'^'+txt + '\ LD'+t_par[idx+k][3]+'>'+txt + '\ LD'+t_par[idx+k][4]+'<'+txt; end; ' ': case t_par[idx+k][1] of // przez adres 'B': ety:=ety+'LD'+t_par[idx+k][2]+' '+txt; 'W': ety:=ety+'LD'+t_par[idx+k][2]+' '+txt + '+1\ LD'+t_par[idx+k][3]+' '+txt; 'L': begin 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; if dreloc.use then warning(86); // typ 'L' nie jest relokowalny end; end; '@': if t_par[idx+k][2]<>'A' then ety:=ety+'TA'+t_par[idx+k][2]; end; __pVar: case chr(v) of '#',' ': case t_par[idx+k][1] of // przez wartosc '#' lub wartosc spod adresu ' ' 'B': ety:=ety+'MVA '+txt+' '+tmpZM; 'W': ety:=ety+'MWA '+txt+' '+tmpZM; 'L': case chr(v) of '#': begin txt[1]:='('; txt:='#'+txt+')'; ety:=ety+' MWA '+txt+'&$FFFF '+tmpZM+'\'; ety:=ety+' MVA '+txt+'>>16 '+tmpZM+'+2\'; end; ' ': begin ety:=ety+' MWA '+txt+' '+tmpZM+'\'; ety:=ety+' MVA '+txt+'+2 '+tmpZM+'+2'; end; end; 'D': case chr(v) of '#': begin txt[1]:='('; txt:='#'+txt+')'; ety:=ety+' MWA '+txt+'&$FFFF '+tmpZM+'\'; ety:=ety+' MWA '+txt+'>>16 '+tmpZM+'+2\'; end; ' ': begin ety:=ety+' MWA '+txt+' '+tmpZM+'\'; ety:=ety+' MWA '+txt+'+2 '+tmpZM+'+2'; end; end; end; '@': ety:=ety+'STA '+tmpZM; end; end; if rodzaj=__pDef then begin ety:=ety+#39+t_par[idx+k][1]+#39+','; if txt[1] = '@' then ety:=ety+'0' else ety:=ety+'"'+txt+'"'; end else ety:=ety+'\ '; end; if rodzaj=__pDef then txt:=ety+' \ @CALL '+#39+'X'+#39+','+t_prc[indeks].nam + ' \ @EXIT '+IntToStr(t_prc[indeks].ile) + str else txt:=ety+'JSR '+t_prc[indeks].nam; k:=line_add; line_add:=line-1; _odd:=High(t_mac); // procedura z parametrami t_mac[_odd]:=txt; // wymuszamy wykonanie większej liczby linii _doo:=_odd+1; analizuj_mem__(_odd,_doo, zm,a,old_str, 0,1, false); line_add:=k; bez_lst:=true; end else begin txt:='JSR '+ t_prc[indeks].nam; // procedura bez parametrow i:=1; mne:=oblicz_mnemonik(i,txt,zm); // wymuszamy wykonanie jednej linii z JSR end; ety:=''; end; (*----------------------------------------------------------------------------*) (* .ERROR [ERT] 'text' | .ERROR [ERT] expression *) (*----------------------------------------------------------------------------*) if (mne.l in [__error,__ert]) and macro_rept_if_test then if pass=pass_end then begin save_lst(' '); txt:=get_string(i,zm,txt,true); if txt<>'' then begin if not(run_macro) then writeln(zm) else writeln(old_str); str:=end_string; end_string:=''; wypisz(i,zm); // !!! modyfikowana jest zmienna ZM !!! txt:=txt+end_string; end_string:=str; blad(txt,34); end else begin branch := true; // tutaj nie ma mowy o relokowalnosci war:=___wartosc_noSPC(zm,zm,i,',','F'); if war<>0 then begin if not(run_macro) then writeln(zm) else writeln(old_str); str:=end_string; end_string:=''; wypisz(i,zm); // !!! modyfikowana jest zmienna ZM !!! if end_string='' then txt:=load_mes(30+1) // User error else txt:=end_string; end_string:=str; blad(txt,34); end; end; end else mne.l:=__nill; (*----------------------------------------------------------------------------*) (* .EXIT *) (*----------------------------------------------------------------------------*) if (mne.l=__exit) and macro_rept_if_test then if not(run_macro) then blad(zm,58) else begin save_lab(ety,adres,bank,zm); save_lst(' '); wymus_zapis_lst(zm); run_macro:=false; wyjscie:=true; ety:=''; exit; end; (*----------------------------------------------------------------------------*) (* .ENDP *) (*----------------------------------------------------------------------------*) if (mne.l=__endp) and macro_rept_if_test then if ety<>'' then blad(zm,38) else if not(proc) then blad(zm,39) else begin save_lst(' '); oddaj_var; oddaj_lokal(zm); t_prc[proc_nr-1].len := cardinal(adres) - t_prc[proc_nr-1].adr; proc_nr := t_prc[proc_nr-1].pnr; // !!! koniecznie ta kolejnosc inaczej zawsze PROC_NR=0 !!! get_address_update; proc := t_prc[proc_nr].prc; org_ofset := t_prc[proc_nr].oof; proc_name := t_prc[proc_nr].pnm; end; (*----------------------------------------------------------------------------*) (* label .PROC [label] *) (* jesli wystepuja parametry ograniczone nawiasami '()' to zapamietaj je *) (*----------------------------------------------------------------------------*) if (mne.l=__proc) and macro_rept_if_test then if adres<0 then blad(zm,10) else begin if ety='' then ety:=get_lab(i,zm, true); save_lst('a'); txt:=zm; zapisz_lst(txt); bez_lst:=true; label_type:='P'; if not(proc) then ety:=lokal_name+ety else ety:=proc_name+ety; zapisz_lokal; lokal_name:=''; t_prc[proc_idx].prc := proc; t_prc[proc_idx].pnr := proc_nr; t_prc[proc_idx].oof := org_ofset; t_prc[proc_idx].pnm := proc_name; proc_nr:=proc_idx; // koniecznie przez ADD_PROC_NR get_address(i,zm); // pobieramy nowy adres asemblacji dla .PROC save_end(__endp); proc_lokal:=end_idx; // koniecznie po SAVE_END, nie wczesniej save_lst('a'); proc_name:=''; if (pass=pass_end) and not(exclude_proc) and not(dreloc.use) then if not(t_prc[proc_nr].use) then blad_und(zm,ety,69); txt:=zm; // jesli TXT<>ZM to UPD_PROCEDURE zmodyfikowala ZM jakims makrem if pass=0 then get_procedure(ety,ety,zm ,i) // zapamietujemy parametry procedury else upd_procedure(ety,zm,adres); // uaktualniamy adresy procedury add_proc_nr; // nowa wartosc PROC_NR, PROC_IDX if (txt<>zm) and proc {and (pass>0)} then begin save_lst(' '); i:=1; mne:=oblicz_mnemonik(i,zm,zm); end; proc := true; proc_name := ety+'.'; ety:='' end; (*----------------------------------------------------------------------------*) (* wykonaj .STRUCT (np. deklaracja pola struktury za pomoca innej struktury) *) (* możliwe jest przypisanie pol zdefiniowanych przez strukture nowej zmiennej*) (*----------------------------------------------------------------------------*) if mne.l in [__struct_run, __struct_run_noLabel, __enum_run] then if ety='' then blad(zm,15) else if macro_rept_if_test then begin if (mne.l=__enum_run) and struct.use then mne.l:=__byteValue+mne.i // typ wyliczeniowy na rozmiar w bajtach else begin create_struct_variable(zm, ety, mne, true, adres); ety:=''; end; end; (*----------------------------------------------------------------------------*) (*----------------------------------------------------------------------------*) (*----------------------------------------------------------------------------*) case mne.l of (*----------------------------------------------------------------------------*) (* wykonaj .MACRO gdy PASS>0 *) (*----------------------------------------------------------------------------*) __macro_run: // if macro then halt {inc(macro_nr)} else if if_test then begin save_lab(ety,adres,bank,zm); if not(FOX_ripit) then save_lst('i'); txt:=zm; zapisz_lst(txt); indeks:=mne.i; old_komentarz:=komentarz; // zapamietujemy aktualne makro w 'OLD_MACRO_NR' old_macro_nr:=macro_nr; txt:=t_mac[indeks+1]; str:='Macro: '+txt+' [Source: '+t_mac[indeks+0]+']'; // !!! nazwa obszaru LOCAL powtorzy sie 2x - KONIECZNIE !!! if macro_nr='' then macro_nr:=macro_nr+lokal_name+proc_name+txt+t_mac[indeks+3]+'.' else macro_nr:=macro_nr+proc_name+txt+t_mac[indeks+3]+'.'; omin_spacje(i,zm); SetLength(par,2); // na pozycji par[0] zostanie wpisana liczba parametrow k:=ord(t_mac[indeks+2][1]); // tryb pracy ch:=t_mac[indeks+2][2]; // separator while not(test_char(i,zm,#0,#0)) do begin txt:=get_dat(i,zm,ch,true); // jesli to licznik petli FOX_RIPIT '#' (lub .R) to wyliczymy wartosc if (txt='#') or (txt='.R') then begin war:=oblicz_wartosc(txt,zm); txt:=IntToStr(war); end; // jesli przekazywany parametr jest miedzy apostrofami " " to jest to ciag znakowy if txt<>'' then if (txt[1]='"') and (txt[length(txt)]='"') then txt:=copy(txt,2,length(txt)-2); _odd:=High(par); if k=byte('''') then begin par[_odd]:=txt; SetLength(par,_odd+2); end else begin if txt[1]='#' then begin par[_odd]:='''#'''; txt:=copy(txt,2,length(txt)); end else if txt[1] in ['<','>'] then begin par[_odd]:='''#'''; war:=oblicz_wartosc(txt,zm); txt:=IntToStr(war); end else par[_odd]:=''' '''; SetLength(par,_odd+3); par[_odd+1]:=txt; end; // omin_spacje(i,zm); if zm[i] in [',',' ',#9] then __next(i,zm); if ch<>' ' then if zm[i]=ch then __inc(i,zm); // else Break; end; // zapisujemy liczbe parametrow dla :0 par[0]:=IntToStr(Int64(High(par))-1); // zwiekszamy numer wywolania makra T_MAC[indeks+3], T_MAC[indeks+5] // !!! koniecznie w tym miejscu !!! _doo:=integer( StrToInt(t_mac[indeks+3]) ); t_mac[indeks+3]:=IntToStr(Int64(_doo)+1); _doo:=integer( StrToInt(t_mac[indeks+5]) ); t_mac[indeks+5]:=IntToStr(Int64(_doo)+1); // !!! zabezpieczenie przed rekurencja bez konca !!! // zatrzymujemy wykonanie makra jesli liczba wywolan przekroczy 255 if _doo>255 then blad(zm,66); _doo:=integer( StrToInt(t_mac[indeks+4]) ); // numer linii txt:=t_mac[indeks]; // nazwa pliku z aktualnie wykonywanym makrem inc(wyw_idx); if wyw_idx>High(t_wyw) then SetLength(t_wyw,wyw_idx+1); t_wyw[wyw_idx].zm := zm; // jesli wystapi blad to te dane pomoga go zlokalizowac t_wyw[wyw_idx].pl := txt; t_wyw[wyw_idx].nr := _doo; // zapamietujemy aktualny indeks do T_MAC w _ODD // odczytujemy makro z T_MAC[indeks], podstawiamy parametry i zapisujemy do T_MAC // potem zwolnimy miejsce na podstawie wczesniej zapamietanego indeksu w _ODD _odd:=High(t_mac); while true do begin txt:=t_mac[indeks+6]; j:=1; ety:=get_datUp(j,txt,#0,false); // wczytujemy nieznany ciag duzych liter if not(fCRC16(ety)=__endm) then begin // aby odnalezc wpis .ENDM, .MEND j:=1; while j<=length(txt) do if test_param(j,txt) then begin k:=j; if txt[j]=':' then inc(j) else inc(j,2); ety:=''; while _dec(txt[j]) do begin ety:=ety+txt[j]; inc(j) end; war:=StrToInt(ety); delete(txt,k,j-k); dec(j,j-k); if war>Int64(High(par))-1 then begin insert('$FFFFFFFF',txt,k); inc(j,9); // musi koniecznie wpisac ciag $FFFFFFFF end else begin insert(par[war],txt,k); inc(j,length(par[war])); end; end else inc(j); save_mac(txt); end else Break; inc(indeks); end; if not(FOX_ripit) and not(rept_run) then put_lst(str); // zapamietaj w zmiennych lokalnych indeks := line_add; line_add := 0; old_rept := ___rept_ile; par := reptPar; old_case := rept_run; rept_run := false; old_run_macro := run_macro; old_ifelse := ifelse; old_loopused := loop_used; komentarz := old_komentarz; run_macro := true; loop_used := false; _doo:=High(t_mac); // for idx:=_odd to _doo-1 do writeln(t_mac[idx],' | '); halt; analizuj_mem__(_odd,_doo, zm,a,old_str, idx,idx+1, false); if not(FOX_ripit) then bez_lst:=true; if run_macro and (old_ifelse<>ifelse) then blad(zm,1); run_macro := old_run_macro; t_mac[mne.i+5]:='0'; loop_used := old_loopused; rept_run := old_case; ifelse := old_ifelse; macro_nr := old_macro_nr; ___rept_ile := old_rept; reptPar := par; line_add := indeks; if not(lst_off) and not(FOX_ripit) and not(rept_run) then put_lst(show_full_name(a,full_name,true)); dec(wyw_idx); SetLength(t_mac,_odd+1); ety:=''; end; (*----------------------------------------------------------------------------*) (* label .MACRO [label] *) (* wystapienie dyrektywy .MACRO oznacza conajmniej 3 przebiegi asemblacji *) (*----------------------------------------------------------------------------*) __macro: begin if ety='' then ety:=get_lab(i,zm, true); if (pass=0) and if_test then begin // Konop postulowal aby przywrocic makra z blokow PROC // if proc then t_prc[proc_nr-1].use:=true; // jesli makro w .PROC to takie .PROC zawsze w uzyciu reserved_word(ety,zm{, false}); save_lab(ety,High(t_mac),__id_macro,zm); str:=show_full_name(a,full_name,false); save_mac(str); // zapisanie nazwy pliku z makrem str:={lokal_name+}ety; save_mac(str); // zapisanie nazwy makra ety:=''''; ch:=','; omin_spacje(i,zm); if zm[i] in ['''','"'] then begin // wczytujemy i sprawdzamy poprawnosc ety:=zm[i]; str:=get_string(i,zm,zm,true); if str<>'' then ch:=str[1]; // if length(txt)>1 then blad(zm,3) else // if txt='' then txt:=','; end; omin_spacje(i,zm); if not(test_char(i,zm,#0,#0)) then blad(zm,4); str:=ety+ch; save_mac(str); // separator i tryb dzialania str:='0'; save_mac(str); // numer wywolania makra str:=IntToStr(line); save_mac(str); // numer linii z makrem str:='0'; save_mac(str); // licznik wywolan dla testu 'infinite loop' if pass_end<3 then pass_end:=3; // jesli sa makra to musza byc conajmniej 3 przebiegi end; macro := true; save_lst(' '); // save_end(__endm); ety:='' end; (*----------------------------------------------------------------------------*) (* .IF [IFT] expression *) (*----------------------------------------------------------------------------*) __if, __ifndef, __ifdef: begin save_lab(ety,adres,bank,zm); txt:=zm; // TXT = ZM, w celu pozniejszej modyfikacji TXT if mne.l in [__ifndef, __ifdef] then begin insert('.DEF',txt,i); if mne.l=__ifndef then insert('.NOT ',txt,i); end; if_stos[ifelse].old_iftest := if_test; inc(ifelse); if ifelse>High(if_stos) then SetLength(if_stos,ifelse+1); if_stos[ifelse]._okelse:=$7FFFFFFF; // zablokowany .ELSE if if_test then begin save_lst(' '); if_stos[ifelse]._else := false; if_stos[ifelse]._okelse := ifelse; branch := true; // tutaj nie ma mowy o relokowalnosci war:=___wartosc_noSPC(txt,zm,i,#0,'F'); if_test := (war<>0); end; if_stos[ifelse]._if_test := if_test; ety:=''; end; (*----------------------------------------------------------------------------*) (* .ENDIF [EIF] *) (*----------------------------------------------------------------------------*) __endif: if ety<>'' then blad(zm,38) else if ifelse>0 then begin dec(ifelse); // if_test := if_stos[ifelse]._if_test; // else_used := if_stos[ifelse]._else; if_test := if_stos[ifelse].old_iftest; end else blad(zm,37); (*----------------------------------------------------------------------------*) (* .ENDM *) (*----------------------------------------------------------------------------*) __endm: dec_end(zm, __endm); (*----------------------------------------------------------------------------*) (* .ELSE [ELS] *) (*----------------------------------------------------------------------------*) __else: if ety<>'' then blad(zm,38) else if if_stos[ifelse]._okelse=ifelse then begin if if_stos[ifelse]._else then blad(zm,1); if ifelse=0 then blad(zm,37); if_stos[ifelse]._else:=true; if_test := not(if_stos[ifelse]._if_test); end; (*----------------------------------------------------------------------------*) (* .PRINT 'string' [,string2...] [,expression1,expression2...] *) (*----------------------------------------------------------------------------*) __print: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if pass=pass_end then begin wypisz(i,zm); end; (*----------------------------------------------------------------------------*) (* .ELSEIF [ELI] expression *) (*----------------------------------------------------------------------------*) __elseif: if ety<>'' then blad(zm,38) else if if_stos[ifelse]._okelse=ifelse then begin // !!! konieczny warunek if if_stos[ifelse]._else then blad(zm,1); if ifelse=0 then blad(zm,37); if_test := not(if_stos[ifelse]._if_test); if if_test then begin save_lst(' '); branch:=true; // tutaj nie ma mowy o relokowalnosci war:=___wartosc_noSPC(zm,zm,i,#0,'F'); if_test := (war<>0); if_stos[ifelse]._if_test := if_test; // !!! koniecznie zapisz IF_TEST end; end; (*----------------------------------------------------------------------------*) (* label .LOCAL [label] *) (*----------------------------------------------------------------------------*) __local: if macro_rept_if_test then begin if ety='' then begin omin_spacje(i,zm); ety:=get_lab(i,zm, false); end; // jesli brak nazwy obszaru .LOCAL to przyjmij domyslna nazwe if ety='' then begin ety:='L@C?L?'+IntToStr(lc_nr); inc(lc_nr); end; if pass=0 then if ety[1]='?' then warning(8); t_loc[lokal_nr].ofs := org_ofset; get_address(i,zm); // nowy adres asemblacji dla .LOCAL if not(test_char(i,zm,#0,#0)) then blad(zm,4); new_local:=true; save_lab(ety, adres, bank, zm); new_local:=false; save_lst('a'); t_loc[lokal_nr].adr := adres; idx:=load_lab(ety, true); // !!! TRUE t_loc[lokal_nr].idx := idx; save_end(__endl); zapisz_lokal; lokal_name:=lokal_name+ety+'.'; ety:=''; end; (*----------------------------------------------------------------------------*) (* .ENDL *) (*----------------------------------------------------------------------------*) __endl: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if lokal_nr>0 then begin save_lst(' '); if not(proc) then oddaj_var; oddaj_lokal(zm); if t_loc[lokal_nr].idx>=0 then begin t_lab[t_loc[lokal_nr].idx].lln:=adres-t_loc[lokal_nr].adr; t_lab[t_loc[lokal_nr].idx].lid:=true; end; org_ofset := t_loc[lokal_nr].ofs; // dec(end_idx); get_address_update; end else blad(zm,28); (*----------------------------------------------------------------------------*) (* .REPT expression *) (*----------------------------------------------------------------------------*) __rept: if if_test then if rept then blad(zm,43) else begin save_lab(ety,adres,bank,zm); save_lst(' '); save_end(__endr); get_parameters(i,zm, reptPar, false, #0,#0); if High(reptPar)=0 then blad(zm,23); // Unexpected end of line rept_ile:=oblicz_wartosc(reptPar[0],zm); // REPT_ILE if rept_ile<0 then blad(zm, 0); // !!! mozliwa wartosc powyzej $ffff !!! // testRange(zm, rept_ile, 0); reptPar[0]:=IntToStr(Int64(High(reptPar))-1); // liczba parametrów przekazana do .REPT rept_nr := High(t_mac); // zapamietujemy indeks do T_MAC rept := true; ety:=IntToStr(___rept_ile); // zapisujemy aktualna wartosc ___REPT_ILE save_mac(ety); // !!! koniecznie po zapamietaniu indeksu !!! ety:=IntToStr(line); // zapisujemy numer wiersza z dyrektywa .REPT save_mac(ety); ety:=''; end; (*----------------------------------------------------------------------------*) (* .ENDR *) (*----------------------------------------------------------------------------*) __endr: begin dirENDR(zm,a,old_str,rept_nr,rept_ile); ety:=''; end; (*----------------------------------------------------------------------------*) (* label .STRUCT [label] *) (* wystapienie dyrektywy .STRUCT oznacza conajmniej trzy przebiegi asemblacji*) (*----------------------------------------------------------------------------*) __struct: if macro_rept_if_test then if struct.use then blad(zm,56) else begin if ety='' then ety:=get_lab(i,zm, true); if pass=0 then reserved_word(ety,zm{, false}); omin_spacje(i,zm); if not(test_char(i,zm,#0,#0)) then blad(zm,4); label_type:='C'; struct.drelocUSE := dreloc.use; struct.drelocSDX := dreloc.sdx; dreloc.use := false; dreloc.sdx := false; upd_structure(ety, zm); zapisz_lokal; lokal_name:=lokal_name+ety+'.'; struct.use := true; // zapamietujemy adres, aby oddac go po .ENDS struct.adres := adres; save_lst('a'); save_end(__ends); ety:=''; end; (*----------------------------------------------------------------------------*) (* .ENDS *) (* zapisujemy w tablicy 'T_STR' dlugosc i liczbe pol struktury *) (*----------------------------------------------------------------------------*) __ends: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if not(struct.use) then blad(zm,55) else begin save_lst(' '); oddaj_lokal(zm); struct.use := false; t_str[struct.idx].siz := adres - struct.adres; // zapisujemy dlugosc struktury t_str[struct.idx].ofs := struct.cnt; // i liczbe pol struktury adres := struct.adres; // zwracamy stary adres asemblacji inc(struct.id); // zwiekszamy identyfikator struktury (liczba struktur) struct.cnt := -1; // dec(end_idx); dec_end(zm, __ends); dreloc.use := struct.drelocUSE; dreloc.sdx := struct.drelocSDX; end; (*----------------------------------------------------------------------------*) (* .ENUM *) (*----------------------------------------------------------------------------*) __enum: if macro_rept_if_test then if enum.use then blad(zm,56) else begin if ety='' then ety:=get_lab(i,zm, true); if pass=0 then reserved_word(ety,zm{, false}); omin_spacje(i,zm); if not(test_char(i,zm,#0,#0)) then blad(zm,4); label_type:='C'; enum.drelocUSE := dreloc.use; enum.drelocSDX := dreloc.sdx; dreloc.use:=false; dreloc.sdx:=false; save_lab(ety, 0, __id_enum, zm); zapisz_lokal; lokal_name:=lokal_name+ety+'.'; enum.use := true; enum.val := 0; enum.max := 0; save_lst('a'); save_end(__ende); ety:=''; end; (*----------------------------------------------------------------------------*) (* .ENDE *) (*----------------------------------------------------------------------------*) __ende: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if not(enum.use) then blad(zm,55) else begin txt:=lokal_name; SetLength(txt, length(txt)-1); idx:=load_lab(txt,false); t_lab[idx].adr:=ValueToType(enum.max); save_lst(' '); oddaj_lokal(zm); enum.use := false; // dec(end_idx); dec_end(zm,__ende); dreloc.use := enum.drelocUSE; dreloc.sdx := enum.drelocSDX; end; (*----------------------------------------------------------------------------*) (* zapisujemy wartosc do tablicy .ARRAY *) (*----------------------------------------------------------------------------*) __array_run: if ety<>'' then blad(zm,38) else begin get_data_array(i,zm, t_arr[array_idx-1].idx, t_arr[array_idx-1].siz); end; (*----------------------------------------------------------------------------*) (* .ARRAY *) (* tablica ze zdefiniowanymi wartosciami *) (*----------------------------------------------------------------------------*) __array: if aray then blad(zm,60) else if macro_rept_if_test then begin if ety='' then ety:=get_lab(i,zm, true); if pass=0 then reserved_word(ety,zm{, true}); save_lab(ety, array_idx, __id_array, zm); save_lst('a'); save_arr(adres, bank); // tutaj ARRAY_IDX zostaje zwiekszone o 1 omin_spacje(i,zm); // od tego momentu uzywamy ARRAY_IDX-1 if zm[i]<>'.' then begin txt:=get_dat(i,zm,' ',true); idx := integer( oblicz_wartosc(txt,zm) ); t_arr[array_idx-1].def:=true; // okreslony rozmiar tablicy end else begin idx:=$FFFF; t_arr[array_idx-1].def:=false; // brak rozmiaru tablicy end; array_used.max:=0; t_arr[array_idx-1].idx:=idx; r:=get_type(i,zm,zm,true); t_arr[array_idx-1].siz := r; if not(t_arr[array_idx-1].def) then idx:=idx div r; t_arr[array_idx-1].len := (idx+1)*r; //if (idx<0) or (t_arr[array_idx-1].len>$FFFF) then blad(zm,62); testRange(zm, idx, 62); if t_arr[array_idx-1].len-1>$FFFF then blad(zm,62); array_used.typ := tType[ t_arr[array_idx-1].siz ]; war:=0; // dopuszczalna maksymalna wartosc typu D-WORD omin_spacje(i,zm); if zm[i]='=' then begin __inc(i,zm); war:=oblicz_wartosc_noSPC(zm,zm,i,#0,tType[r]); end; omin_spacje(i,zm); if not(test_char(i,zm,#0,#0)) then blad(zm,4); for j:=0 to idx do t_tmp[j]:=cardinal(war); // FILLCHAR wypelnia tylko bajtami aray := true; save_end(__enda); ety:=''; end; (*----------------------------------------------------------------------------*) (* .ENDA *) (*----------------------------------------------------------------------------*) __enda: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if not(aray) then blad(zm,59) else begin aray := false; v := t_arr[array_idx-1].siz; if t_arr[array_idx-1].def then // okreslony rozmiar tablicy _doo := t_arr[array_idx-1].idx+1 else begin _doo := array_used.max ; // rozmiar tablicy na podstawie ilosci danych t_arr[array_idx-1].idx := _doo-1; t_arr[array_idx-1].len := _doo*v; if t_arr[array_idx-1].len-1>$FFFF then blad(zm,62); end; for idx:=0 to _doo-1 do save_dta(t_tmp[idx],zm, tType[v],0); t:=''; save_lst(' '); // dec(end_idx); dec_end(zm,__enda); end; (*----------------------------------------------------------------------------*) (* label EXT type *) (*----------------------------------------------------------------------------*) __ext: if ety='' then blad(zm,15) else if macro_rept_if_test then if loop_used then blad(zm,36) else begin v := get_typeExt(i,zm); save_extLabel(i,ety,zm,v); nul.i:=0; save_lst('l'); ety:=''; end; (*----------------------------------------------------------------------------*) (* .EXTRN label .PROC (par1, par2, ...) [.var]|[.reg] *) (* .EXTRN label1, label2, label3 ... type *) (* rozbudowany odpowiednik pseudo rozkazu EXT *) (*----------------------------------------------------------------------------*) __extrn: if macro_rept_if_test then begin // if loop_used then blad(zm,36) else begin nul.i:=0; save_lst('l'); v:=0; if ety='' then begin // jesli .EXTRN nie poprzedza etykieta while true do begin get_parameters(i,zm,par,false, '.',':'); v:=get_typeExt(i,zm); _doo:=High(par); if _doo=0 then blad(zm,15); for _odd:=_doo-1 downto 0 do begin txt:=par[_odd]; if txt<>'' then save_extLabel(i,txt,zm,v) else blad(zm,15); end; omin_spacje(i,zm); if (v=__proc) or (test_char(i,zm,#0,#0)) then Break; end; end else begin // jesli .EXTRN poprzedza etykieta v := get_typeExt(i,zm); save_extLabel(i,ety,zm,v); end; ety:=''; end; (*----------------------------------------------------------------------------*) (* .VAR label1, label2, label3 ... TYPE [=address] *) (* .VAR TYPE label1, label2 .... *) (* .ZPVAR label1, label2, label3 ... TYPE [=address] *) (* .ZPVAR TYPE label1, label2 .... *) (*----------------------------------------------------------------------------*) __var, __zpvar: if ety<>'' then blad(zm,38) else if (pass>0) and macro_rept_if_test then // if (adres<0) and (mne.l=__var) then blad(zm,10) else if rept_run then blad(zm,36) else begin // nul.i:=0; save_lst('a'); if pass_end<3 then pass_end:=3; // !!! potrzebne conajmniej 3 przebiegi !!! while true do begin get_vars(i,zm,par, mne.l); omin_spacje(i,zm); if test_char(i,zm,#0,'=') then Break; end; txt:=zm; // sprawdz czy zostal okreslony adres umiejscowienia zmiennych '= ADDRESS' idx:=-1; if High(par)>var_idx then begin // deklaracja typu przez .STRUCT lub .ENUM i:=1; txt:=par[var_idx]; end; if txt<>'' then if txt[i]='=' then begin // nowy adres alokacji inc(i); idx:=integer( oblicz_wartosc_noSPC(txt,zm,i,#0,'A') ); testRange(zm,idx,87); end; if mne.l=__zpvar then begin if idx>=0 then zpvar:=idx; for _doo:=0 to var_idx-1 do if t_var[_doo].id=var_id then begin t_var[_doo].adr:=zpvar; t_var[_doo].zpv:=true; if zpvar+t_var[_doo].cnt*t_var[_doo].siz>256 then blad(zm,0) else for k:=0 to t_var[_doo].cnt*t_var[_doo].siz-1 do begin if (pass=pass_end) and t_zpv[zpvar] then warning(109); t_zpv[zpvar]:=true; inc(zpvar); end; end; end else begin if idx>=0 then for _doo:=0 to var_idx-1 do if t_var[_doo].id=var_id then begin t_var[_doo].adr:=idx; t_var[_doo].zpv:=false; inc(idx, t_var[_doo].cnt*t_var[_doo].siz); end; end; inc(var_id); ety:=''; end; (*----------------------------------------------------------------------------*) (* .BY [+byte] bytes and/or ASCII *) (* .WO words *) (* .HE hex bytes *) (*----------------------------------------------------------------------------*) __by, __wo, __he, __sb: if (mne.l<>__he) and (dreloc.use or dreloc.sdx) then blad(zm,71) else if macro_rept_if_test then begin save_lab(ety,adres,bank,zm); case mne.l of __by: get_maeData(zm,i,'B'); __wo: get_maeData(zm,i,'W'); __he: get_maeData(zm,i,'H'); __sb: get_maeData(zm,i,'S'); end; ety:=''; end; (*----------------------------------------------------------------------------*) (* .WHILE .TYPE ARG1 OPERAND ARG2 [.AND|.OR .TYPE ARG3 OPERAND ARG4] *) (*----------------------------------------------------------------------------*) __while: if macro_rept_if_test then begin // if loop_used then blad(zm,36) else begin // if ety='' then ety:=get_lab(i,zm, true); save_lab(ety,adres,bank,zm); save_lst('a'); if while_name='' then while_name:=lokal_name; while_name:=while_name+IntToStr(while_nr)+'.'; // sciezka dostepu do WHILE long_test:=''; wyrazenie_warunkowe(i, long_test, zm,txt,tmp,v,r, '\EX LDA#0\:?J/2-1 ORA#0\.ENDL'); // if long_test<>'' then begin // create_long_test(v, r, long_test, txt, tmp); // long_test:=long_test+'\EX LDA#0\:?J/2-1 ORA#0\.ENDL'; // end; save_end(__endw); ety:=__while_label+while_name; // poczatek .WHILE save_fake_label(ety,zm,adres); ety:=__endw_label+while_name; // koniec WHILE if long_test='' then mne := asm_test(txt,tmp,zm, ety, r,v) else begin idx:=High(t_mac); _odd:=idx+1; t_mac[idx]:=long_test+'\ JEQ '+ety; line_add:=line-1; save_lst('i'); txt:=zm; zapisz_lst(txt); opt_tmp:=opt; opt:=opt and (not(4)); code6502:=true; analizuj_mem__(idx,_odd, zm,a,old_str, 0,1, false); code6502:=false; line_add:=0; opt:=opt_tmp; bez_lst:=true; end; inc(whi_idx); inc(while_nr); ety:=''; end; (*----------------------------------------------------------------------------*) (* .ENDW *) (*----------------------------------------------------------------------------*) __endw: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if whi_idx>0 then begin // if loop_used then blad(zm,36) else begin save_lst('a'); dec(whi_idx); ety:=__while_label+while_name; war:=load_lab(ety,false); // odczytujemy wartosc etykiety poczatku petli WHILE ##B if war>=0 then begin tst:=t_lab[war].adr; save_relAddress(integer(war), reloc_value); if pass=pass_end then if t_lab[war].bnk<>bank then warning(70); // petla .WHILE musi znajdowac sie w obszarze tego samego banku end else tst:=0; txt:='JMP '+IntToStr(tst); k:=1; mne:=oblicz_mnemonik(k,txt,zm); ety:=__endw_label+while_name; idx := adres + 3; // E## = aktualny adres + 3 bajty (JMP) save_fake_label(ety,zm,idx); obetnij_kropke(while_name); // dec(end_idx); dec_end(zm,__endw); ety:=''; end else blad(zm,88); (*----------------------------------------------------------------------------*) (* .TEST .TYPE ARG1 OPERAND ARG2 [.AND|.OR .TYPE ARG3 OPERAND ARG4] *) (*----------------------------------------------------------------------------*) __test: if macro_rept_if_test then begin save_lab(ety,adres,bank,zm); save_lst('a'); if test_name='' then test_name:=lokal_name; test_name:=test_name+IntToStr(test_nr)+'.'; // sciezka dostepu do TEST long_test:=''; wyrazenie_warunkowe(i, long_test,zm,txt,tmp,v,r, '\EX LDA#0\:?J/2-1 ORA#0\.ENDL'); // if long_test<>'' then begin // create_long_test(v, r, long_test, txt, tmp); // long_test:=long_test+'\EX LDA#0\:?J/2-1 ORA#0\.ENDL'; // end; save_end(__endt); ety:=__test_label+test_name; // poczatek #IF __TEST_LABEL save_fake_label(ety,zm,adres); ety:=__telse_label+test_name; // sprawdzamy czy wystapilo #ELSE if load_lab(ety,false)<0 then ety:=__endt_label+test_name; // jesli nie bylo #ELSE to skok do #END if long_test='' then mne := asm_test(txt,tmp,zm, ety, r,v) else begin idx:=High(t_mac); _odd:=idx+1; t_mac[idx]:=long_test+'\ JEQ '+ety; line_add:=line-1; save_lst('i'); txt:=zm; zapisz_lst(txt); opt_tmp:=opt; opt:=opt and (not(4)); code6502:=true; analizuj_mem__(idx,_odd, zm,a,old_str, 0,1, false); code6502:=false; line_add:=0; opt:=opt_tmp; bez_lst:=true; end; t_els[test_idx]:=false; inc(test_idx); if test_idx>High(t_els) then SetLength(t_els, test_idx+1); inc(test_nr); ety:=''; end; (*----------------------------------------------------------------------------*) (* .TELSE *) (*----------------------------------------------------------------------------*) __telse: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if test_idx>0 then begin if t_els[test_idx-1] then blad(zm,95); txt:='JMP '+__endt_label+test_name; mne:=asm_mnemo(txt, zm); t_els[test_idx-1]:=true; ety:=__telse_label+test_name; // adres #ELSE __TELSE_LABEL save_fake_label(ety,zm,adres); dec(adres, mne.l); ety:=''; end else blad(zm,95); (*----------------------------------------------------------------------------*) (* .ENDT *) (*----------------------------------------------------------------------------*) __endt: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if test_idx>0 then begin // if loop_used then blad(zm,36) else begin save_lst('a'); dec(test_idx); ety:=__test_label+test_name; war:=load_lab(ety,false); // adres #IF __TEST_LABEL if war>=0 then if pass=pass_end then if t_lab[war].bnk<>bank then warning(70); // TEST musi znajdowac sie w obszarze tego samego banku ety:=__endt_label+test_name; // adres #END dla bloku #IF __ENDT_LABEL save_fake_label(ety,zm,adres); obetnij_kropke(test_name); // dec(end_idx); dec_end(zm,__endt); ety:=''; end else blad(zm,95); (*----------------------------------------------------------------------------*) (* .DEF label *) (*----------------------------------------------------------------------------*) __def: if ety<>'' then blad(zm,38) else if macro_rept_if_test then begin idx:=adres; omin_spacje(i,zm); label_type:='V'; if zm[i]=':' then begin old_case:=true; // zostal uzyty znak ':' w nazwie etykiety inc(i); end else old_case:=false; // znak ':' nie zostal uzyty w nazwie etykiety ety:=get_lab(i,zm,true); omin_spacje(i,zm); txt:=zm; // podstawiamy ZM pod TXT if txt[i] in ['+','-'] then if txt[i+1] in ['+','-','='] then operator_zlozony(i,txt,ety, old_case); if txt[i]='=' then begin __inc(i,txt); variable:=false; idx:=oblicz_wartosc_noSPC(txt,zm,i,#0,'W'); if not(variable) then label_type:='C'; end else if not(test_char(i,txt,#0,#0)) then blad(zm,58); nul.i:=idx; save_lst('l'); data_out := true; // wymus pokazanie w pliku LST podczas wykonywania makra // !!! jesli wystapila dyrektywa .IFNDEF to nie pokaze !!! old_run_macro := run_macro; run_macro := false; // old_loopused := dreloc.use; // dreloc.use := false; mne_used := true; if old_case then s_lab(ety,idx,bank,zm,ety[1]) // etykieta globalna else save_lab(ety,idx,bank,zm); // etykieta w aktualnym zasiegu run_macro := old_run_macro; // dreloc.use := old_loopused; ety:=''; end; (*----------------------------------------------------------------------------*) (* .USING label [,label2...] *) (*----------------------------------------------------------------------------*) __using: if ety<>'' then blad(zm,38) else if macro_rept_if_test then begin save_lst('i'); get_parameters(i,zm,par,false, '.',':'); if pass>0 then for k:=High(par)-1 downto 0 do begin txt:=par[k]; _odd:=load_lab(txt, false); if _odd<0 then blad_und(zm,txt,5); t_usi[usi_idx].lok:=end_idx; t_usi[usi_idx].lab:=txt; if proc then t_usi[usi_idx].nam:=proc_name else t_usi[usi_idx].nam:=lokal_name; inc(usi_idx); SetLength(t_usi, usi_idx+1); end; end; (*----------------------------------------------------------------------------*) (* .FL *) (*----------------------------------------------------------------------------*) __fl: if macro_rept_if_test then begin save_lab(ety,adres,bank,zm); save_lst('a'); omin_spacje(i,zm); while not(test_char(i,zm,#0,#0)) do begin txt:=get_dat(i,zm,',',true); save_fl(txt, zm); if zm[i] in [',',' ',#9] then __next(i,zm) else Break; end; ety:=''; end; (*----------------------------------------------------------------------------*) (* label EQU [=] expression *) (*----------------------------------------------------------------------------*) __equ,__smb,__addEqu: if ety='' then blad(zm,15) else if macro_rept_if_test then if loop_used then blad(zm,36) else begin if dreloc.use then if mne.l in [__equ,__smb] then blad(zm,71); label_type:='C'; old_case := dreloc.use; // deklaracje etykiet w bloku .RELOC nie moga byc relokowalne dreloc.use := false; if mne.l=__smb then begin // SMB txt:=get_smb(i,zm); // wymuszamy relokowalnosc dla tej etykiety // jesli BLOK>1 to zaznaczy jako etykiete relokowalna k:=blok; blok:=$FFFF; save_lab(ety,smb_idx,__id_smb,zm); blok:=k; // zapisujemy etykiete symbolu SMB w tablicy T_SMB t_smb[smb_idx].smb:=txt; // SAVE_SMB inc(smb_idx); // if smb_idx>High(t_smb) then SetLength(t_smb,smb_idx+1); // war:=__rel; end else begin // EQU, addEQU branch:=true; // dla EQU i addEQU nie ma relokowalnosci // nie mozna przypisac wartosci etykiety EXTERNAL, SMB (BLOCKED = TRUE) blocked := true; // sprawdzamy czy deklaracja etykiety powiodla sie (UNDECLARED = FALSE) // procedura OBLICZ_WARTOSC zmodyfikuje UNDECLARED na TRUE jesli wystapi // proba odwolania do niezdefiniowanej etykiety undeclared:=false; variable:=false; war:=___wartosc_noSPC(zm,zm,i,#0,'F'); if variable then label_type:='V'; blocked := false; // !!! koniecznie przywracamy BLOCKED = FALSE !!! mne_used:=true; // konieczny test dla zmieniajacych sie wartosci etykiet save_lab(ety,cardinal(war),bank,zm); _odd:=load_lab(ety, true); // !!! TRUE if _odd>=0 then t_lab[_odd].sts := undeclared; undeclared:=false; // !!! koniecznie przywracamy UNDECLARED = FALSE !!! data_out := true; // wymus pokazanie w pliku LST podczas wykonywania makra mne_used := false; end; nul.i:=integer( war ); save_lst('l'); if mne.l=__addEqu then begin zapisz_lst(tmpZM); zm:=''; end; dreloc.use := old_case; ety:=''; end; (*----------------------------------------------------------------------------*) (* OPT holscmtb?f +- *) (*----------------------------------------------------------------------------*) (* bit *) (* 0 - Header default = yes 'h+' *) (* 1 - Object file default = yes 'o+ *) (* 2 - Listing default = no 'l-' *) (* 3 - Screen (listing on screen) default = no 's-' *) (* 4 - CPU 8bit/16bit default = 6502 'c-' *) (* 5 - visible macro default = no 'm-' *) (* 6 - track sep rep default = no 't-' *) (* 7 - banked mode default = no 'b-' *) (*----------------------------------------------------------------------------*) __opt: if macro_rept_if_test then begin txt:=get_dat_noSPC(i,zm,',',#0,zm); // pomijamy spacje j:=1; while j<=length(txt) do begin ch:=txt[j+1]; opt_tmp:=opt; tst:=0; case UpCase(txt[j]) of 'F': raw.use:= (ch='+'); 'H': tst:=1; 'O': tst:=2; 'L': tst:=4; 'S': tst:=8; 'C': tst:=16; 'M': tst:=32; 'T': tst:=64; 'B': tst:=128; '?': mae_labels:= (ch='+'); 'R': regAXY_opty:= (ch='+'); else blad(zm,16); end; case ch of '+': opt:=opt or tst; '-': opt:=opt and (not(tst)); else blad(zm,16); end; if (opt_tmp and 1)<>(opt and 1) then // OPT H- if (opt and 1)=0 then save_hea; inc(j,2); end; data_out:=true; save_lst(' '); end; (*----------------------------------------------------------------------------*) (* ORG adres [,adres2] *) (* RUN adres *) (* INI adres *) (* BLK *) (*----------------------------------------------------------------------------*) __org, __run, __ini, __blkSpa, __blkRel, __blkEmp: if if_test then if loop_used or rept then blad(zm,36) else if dreloc.use then blad(zm,71) else if first_org and (ety<>'') then blad(zm,10) else begin if (org_ofset>0) and ((lokal_name<>'') or proc) then blad(zm,71); if hea_ofs.adr>=0 then raw.old := hea_ofs.adr+(adres-hea_ofs.old) else raw.old := adres; label_type:='V'; data_out:=true; save_lst('a'); branch:=true; // relokowalnosc tutaj niemozliwa rel_ofs:=0; {org_ofs:=0;} idx:=-$FFFF; hea_ofs.adr:=-1; _odd:=-1; save_lab(ety,adres,bank,zm); omin_spacje(i,zm); r := mne.l; // !!! koniecznie V := MNE.L !!! aby zadzialalo RUN, INI // !!! RUN, INI modyfikuja MNE.L !!! case r of // BLK SPARTA a __blkSpa: begin dreloc.sdx:=true; blok:=0; opt_tmp:=opt; opt_h_minus; // a($fffa),a(str_adr),a(end_adr) save_dstW( $fffa ); idx:=integer( ___wartosc_noSPC(zm,zm,i,',','A') ); opt:=opt_tmp; end; //BLK R[eloc] M[ain]|E[xtended] __blkRel: begin dreloc.sdx:=true; ds_empty:=0; opt_tmp:=opt; opt_h_minus; v := getMemType(i,zm); add_blok(zm); // a($fffe),b(blk_num),b(blk_id) // a(blk_off),a(blk_len) save_dstW( $fffe ); save_dst(byte(blok)); save_dst(memType); if blok=1 then idx:=__rel else begin rel_ofs:=adres-__rel; _odd:=adres; idx:=adres; end; opt:=opt_tmp; end; //BLK E[mpty] a M[ain]|E[xtended] __blkEmp: begin opt_tmp := opt; opt_h_minus; _odd:=integer( ___wartosc_noSPC(zm,zm,i,' ','A') ); // !!! koniecznie znak spacji ' ' !!! // blk empty empend-tdbuf extended v := getMemType(i,zm); blk_empty(_odd, zm); idx:=adres + _odd; opt := opt_tmp; if ds_empty>0 then blad(zm,57); // albo .DS albo BLK EMPTY, nie mozna obu naraz end; // ORG __org: begin if dreloc.sdx then blad(zm,71); if not(NoAllocVar) and not(proc) and (lokal_nr=0) then oddaj_var; NoAllocVar:=false; if zm[i]='[' then begin opt_tmp := opt; opt_h_minus; txt:=ciag_ograniczony(i,zm,true); k:=1; if pass>1 then oblicz_dane(k,txt,zm,1); omin_spacje(i,zm); if zm[i]=',' then begin __inc(i,zm); idx:=integer( ___wartosc_noSPC(zm,zm,i,#0,'A') ); end; opt := opt_tmp; end else idx:=integer( ___wartosc_noSPC(zm,zm,i,',','A') ); org_ofset:=0; omin_spacje(i,zm); if zm[i]=',' then begin __inc(i,zm); {org_ofs:=idx;} hea_ofs.adr := integer( ___wartosc_noSPC(zm,zm,i,#0,'A') ); if hea_ofs.adr<0 then blad(zm,10); hea_ofs.old := idx; { if adres<0 then org_ofset := hea_ofs.adr else } org_ofset := idx - hea_ofs.adr; end; if not(first_org) then // koniecznie IF NOT(FIRST_ORG) inaczej nic nie zapisze if (adres<>idx) and raw.use then begin if raw.old<0 then k:=0 else if hea_ofs.adr>=0 then k:=hea_ofs.adr-raw.old else k:=idx-raw.old; if k<0 then blad(zm,108); if not(hea) then inc(fill,k); // IF NOT(HEA) czeka az zacznie zapisywac cos do pliku adres:=idx; end; end; // RUN,INI __run,__ini: begin if dreloc.sdx then blad(zm,71); // Illegal instruction at RELOC block if opt and 1=0 then blad(zm,111); // Illegal when Atari file headers disabled oddaj_var; idx:=integer( ___wartosc_noSPC(zm,zm,i,#0,'A') ); mne.l:=2; mne.h[0]:=byte(idx); mne.h[1]:=byte(idx shr 8); idx:=$2e0 + r - __run; end; end; if (adres<>idx) or (_odd>=0) then begin save_hea; adres:=idx; if r<>__blkEmp then org:=true; // R = MNE.L end; if (idx>=0) and (idx<=$FFFF) then first_org:=false else blad(zm,0); // !!! koniecznie blad(zm,0) !!! w celu akceptacji // ORG-ów <0 w poczatkowych przebiegach asemblacji if raw.use and (r in [__run, __ini]) then first_org:=true; ety:=''; end; (*----------------------------------------------------------------------------*) (* .PUT [index] = VALUE,... *) (*----------------------------------------------------------------------------*) __put: if ety<>'' then blad(zm,38) else if macro_rept_if_test then begin omin_spacje(i,zm); array_used.max:=0; put_used:=true; blocked := true; get_data_array(i,zm,$FFFF,1); blocked := false; put_used:=false; end; (*----------------------------------------------------------------------------*) (* .SAV [index] ['file',length] | ['file',ofset,length] *) (*----------------------------------------------------------------------------*) __sav: // if ety<>'' then blad(zm,38) else if macro_rept_if_test then begin save_lab(ety,adres,bank,zm); save_lst('a'); idx_get:=0; omin_spacje(i,zm); if zm[i] in ['[','('] then begin txt:=ciag_ograniczony(i,zm,true); k:=1; idx_get:=integer( ___wartosc_noSPC(txt,zm,k,#0,'A') ); end; txt:=get_string(i,zm,zm,false); omin_spacje(i,zm); if txt<>'' then if zm[i]=',' then __inc(i,zm) else blad(zm,23); _doo:=integer( ___wartosc_noSPC(zm,zm,i,',','A') ); omin_spacje(i,zm); if zm[i]=',' then begin __inc(i,zm); inc(idx_get, _doo); _doo:=integer( ___wartosc_noSPC(zm,zm,i,',','A') ); end; _odd:=idx_get+_doo; if _odd>0 then dec(_odd); testRange(zm, _odd, 62); //subrange_bounds(zm,idx_get+_doo,$FFFF); test_eol(i,zm,zm,#0); if txt<>'' then begin txt:=GetFile(txt,zm); if pass=pass_end then begin WriteAccessFile(txt); AssignFile(g, txt); FileMode:=1; Rewrite(g,1); blockwrite(g, t_get[idx_get], _doo); closefile(g); end; end else begin if (pass=pass_end) and (_doo>0) then for idx:=0 to _doo-1 do save_dst(t_get[idx_get+idx]); inc(adres,_doo); end; ety:=''; end; (*----------------------------------------------------------------------------*) (* .PAGES *) (*----------------------------------------------------------------------------*) __pages: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if adres<0 then blad(zm,10) else begin save_lst('a'); war:=1; txt:=get_dat_noSPC(i,zm,' ',#0,zm); if txt<>'' then begin k:=1; war:=___wartosc_noSPC(txt,zm,k,#0,'A'); // dopuszczalny zakres wartosci to .WORD k:=integer(war); testRange(zm, k, 0); end; omin_spacje(i,zm); if not(test_char(i,zm,#0,#0)) then blad(zm,4); t_pag[pag_idx].adr:= integer(adres and $7FFFFF00); t_pag[pag_idx].cnt:= integer(war) shl 8; inc(pag_idx); if pag_idx>High(t_pag) then SetLength(t_pag,pag_idx+1); save_end(__endpg); // ety:=''; end; (*----------------------------------------------------------------------------*) (* .ENDPG *) (*----------------------------------------------------------------------------*) __endpg: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if pag_idx=0 then blad(zm,64) else begin save_lst('a'); dec(pag_idx); _odd := t_pag[pag_idx].adr; _doo := (adres-1) and $7FFFFF00; if pass=pass_end then if (_doo-_odd) >= t_pag[pag_idx].cnt then warning(70); // dec(end_idx); dec_end(zm,__endpg); // ety:=''; end; (*----------------------------------------------------------------------------*) (* .RELOC *) (*----------------------------------------------------------------------------*) __reloc: if ety<>'' then blad(zm,38) else if macro_rept_if_test then if not(hea and not(mne_used)) then blad(zm,83) else begin inc(bank); if bank>=__id_param then blad(zm,45); test_wyjscia(zm,false); save_hea; if dreloc.use then begin rel_idx:=0; ext_idx:=0; extn_idx:=0; skip.idx:=0; pub_idx:=0; smb_idx:=0; sym_idx:=0; ext_used.use:=false; rel_used:=false; blocked:=false; blkupd.adr:=false; blkupd.ext:=false; blkupd.pub:=false; blkupd.sym:=false; blkupd.new:=false; end; save_lst(' '); k:=get_type(i,zm,zm,false); if k=1 then rel_ofs := __rel else rel_ofs := __relASM; dreloc.use:=true; adres:=rel_ofs; first_org:=false; org:=true; save_dstW( __relHea ); // dodatkowy naglowek bloku relokowalnego 'MR' save_dstW( rel_ofs ); // informacja o rodzaju bloku .WORD (bit0) // zapisujemy wartosci etykiet dla stosu programowego indeks:=adr_label(0,false); save_dstW( indeks ); // @stack_pointer indeks:=adr_label(1,false); save_dstW( indeks ); // @stack_address indeks:=adr_label(2,false); save_dstW( indeks ); // @proc_vars_adr end; (*----------------------------------------------------------------------------*) (* .LINK 'filename' *) (* pozwala dolaczyc kod relokowalny tzn. pliki DOS o adresie $0000 *) (*----------------------------------------------------------------------------*) __link: // if ety<>'' then blad(zm,38) else if macro_rept_if_test then if dreloc.use then blad(zm,57) else begin save_lab(ety,adres,bank,zm); // save_lst(zm,'a'); // omin_spacje(i,zm); txt:=get_string(i,zm,zm,true); txt:=GetFile(txt,zm); if not(TestFile(txt)) then blad(txt,18); test_eol(i,zm,zm,#0); AssignFile(g, txt); FileMode:=0; Reset(g,1); // sprawdzamy czy wczytujemy plik DOS'a (pierwsze dwa bajty pliku = __HEA_DOS) t_lnk[0]:=0; t_lnk[1]:=0; blockread(g,t_lnk,2); if (t_lnk[0]+t_lnk[1] shl 8)<>__hea_dos then blad(zm,74); Reset(g,1); blockread(g,t_lnk,sizeof(t_lnk),IDX); // wczytujemy caly plik do T_LNK o dlugosci IDX // w glownej petli uzywamy zmiennych IDX, K, _ODD _odd:=0; dlink.use:=false; dlink.len:=0; dlink.emp:=0; while _odd__relHea then blad(zm,74); (*----------------------------------------------------------------------------*) (* bajt 0 - nieuzywany *) (* bajt 1 - bit 0 kod strony zerowej (0), kod poza strona zerowa (1) *) (* bit 1..7 nieuzywne *) (*----------------------------------------------------------------------------*) fgetB(_odd); // odczytujemy 2 bajty z informacja o pliku .RELOC v:=fgetB(_odd); if (v=0) and (adres>$FF) then blad(zm,76); __link_stack_pointer_old := fgetW(_odd); // @stack_pointer __link_stack_address_old := fgetW(_odd); // @stack_address __link_proc_vars_adr_old := fgetW(_odd); // @proc_vars_adr if pass=0 then begin if dlink.stc then if (__link_stack_pointer_old<>__link_stack_pointer) or (__link_stack_address_old<>__link_stack_address) or (__link_proc_vars_adr_old<>__link_proc_vars_adr) then warning(75); if not(dlink.stc) then begin __link_stack_pointer := __link_stack_pointer_old; __link_stack_address := __link_stack_address_old; __link_proc_vars_adr := __link_proc_vars_adr_old; txt:=mads_stack[0]; save_fake_label(txt,zm,__link_stack_pointer); //@stack_pointer txt:=mads_stack[1]; save_fake_label(txt,zm,__link_stack_address); //@stack_address txt:=mads_stack[2]; save_fake_label(txt,zm,__link_proc_vars_adr); //@proc_vars_adr end; end; move(t_lnk[_odd],t_ins,k); // wczytujemy blok relokowalny do T_INS inc(_odd,k); dlink.len:=k; dlink.use:=true; dlink.stc:=true; end; // BLK UPDATE ADDRESS __hea_address: begin ch := chr( fgetB(_odd) ); j := fgetW(_odd); while j>0 do begin idx_get:=fgetW(_odd); tst:=adres; case ch of 'E': begin // pusty blok rezerwujacy pamiec dlink.emp := idx_get; end; '<','B': begin inc(tst, t_ins[idx_get]); t_ins[idx_get] := byte(tst); end; '>': begin inc(tst, t_ins[idx_get] shl 8); v:=fgetB(_odd); // dodatkowy bajt dla relokacji starszych adresow inc(tst,v); t_ins[idx_get] := byte(tst shr 8); end; 'W': begin inc(tst, t_ins[idx_get]); inc(tst, t_ins[idx_get+1] shl 8); t_ins[idx_get] := byte(tst); t_ins[idx_get+1]:= byte(tst shr 8); end; 'L': begin inc(tst, t_ins[idx_get]); inc(tst, t_ins[idx_get+1] shl 8); inc(tst, t_ins[idx_get+2] shl 16); t_ins[idx_get] := byte(tst); t_ins[idx_get+1]:= byte(tst shr 8); t_ins[idx_get+2]:= byte(tst shr 16); end; 'D': begin inc(tst, t_ins[idx_get]); inc(tst, t_ins[idx_get+1] shl 8); inc(tst, t_ins[idx_get+2] shl 16); inc(tst, t_ins[idx_get+3] shl 24); t_ins[idx_get] := byte(tst); t_ins[idx_get+1]:= byte(tst shr 8); t_ins[idx_get+2]:= byte(tst shr 16); t_ins[idx_get+3]:= byte(tst shr 24); end; end; dec(j); end; end; // BLK UPDATE EXTERNAL __hea_external: begin ch := chr ( fgetB(_odd) ); j := fgetW(_odd); txt:=fgetS(_odd); // label_ext name idx_get:=load_lab(txt,false); if idx_get<0 then begin war:=0; if pass=pass_end then blad_und(zm,txt,73); end else war:=oblicz_wartosc(txt,zm); v:=ord(value_code(war,zm,true)); // sprawdzamy czy zgadza sie typ etykiety if pass=pass_end then case ch of 'B': if chr(v)<>'Z' then blad_und(zm,txt,41); 'W': if not(chr(v) in ['Z','Q']) then blad_und(zm,txt,41); 'L': if not(chr(v) in ['Z','Q','T']) then blad_und(zm,txt,41); end; while j>0 do begin idx_get:=fgetW(_odd); tst:=word(war); case ch of 'B','<': begin inc(tst, t_ins[idx_get]); t_ins[idx_get] := byte(tst); end; '>': begin inc(tst, t_ins[idx_get] shl 8); v:=fgetB(_odd); // dodatkowy bajt dla relokacji starszych adresow inc(tst,v); t_ins[idx_get] := byte(tst shr 8); end; 'W': begin inc(tst, t_ins[idx_get]); inc(tst, t_ins[idx_get+1] shl 8); t_ins[idx_get] := byte(tst); t_ins[idx_get+1]:= byte(tst shr 8); end; 'L': begin inc(tst, t_ins[idx_get]); inc(tst, t_ins[idx_get+1] shl 8); inc(tst, t_ins[idx_get+2] shl 16); t_ins[idx_get] := byte(tst); t_ins[idx_get+1]:= byte(tst shr 8); t_ins[idx_get+2]:= byte(tst shr 16); end; 'D': begin inc(tst, t_ins[idx_get]); inc(tst, t_ins[idx_get+1] shl 8); inc(tst, t_ins[idx_get+2] shl 16); inc(tst, t_ins[idx_get+3] shl 24); t_ins[idx_get] := byte(tst); t_ins[idx_get+1]:= byte(tst shr 8); t_ins[idx_get+2]:= byte(tst shr 16); t_ins[idx_get+3]:= byte(tst shr 24); end; end; dec(j); end; end; // BLK UPDATE PUBLIC __hea_public: begin j:=fgetW(_odd); while j>0 do begin typ:= chr ( fgetB(_odd) ); // TYPE B-YTE, W-ORD, L-ONG, D-WORD ch := chr ( fgetB(_odd) ); // LABEL_TYPE V-ARIABLE, P-ROCEDURE, C-ONSTANT if dlink.use then tst:=adres else tst:=0; case ch of 'P': begin str:=fgetS(_odd); // label_pub name inc(tst, fgetW(_odd)); // adres procedury r:=fgetB(_odd); // kolejnosc rejestrow CPU rodzaj:=chr(fgetB(_odd)); // typ procedury if not(rodzaj in [__pDef, __pReg, __pVar]) then blad_und(zm,str,41); idx_get:=fgetW(_odd); // liczba danych na temat parametrow proc_nr:=proc_idx; // koniecznie przez ADD_PROC_NR if pass=0 then begin _doo:=_odd+idx_get; txt:='('; while _odd<_doo do begin v:=TypeToByte( chr( fgetB(_odd) ) ); // liczba bajtow przypadajaca na parametr txt:=txt+mads_param[v]; case rodzaj of // parametr jesli trzeba __pDef: tmp:='par'+IntToStr(_odd); __pReg: begin tmp:=''; while v<>0 do begin tmp:=tmp+ByteToReg(r); dec(v) end; end; __pVar: tmp:=fgetS(_odd); end; txt:=txt+tmp+' '; end; txt:=txt+')'; case rodzaj of __pReg: txt:=txt+' .REG'; __pVar: txt:=txt+' .VAR'; end; i:=1; get_procedure(str,str,txt,i); // odczytujemy parametry proc:=false; // koniecznie wylaczamy PROC proc_name:=''; // i koniecznie PROC_NAME := '' end else inc(_odd,idx_get); // koniecznie zwiekszamy _ODD gdy PASS<>0 upd_procedure(str,zm,tst); proc:=false; // koniecznie wylaczamy PROC proc_name:=''; // i koniecznie PROC_NAME = '' add_proc_nr; // zwiekszamy koniecznie numer procedury end; 'A': begin // upubliczniamy .ARRAY str:=fgetS(_odd); _doo:= fgetW(_odd); inc(tst, _doo); // nowy adres etykiety save_lab(str, array_idx, __id_array, zm); save_arr(tst, bank); // tutaj ARRAY_IDX zostaje zwiekszone o 1 _doo:= fgetW(_odd); v:=TypeToByte( chr( fgetB(_odd) ) ); t_arr[array_idx-1].idx:=_doo; // dlatego teraz ARRAY_IDX-1 t_arr[array_idx-1].siz := v; t_arr[array_idx-1].len := (_doo+1)*v; end; 'S': begin // upubliczniamy .STRUCT str:=fgetS(_odd); _doo:= fgetW(_odd); upd_structure(str, zm); // UPD_STRUCTURE ustawi wartosc STRUCT.IDX zapisz_lokal; lokal_name:=lokal_name+str+'.'; struct.adres:=0; while _doo>0 do begin v:=TypeToByte( chr( fgetB(_odd) ) ); str:=fgetS(_odd); j:=fgetW(_odd); save_str(str,struct.adres,v,j,adres,bank); save_lab(str,struct.adres,bank,zm); inc(struct.adres, v*j); inc(struct.cnt); dec(_doo); end; t_str[struct.idx].siz := struct.adres; // zapisujemy dlugosc struktury t_str[struct.idx].ofs := struct.cnt; // i liczbe pol struktury inc(struct.id); // zwiekszamy identyfikator struktury (liczba struktur) struct.cnt := -1; oddaj_lokal(zm); end; 'V': begin str:=fgetS(_odd); _doo:= fgetW(_odd); inc(tst, _doo); // nowy adres etykiety save_lab(str,tst,bank,zm); // variable end; 'C': begin str:=fgetS(_odd); case typ of 'B': vtmp:=fgetB(_odd); 'W': vtmp:=fgetW(_odd); 'L': vtmp:=fgetL(_odd); 'D': vtmp:=fgetD(_odd); end; save_lab(str,vtmp,bank,zm); // constant end; end; dec(j); end; end; else begin flush_link; k:=fgetW(_odd); // odczytujemy dlugosc pliku relokowalnego inc(k); // zwiekszamy o 1 testRange(zm,k, 62); // maksymalna dlugosc pliku $FFFF save_hea; adres:=j; org:=true; dlink.len:=k-j; move(t_lnk[_odd],t_ins,dlink.len); // wczytujemy blok relokowalny do T_INS inc(_odd,dlink.len); end; end; end; flush_link; closefile(g); ety:=''; end; (*----------------------------------------------------------------------------*) (* .PUBLIC label [,label2,label3...] *) (*----------------------------------------------------------------------------*) __public: if ety<>'' then blad(zm,38) else if macro_rept_if_test then begin save_lst(' '); omin_spacje(i,zm); while not(test_char(i,zm,#0,#0)) do begin txt:=get_lab(i,zm, true); save_pub(txt,zm); _odd:=load_lab(txt,false); if _odd>=0 then t_lab[_odd].use:=true; //etykieta domyslnie w uzyciu __next(i,zm); end; end; (*----------------------------------------------------------------------------*) (* .SYMBOL label *) (*----------------------------------------------------------------------------*) __symbol: if macro_rept_if_test then if not(dreloc.sdx) then blad(zm,53) else begin // tylko gdy blok relokowalny SDX if ety='' then ety:=get_lab(i,zm, true); if not(test_char(i,zm,#0,#0)) then blad(zm,4); save_lst(' '); // zapisujemy symbol .SYMBOL w T_SYM t_sym[sym_idx] := ety; // SAVE_SYM inc(sym_idx); // if sym_idx>High(t_sym) then SetLength(t_sym,sym_idx+1); // end; (*----------------------------------------------------------------------------*) (* INS 'filename' [+-expression] [,length[,offset]] *) (* .GET [index] 'filename' [+-expression] [,length[,offset]] *) (*----------------------------------------------------------------------------*) __ins,__get: if macro_rept_if_test then // if loop_used then blad(zm,36) else if first_org and (opt and 1>0) and (mne.l=__ins) then blad(zm,10) else begin data_out:=true; idx_get:=0; omin_spacje(i,zm); if mne.l=__get then if zm[i] in ['[','('] then begin txt:=ciag_ograniczony(i,zm,true); k:=1; idx_get:=integer( ___wartosc_noSPC(txt,zm,k,#0,'A') ); end; // omin_spacje(i,zm); txt:=get_string(i,zm,zm,true); txt:=GetFile(txt,zm); if not(TestFile(txt)) then blad(txt,18); if (GetFileName(txt)=GetFileName(a)) or (GetFileName(txt)=GetFileName(plik_asm)) then blad(txt,18); AssignFile(g, txt); FileMode:=0; Reset(g,1); k:=integer(FileSize(g)); _odd:=0; _doo:=k; v:=byte( test_string(i,zm,'B') ); if zm[i]=',' then begin __inc(i,zm); _odd:=integer( ___wartosc_noSPC(zm,zm,i,',','F') ); if _odd<0 then begin _doo:=abs(_odd); _odd:=k+_odd; end else _doo:=k-abs(_odd); if zm[i]=',' then begin __inc(i,zm); _doo:=integer( ___wartosc_noSPC(zm,zm,i,',','F') ); // - testRange(zm, _doo, 13); if _doo<0 then begin blad(zm,13); _doo:=0; end; test_eol(i,zm,zm,#0); end; end else test_eol(i,zm,zm,#0); // sprawdz czy nie zostala przekroczona dlugosc pliku if (abs(_odd)>k) or (abs(_odd)+abs(_doo)>k) then blad(zm,24); k:=_doo; // dlugosc pliku nie moze byc mniejsza od 0 // - testRange(zm, k, 25); //if k>$FFFF then blad(zm,25); if k<0 then begin blad(zm,25); k:=0; end; save_lst('a'); if mne.l=__get then begin // .GET j:=idx_get+_doo; testRange(zm, j, 62); // subrange_bounds(zm,idx_get+_doo,$FFFF+1); if _odd>0 then seek(g,_odd); // omin _ODD bajtow w pliku blockread(g,t_get[idx_get],_doo); // odczytaj _DOO bajtow od indeksu [IDX_GET] end else // INS if (pass=pass_end) and (_doo>0) then begin // if opt and 1=0 then first_org := true; if _odd>0 then seek(g,_odd); // omin _ODD bajtow w pliku for j:=0 to (_doo div $10000)-1 do begin blockread(g, t_ins, $10000); // odczytaj 64KB bajtow for idx:=0 to $FFFF do save_dst( byte( t_ins[idx]+v ) ); end; j:=_doo mod $10000; // odczytaj pozostale bajty blockread(g, t_ins, j); for idx:=0 to j-1 do save_dst( byte( t_ins[idx]+v ) ); end; closefile(g); save_lab(ety,adres,bank,zm); if mne.l<>__get then inc(adres, k); ety:=''; end; (*----------------------------------------------------------------------------*) (* END *) (*----------------------------------------------------------------------------*) __end, __en: if loop_used then blad(zm,36) else begin end_file:=true; save_lab(ety,adres,bank,zm); save_lst('a'); mne.l:=0; ety:=''; end; (*----------------------------------------------------------------------------*) (* DTA [abefgtcd] 'string',expression... *) (* lub dodajemy nowe pola do struktury .STRUCT *) (*----------------------------------------------------------------------------*) __dta,__byte..__dword: if macro_rept_if_test then if first_org and (opt and 1>0) and not(struct.use) then blad(zm,10) else begin if struct.use then begin // zapisujemy pola struktury if ety='' then blad(zm,15); // pola struktury musza posiadac etykiety if mne.l=__dta then blad(zm,58); // przyjmujemy tylko nazwy typow j:=mne.l-__byteValue; // J = <1..4> k:=adres-struct.adres; if ety+'.'=lokal_name then blad(zm,57); // nazwa pola musi byc <> od nazwy struktury save_str(ety,k,j,rpt,adres,bank); save_lab(ety,k,bank,zm); nul.i:=k; save_lst('l'); if loop_used then begin loop_used:=false; j := j*rpt; end; inc(adres, j); inc(struct.cnt); // zwiekszamy licznik pol struktury // ety:=''; end else create_struct_data(i,zm,ety, mne.l); ety:=''; end; (*----------------------------------------------------------------------------*) (* ICL 'filename' *) (*----------------------------------------------------------------------------*) __icl: if macro_rept_if_test then if loop_used then blad(zm,36) else begin save_lab(ety,adres,bank,zm); save_lst('a'); txt:=get_string(i,zm,zm,true); txt:=GetFile(txt,zm); if not(TestFile(txt)) then begin tmp:=GetFile(txt+'.asm', zm); if not(TestFile(tmp)) then blad(txt,18) else txt:=tmp; end; test_eol(i,zm,zm,#0); // if (GetFileName(txt)=GetFileName(a)) or (GetFileName(txt)=GetFileName(plik_asm)) then blad(txt,18); if (txt=a) or (txt=plik_asm) then blad(txt,18); // sprawdzamy czy jest to plik tekstowy w pierwszych dwóch przebiegach asemblacji if pass<2 then begin assignfile(f, txt); FileMode:=0; Reset(f); readln(f, tmp); CloseFile(f); if pos(#0,tmp)>0 then blad(zm,74); end; str:=zm; zapisz_lst(str); old_icl_used := icl_used; icl_used:=true; analizuj_plik__(txt,zm); bez_lst:=true; // put_lst(show_full_name(a,full_name,true),''); global_name:=a; line:=nr; icl_used := old_icl_used; ety:=''; mne.l:=0; end; end; // zapamietanie etykiety jesli wystapila // i zapisanie zdekodowanych rozkazow if if_test then begin omin_spacje(i,zm); txt:=''; ___search_comment_block(i,zm,txt); if ety<>'' then begin // if mne_used then label_type:='V'; // !!! koniecznie label_type = V-ariable // else // label_type:='C'; if pass=pass_end then if adres<0 then warning(10); save_lab(ety,adres,bank,zm); // pozostale etykiety bez zmian save_lst('a'); end; // writeln(zm,' | ',if_test); if mne.l<__equ then begin nul:=mne; if (mne.l=0) and (ety='') then save_lst(' ') else save_lst('a'); nul.l:=0; end; end; // zapisz wynik asemblacji do pliku LST if not(loop_used) and not(FOX_ripit) then begin if not(bez_lst) then zapisz_lst(zm); bez_lst:=false; end; end; procedure get_line(var zm:string; var end_file,ok:Boolean; var _odd,_doo:integer; var app: Boolean; var appLine: string); (*----------------------------------------------------------------------------*) (* pobieramy linie i sprawdzamy czy linia nie jest komentarzem *) (*----------------------------------------------------------------------------*) var i, j: integer; str: string; begin if end_file then exit; noWarning:=false; if not(macro) and not(rept) then if komentarz then begin i:=1; str:=''; search_comment_block(i,zm,str); if str<>'' then begin save_lst(' '); justuj; put_lst(t+zm); zm:=copy(zm,i,length(zm)); end; end; if not(komentarz) then if not(macro) and not(rept) and (pos('\',zm)>0) then begin // pobieżny test na obecnosc znaku '\' i:=1; str:=get_dat(i,zm,'\',false); // tutaj sprawdzamy dokladniej SetLength(t_lin, 1); if zm[i]='\' then begin save_lst(' '); justuj; put_lst(t+zm); _odd:=High(t_lin); i:=1; while true do begin str:=get_dat(i,zm,'\',false); j:=1; omin_spacje(j, str); if j>length(str) then str:=''; j:=High(t_lin); // SAVE_LIN t_lin[j]:=str; // SetLength(t_lin,j+2); // if zm[i]='\' then inc(i) else Break; end; _doo:=High(t_lin); if str='' then begin app:=true; appLine:=appLine+t_lin[_doo-2]; dec(_doo,2); end; lst_off:=true; ok:=false; exit; end; end; app:=false; i:=1; if zm<>'' then begin omin_spacje(i,zm); if not((zm[i] in [';','*']) or ((zm[i]='|') and (zm[i+1]<>'|')) or komentarz) then ok:=true; str:=''; ___search_comment_block(i,zm, str); end; // !!! linie z komentarzem /* */ byly traktowane jako puste linie !!! { omin_spacje(i,zm); // sprawdzamy czy wiersz nie zawiera samych "bialych znakow" if not(macro) and not(rept) then if (i>length(zm)) then begin ok:=false; if not(komentarz) then zm:=''; // jesli nie jest to komentarz to zapiszemy tylko pusty wiersz end; } if not(macro) and not(rept) and not(run_macro) and not(rept_run) then if (zm='') or not(ok) then begin save_lst(' '); if zm<>'' then justuj else SetLength(t,6); put_lst(t+zm); ok:=false; end; end; procedure analizuj_plik(var a:string; var old_str: string); (*----------------------------------------------------------------------------*) (* odczyt pliku ASM wiersz po wierszu *) (*----------------------------------------------------------------------------*) var f: textfile; rept_nr, rept_ile, nr, _odd, _doo: integer; end_file, ok, wyjscie, app, _app: Boolean; zm, appLine, _appLine: string; v: byte; begin if not(TestFile(a)) then blad(a,18); AssignFile(f,a); FileMode:=0; Reset(f); _odd:=0; _doo:=0; rept_ile:=0; rept_nr:=0; nr:=0; // nr linii w asemblowanym pliku global_name:=a; // nazwa pliku dla funkcji 'BLAD' end_file:=false; // czy napotkal rozkaz 'END' wyjscie:=false; // czy wystapilo EXIT w makrze app:=false; appLine:=''; _app:=false; _appLine:=''; // nazwe pierwszego pliku zawsze zapisze do LST // pod warunkiem ze (opt and 4>0) czyli wystapilo OPT L+ if (opt and 4>0) then if (pass=pass_end) and (a[2]=':') then writeln(lst,show_full_name(global_name,true,true)) else put_lst(show_full_name(global_name,full_name,true)); while (not eof(f)) or (_doo>0) do begin ok:=false; if _doo>0 then begin zm:=t_lin[_odd]; inc(_odd); if _odd>=_doo then begin _doo:=0; lst_off:=false; end; get_line(zm,end_file,ok,_odd,_doo, _app,_appLine); end else begin readln(f,zm); if length(zm)>$FFFF then begin // maksymalna dlugosc wiersza 65535 znakow blad(zm,101); koniec(2) end; inc(nr); line:=nr; inc(line_all); get_line(zm,end_file,ok,_odd,_doo, app,appLine); if ok and not(app) and (appLine<>'') then begin save_lst(' '); justuj; put_lst(t+zm); zm:=appLine+zm; appLine:=''; end; end; if macro then begin v:=dirMACRO(zm); if v in [{__end+1,} __en] then end_file:=true; // !!! dla __end+1 zatrzyma sie gdy 'lda end' end else if rept then begin v:=dirREPT(zm); if v=__endr then dirENDR(zm,a,old_str,rept_nr,rept_ile) else if v in [__end+1, __en] then end_file:=true; end else if ok and not(komentarz) then analizuj_linie(zm,a,old_str, rept_nr,rept_ile, nr, end_file,wyjscie); if end_file then Break; end; if appLine<>'' then analizuj_linie(appLine,a,old_str, rept_nr,rept_ile, nr, end_file,wyjscie); test_skipa; if skip.use then blad(zm,84); // Can't skip over this oddaj_var; if a=plik_asm then oddaj_ds; // !!! koniecznie tutaj, inaczej po ICL z .DS bedzie generowal nowy blok EMPTY if pass=pass_end then if (a=plik_asm) {and not(first_org)} then begin // wymuszamy BLK UPDATE na koncu glownego pliku if dreloc.use or dreloc.sdx then begin save_lst('a'); if not(blkupd.adr) then begin zm:=load_mes(91)+load_mes(92); blk_update_address(zm) end; save_lst('a'); if not(blkupd.ext) then begin zm:=load_mes(91)+load_mes(93); blk_update_external(zm) end; save_lst('a'); if not(blkupd.pub) then begin zm:=load_mes(91)+load_mes(94); blk_update_public(zm) end; save_lst('a'); if not(blkupd.sym) then begin zm:=load_mes(91)+load_mes(95); blk_update_symbol(zm) end; save_lst('a'); oddaj_sym; end; end; test_wyjscia(zm,wyjscie); closefile(f); end; procedure analizuj_mem(const start,koniec:integer; var old,a,old_str:string; licz:integer; const p_max:integer; const rp:Boolean); (*----------------------------------------------------------------------------*) (* odczyt i analiza wierszy zapisanych w tablicy dynamicznej T_MAC *) (* P_MAX okresla liczbe powtorzen *) (*----------------------------------------------------------------------------*) var rept_ile, rept_nr, licznik, nr, _odd, _doo, old_line_add: integer; end_file, ok, wyjscie, old_icl_used, app, _app: Boolean; zm, appLine, _appLine: string; v: byte; begin old_icl_used := icl_used; icl_used := true; old_line_add := line_add; // !!! koniecznie zapamietac LINE_ADD !!! line_add := 0; // inaczej numer linii z bledem dla np. "lda:cmp:rq" bedzie zly _odd:=0; _doo:=0; rept_ile:=0; rept_nr:=0; while licz < p_max do begin if rp or FOX_ripit then ___rept_ile := licz; licznik:=start; nr:=old_line_add; // nr linii w asemblowanym pliku end_file:=false; // czy napotkal rozkaz 'END' wyjscie:=false; // czy wystapilo EXIT w makrze app:=false; appLine:=''; _app:=false; _appLine:=''; while (licznik0) do begin ok:=false; if _doo>0 then begin zm:=t_lin[_odd]; inc(_odd); if _odd>=_doo then begin _doo:=0; lst_off:=false end; get_line(zm,end_file,ok, _odd,_doo, _app,_appLine); end else begin zm:=t_mac[licznik]; reptLine(zm); // podstawiamy parametry w bloku .REPT inc(licznik); inc(nr); line:=nr; inc(line_all); get_line(zm,end_file,ok, _odd,_doo, app,appLine); if ok and not(app) and (appLine<>'') then begin save_lst(' '); justuj; put_lst(t+zm); zm:=appLine+zm; appLine:=''; end; end; if rept then begin v:=dirREPT(zm); if v=__endr then dirENDR(zm,a,old_str,rept_nr,rept_ile) else if v in [__end+1, __en] then end_file:=true; end else if ok and not(end_file) and not(komentarz) then analizuj_linie(zm,a,old_str, rept_nr,rept_ile, nr, end_file,wyjscie); if wyjscie then Break; // zakonczenie przetwarzania makra przez dyrektywe .EXIT end; if appLine<>'' then analizuj_linie(appLine,a,old_str, rept_nr,rept_ile, nr, end_file,wyjscie); test_wyjscia(old,wyjscie); inc(licz); end; icl_used := old_icl_used; line_add := old_line_add; end; procedure asem(var a:string); (*----------------------------------------------------------------------------*) (* asemblacja glownego pliku *.ASM *) (*----------------------------------------------------------------------------*) var i: integer; s: string; begin while (pass<=pass_end) and (pass=pass_end) or (pass<1) then if next_pass then inc(pass_end); // !!! zerowanie numeru wywolania makra !!! for i:=High(t_lab)-1 downto 0 do if t_lab[i].bnk=__id_macro then t_mac[ t_lab[i].adr + 3 ] := '0'; label_type:='V'; zpvar:=$80; adres:=-$FFFF; raw.old:=-$FFFF; hea_ofs.adr:=-1; struct.cnt:=-1; ___rept_ile:=-1; regOpty.reg[0]:=-1; regOpty.reg[1]:=-1; regOpty.reg[2]:=-1; array_used.max:=0; fillchar(t_zpv, sizeof(t_zpv), false); hea_i:=0; bank:=0; ifelse:=0; blok:=0; rel_ofs:=0; org_ofset:=0; proc_idx:=0; proc_nr:=0; lokal_nr:=0; lc_nr:=0; fill:=0; line_add:=0; struct.id:=0; wyw_idx:=0; rel_idx:=0; array_idx:=0; ext_idx:=0; extn_idx:=0; skip.idx:=0; smb_idx:=0; sym_idx:=0; pag_idx:=0; end_idx:=0; var_idx:=0; pub_idx:=0; usi_idx:=0; whi_idx:=0; while_nr:=0; ora_nr:=0; test_nr:=0; test_idx:=0; var_id:=0; proc_lokal:=0; __link_stack_pointer := adr_label(0,false); // @STACK_POINTER __link_stack_address := adr_label(1,false); // @STACK_ADDRESS __link_proc_vars_adr := adr_label(2,false); // @PROC_VARS_ADR siz_idx:=1; opt := optDefault; hea:=true; first_org:=true; if_test:=true; TestWhileOpt:=true; exProcTest:=true; regOpty.use:=false; regOpty.blk:=false; mae_labels:=false; loop_used:=false; macro:=false; proc:=false; regAXY_opty:=false; undeclared:=false; new_local:=false; icl_used:=false; bez_lst:=false; empty:=false; enum.use:=false; reloc:=false; branch:=false; vector:=false; rept:=false; rept_run:=false; struct.use:=false; dta_used:=false; code6502:=false; struct_used.use:=false; aray:=false; next_pass:=false; mne_used:=false; skip.use:=false; skip.xsm:=false; FOX_ripit:=false; put_used:=false; ext_used.use:=false; dreloc.use:=false; dreloc.sdx:=false; rel_used:=false; blocked:=false; dlink.stc:=false; blokuj_zapis:=false; overflow:=false; test_symbols:=false; lst_off:=false; noWarning:=false; raw.use:=false; variable:=false; komentarz:=false; org:=false; lokal_name:=''; macro_nr:=''; str_blad:=''; while_name:=''; test_name:=''; warning_old:=''; // SetLength(t_lin, 1); // T_LIN mozemy zapisywac od nowa if binary_file.use then begin adres := binary_file.adr; org := true; first_org := false; end; end; // jesli nie wystapil zaden blad i mamy 16 przebiegow to na pewno nastapila petla bez konca if (status=0) and (pass=pass_max) then begin writeln(#13#10'Infinite loop !!!'); koniec(2); end; end; procedure Syntax; (*----------------------------------------------------------------------------*) (* wyswietlamy informacje na temat przelacznikow, konfiguracji MADS'a *) (*----------------------------------------------------------------------------*) begin Writeln(load_mes(119+1)); Writeln(load_mes(117+1)); halt(3); end; function NewFileExt(nam: string; const ext: string): string; begin if pos('.',nam)>0 then begin obetnij_kropke(nam); Result:=nam+ext; end else Result:=nam+'.'+ext; end; function nowy_plik(var a: string; var i:integer): string; var name, path: string; begin path:=''; Result:=a; inc(i,2); // omijamy znak przelacznika i znak ':' name:=copy(t,i,length(t)); if GetFilePath(name)<>'' then path:=GetFilePath(name); if name<>'' then Result:=path+GetFileName(name); inc(i,length(name)); end; procedure INITIALIZE; (*----------------------------------------------------------------------------*) (* procedura obliczajaca tablice CRC16, CRC32, mniej miejsca zajmuje anizeli *) (* gotowa predefiniowana tablica *) (*----------------------------------------------------------------------------*) var IORes, _i, x, y: integer; crc: cardinal; crc_: Int64; tmp: string; const // HASH_VAL i HASH_OFS wylicza osobny program // nie trzeba przechowywac w pamieci stringow z nazwami hash_val: array [0..282] of byte=( $56,$01,$58,$42,$1E,$1F,$E0,$59,$F0,$3E,$0E,$86, $A0,$04,$9E,$9E,$29,$2A,$98,$98,$43,$48,$8D,$89, $8C,$93,$97,$3C,$CA,$3D,$D3,$9D,$0A,$33,$9F,$9B, $9B,$07,$50,$12,$22,$18,$13,$51,$36,$9F,$9B,$9B, $E2,$4E,$9D,$9C,$24,$44,$1B,$49,$08,$85,$9C,$97, $BC,$57,$63,$32,$9F,$9B,$9B,$A2,$63,$A2,$65,$83, $B9,$B6,$F0,$68,$CD,$54,$23,$19,$AA,$31,$9F,$9B, $9B,$8A,$67,$20,$AC,$6B,$45,$94,$17,$A6,$A2,$87, $9C,$5B,$9C,$15,$30,$97,$9F,$9B,$9B,$5C,$09,$5A, $4C,$55,$D6,$BF,$C6,$61,$C2,$88,$40,$C3,$70,$3B, $3A,$1C,$1D,$0F,$0C,$3F,$BE,$2F,$4D,$41,$35,$9F, $9B,$9B,$A5,$99,$99,$14,$16,$AC,$0B,$0D,$34,$9F, $9B,$9B,$4F,$A6,$84,$21,$37,$9F,$9B,$9B,$2B,$AF, $A1,$D4,$38,$A3,$8B,$82,$F0,$8E,$69,$95,$81,$B2, $1A,$A3,$9A,$9A,$9C,$B8,$9C,$97,$A4,$62,$2D,$02, $28,$46,$4A,$BA,$68,$26,$11,$CB,$2E,$05,$9E,$9E, $53,$2C,$03,$27,$47,$4B,$25,$10,$06,$9E,$9E,$52, $AB,$D7,$39,$E1,$6F,$A9,$67,$6D,$6A,$A7,$69,$C9, $B7,$A7,$D1,$77,$62,$F0,$CE,$71,$74,$76,$F0,$AA, $A9,$B9,$AE,$D5,$61,$A4,$B0,$C1,$BB,$65,$B4,$66, $AD,$64,$BE,$BD,$CF,$AE,$C5,$B0,$CC,$C0,$73,$75, $6E,$C8,$66,$A1,$C3,$6C,$B1,$6B,$D8,$6C,$CF,$D8, $CE,$B3,$6A,$D0,$B4,$CD,$C4,$C3,$C7,$72,$CC,$AA, $64,$A8,$D0,$C0,$AF,$B5,$D2); hash_ofs: array [0..282] of word=( $0458,$048C,$04A4,$04B0,$0510,$0590,$059E,$05C9,$060E,$0642,$064F,$0684, $068A,$0693,$06CD,$06ED,$0714,$0734,$0853,$0881,$0910,$0990,$09AC,$09AE, $09B2,$09B3,$0A03,$0A54,$0A68,$0A74,$0A82,$0AB3,$0C53,$0C62,$0C6A,$0C72, $0C73,$0C81,$0C94,$0CA4,$0CB3,$0D83,$0DC9,$0E74,$0EC2,$0ECA,$0ED2,$0ED3, $0EF2,$1074,$1081,$10A4,$10B3,$1110,$1183,$1190,$11C1,$11C5,$11C9,$1203, $1284,$1478,$155E,$15C2,$15CA,$15D2,$15D3,$1925,$1A4F,$1B79,$1C4B,$1E4F, $1EE6,$1EE7,$20ED,$2258,$22D8,$2437,$24B3,$2583,$2585,$25A2,$25AA,$25B2, $25B3,$25C9,$266F,$2692,$2760,$2C28,$2D10,$2D82,$2E42,$2F88,$2FDC,$3069, $30A4,$31AA,$31C9,$31F2,$3202,$3203,$320A,$3212,$3213,$3242,$3261,$326A, $3292,$3497,$3538,$354A,$361E,$3721,$3AA5,$3AB2,$3ACD,$3FD3,$400D,$40B2, $40B3,$4110,$4190,$41A3,$41AA,$41E3,$41E6,$41EE,$4293,$42CD,$44A2,$44AA, $44B2,$44B3,$463C,$4910,$4990,$49E5,$49F2,$4A25,$4A6A,$4A6C,$4C62,$4C6A, $4C72,$4C73,$4C74,$4D85,$4DC9,$4E92,$4EC2,$4ECA,$4ED2,$4ED3,$4F14,$4FA1, $50C9,$50FC,$5122,$51D4,$51E2,$520F,$521A,$5245,$5297,$5305,$5625,$56C2, $5983,$5A04,$5C53,$5C81,$5CA4,$5D5E,$5DC9,$5E03,$5E83,$5EDF,$6034,$608C, $60A4,$6110,$6190,$61A1,$61A6,$61C9,$6203,$6231,$6274,$6293,$62CD,$62ED, $6334,$6434,$648C,$64A4,$6510,$6590,$65C9,$6603,$6693,$66CD,$66ED,$6714, $68C2,$6A46,$6A93,$6B3A,$733C,$73F5,$7833,$7B65,$7C8D,$7D7A,$7E9D,$7F58, $7F79,$8154,$843F,$864A,$8976,$8A4B,$8C5C,$8D4A,$92F2,$9704,$987A,$990E, $9998,$9B88,$9E9D,$9F41,$9F52,$A152,$A307,$A3EE,$A421,$A934,$A9FB,$AB24, $ACD0,$AFC6,$B2B3,$B633,$B904,$B9DA,$B9F0,$BA41,$BFBD,$C10A,$C257,$CA0E, $CA5A,$CD5F,$CDE6,$CE0D,$CF8A,$D040,$D0C2,$D0CD,$D417,$D894,$D91C,$DB0C, $DE1A,$E073,$E3FC,$E767,$E829,$E97F,$EB60,$EBA8,$F129,$F166,$F1FE,$F353, $F5F1,$F6D0,$F6E5,$F88C,$F8D5,$FAC5,$FCCE); begin // szukanie indeksow dla MES y:=0; for x:=0 to sizeof(mes)-1 do if ord(mes[x])>$7f then begin dec(mes[x],$80); imes[y]:=x; inc(y); end; for x:=0 to 255 do begin crc:=x shl 8; crc_:=crc; for y:=1 to 8 do begin crc := crc shl 1; crc_ := crc_ shr 1; if (crc and $00010000) > 0 then crc := crc xor $1021; if (crc_ and $80) > 0 then crc_ := crc_ xor $edb8832000; end; tcrc16[x] := integer(crc); tcrc32[x] := cardinal(crc_ shr 8); end; for IORes:=sizeof(hash_val)-1 downto 0 do hash[hash_ofs[IORes]] := hash_val[IORes]; (*----------------------------------------------------------------------------*) (* przetwarzanie parametrow, inicjalizacja zmiennych *) (*----------------------------------------------------------------------------*) plik_asm:=''; if ParamCount<1 then Syntax; // odczyt parametrow for IORes:=1 to ParamCount do begin t:=ParamStr(IORes); if t<>'' then // if not(t[1] in ['/','-']) then begin if not(t[1]='-') then begin // w celu kompatybilnosci z Linuxami, Mac OS X if plik_asm<>'' then Syntax else plik_asm:=t end else begin _i:=2; while _i<=length(t) do begin case UpCase(t[_i]) of 'C': case_used := true; 'F': labFirstCol := true; 'P': full_name := true; 'S': silent := true; 'X': exclude_proc := true; 'U': unused_label := true; 'V': if UpCase(t[_i+1])='U' then begin inc(_i,2); VerifyProc := true end; 'B': if t[_i+1]<>':' then Syntax else begin inc(_i,2); tmp:=get_dat(_i,t,' ',true); binary_file.adr := integer( oblicz_wartosc(tmp, t) ); binary_file.use := true; end; 'D': if t[_i+1]<>':' then Syntax else begin inc(_i,2); def_label:=get_lab(_i,t, true); if t[_i]<>'=' then nul.i:=1 else begin inc(_i); nul.i:=integer( get_expres(_i,t,t, false) ); end; s_lab(def_label,nul.i,bank,t,def_label[1]); end; 'H': begin inc(_i); case UpCase(t[_i]) of 'C': begin list_hhh:=true; if t[_i+1]=':' then plik_h:=nowy_plik(plik_h, _i); end; 'M': begin list_mmm:=true; if t[_i+1]=':' then plik_hm:=nowy_plik(plik_hm, _i); end; else Syntax end; end; 'I': if t[_i+1]<>':' then Syntax else begin name:=nowy_plik(name, _i); if name='' then Syntax else begin t_pth[High(t_pth)]:=name; SetLength(t_pth, High(t_pth)+2); end; end; 'L': begin opt:=opt or 4; if t[_i+1]=':' then plik_lst:=nowy_plik(plik_lst, _i); end; 'M': if t[_i+1]<>':' then Syntax else begin list_mac:=true; plik_mac:=nowy_plik(plik_mac, _i); end; 'O': if t[_i+1]<>':' then Syntax else plik_obj:=nowy_plik(plik_obj, _i); 'T': begin list_lab:=true; if t[_i+1]=':' then plik_lab:=nowy_plik(plik_lab, _i); end; else Syntax; end; inc(_i); end; end; end; if (plik_asm='') or (GetFileName(plik_asm)='') then Syntax; path:=GetFilePath(plik_asm); if path='' then begin GetDir(0,path); path:=path+PathDelim end; name:=GetFileName(plik_asm); global_name:=name; // sprawdzamy obecnosc pliku ASM plik_asm:=path+name; if not(TestFile(plik_asm)) then plik_asm := path + NewFileExt(name,'asm'); if plik_lst = '' then plik_lst := path + NewFileExt(name,'lst'); if plik_obj = '' then plik_obj := path + NewFileExt(name,'obx'); if plik_lab = '' then plik_lab := path + NewFileExt(name,'lab'); if plik_mac = '' then plik_mac := path + NewFileExt(name,'mac'); if plik_h = '' then plik_h := path + NewFileExt(name,'h'); if plik_hm = '' then plik_hm := path + NewFileExt(name,'hea'); t:=load_mes(119+1); // if not(silent) then new_message(t); if list_lab then begin WriteAccessFile(plik_lab); AssignFile(lab,plik_lab); FileMode:=1; Rewrite(lab); writeln(lab,t); writeln(lab,load_mes(54+1)); end; name:=GetFileName(plik_asm); _i:=1; name:=get_datUp(_i,name,'.',false); if list_mmm then begin WriteAccessFile(plik_hm); AssignFile(mmm,plik_hm); FileMode:=1; Rewrite(mmm); end; if list_hhh then begin WriteAccessFile(plik_h); AssignFile(hhh,plik_h); FileMode:=1; Rewrite(hhh); writeln(hhh,'#ifndef _'+name+'_ASM_H_'); writeln(hhh,'#define _'+name+'_ASM_H_'+#13#10); end; WriteAccessFile(plik_lst); AssignFile(lst,plik_lst); FileMode:=1; Rewrite(lst); WriteAccessFile(plik_obj); Assignfile(dst,plik_obj); FileMode:=1; Rewrite(dst,1); Writeln(lst,t); // naglowek z nazwa programu do pliku LST end; { procedure tttt(a: string); begin case length(a) of 1,2: writeln(hex(ord(a[1]) shl 8+ord(a[2]),8)); 3: writeln(hex(ord(a[1]) shl 16+ord(a[2]) shl 8+ord(a[3]),8)); 4: writeln(hex(ord(a[1]) shl 24+ord(a[2]) shl 16+ord(a[3]) shl 8+ord(a[4]),8)); end; end; } (*----------------------------------------------------------------------------*) (* M A I N P R O G R A M *) (*----------------------------------------------------------------------------*) begin ___search_comment_block := search_comment_block; oblicz_mnemonik__ := oblicz_mnemonik; analizuj_plik__ := analizuj_plik; analizuj_mem__ := analizuj_mem; ___wartosc_noSPC := oblicz_wartosc_noSPC; SetLength(t_lab,1); SetLength(t_hea,1); SetLength(t_mac,1); SetLength(t_par,1); SetLength(t_loc,1); SetLength(t_prc,1); SetLength(t_pth,1); SetLength(t_wyw,1); SetLength(t_rel,1); SetLength(t_smb,1); SetLength(t_ext,1); SetLength(t_extn,1); SetLength(t_str,1); SetLength(t_arr,1); SetLength(t_pag,1); SetLength(t_end,1); SetLength(t_mad,1); SetLength(t_pub,1); SetLength(t_var,1); SetLength(t_skp,1); // SetLength(t_lin,1); SetLength(t_sym,1); SetLength(t_usi,1); SetLength(t_els,1); SetLength(if_stos,1); SetLength(t_siz,2); SetLength(messages,1); pass:=1; (*----------------------------------------------------------------------------*) (* tworzenie tablic 'TCRC16', 'TCRC32' oraz tablicy 'HASH', odczyt parametrow *) (*----------------------------------------------------------------------------*) INITIALIZE; if binary_file.use then begin opt := opt or 2; adres := binary_file.adr; org := true; first_org := false; end; optDefault := opt; open_ok:=true; t:=''; nul.l:=0; nul.i:=0; pass:=0; asem(plik_asm); over:=true; koniec(status); end.