procedure toUnicode(var s: String); var Buffer: PWideChar; L: Integer; ansi:PChar; begin L := MultiByteToWideChar(CP_ACP, 0, PChar(s),-1,nil,0); GetMem(Buffer, L*2); MultiByteToWideChar(CP_ACP,0,PChar(s),-1,Buffer,L); L := WideCharToMultiByte(CP_UTF8,0,Buffer,-1,nil,0,nil,nil); GetMem(ansi, L+1); WideCharToMultiByte(CP_UTF8,0,Buffer,-1,ansi,L,nil,nil); s := ansi; FreeMem(Buffer); FreeMem(ansi); end; procedure tostr_delphi(var s:string); begin replace(s, '''', ''''''); end; var TP_PControl:integer; function _getType(dt:PScData):integer; begin Result := dt.getType; if(Result = data_code)or(Result = data_array)then Result := dt.getSubType; end; var cmp:string; toUtf8:boolean; function readCmp(e:id_element; cgt:PCodeGenTools):string; var _cmp:array[0..24] of char; begin if cmp = '' then begin cardinal(pointer(@_cmp[0])^) := e; cgt.GetParam(PARAM_COMPILER, @_cmp[0]); cmp := _cmp; toUtf8 := pos('fpc', lowercase(cmp)) > 0; end; Result := cmp; end; function _toCode(data:PScData; toType:byte):PScData; var ok:boolean; begin Result := data; ok := false; case toType of data_int: case _getType(data) of data_str: begin Result := MakeData('str2int(', true); Result.AddValue(data, true); Result.AddValue(MakeData(')', true), true); ok := true; end; data_real: begin Result := MakeData('round(', true); Result.AddValue(data, true); Result.AddValue(MakeData(')', true), true); ok := true; end; data_int:; else begin Result := MakeData('0', true); ok := true; end; end; data_str: case _getType(data) of data_int: begin Result := MakeData('KOLString(int2str(', true); Result.AddValue(data, true); Result.AddValue(MakeData('))', true), true); ok := true; end; data_real: begin Result := MakeData('KOLString(double2str(', true); Result.AddValue(data, true); Result.AddValue(MakeData('))', true), true); ok := true; end; data_str:; else begin Result := MakeData('', false); ok := true; end; end; data_real: case _getType(data) of data_str: begin Result := MakeData('str2double(', true); Result.AddValue(data, true); Result.AddValue(MakeData(')', true), true); ok := true; end; data_real,data_int:; else begin Result := MakeData('0.0', true); ok := true; end; end end; if ok then Result.SetSubType(toType); end; procedure _readCustomProperty(Result:PScData; e:id_element; cgt:PCodeGenTools; prop:id_prop); begin if cgt.propGetType(prop) = data_str then begin replace(Result.value.sdata, '''', ''''''); readCmp(e, cgt); if toUtf8 then toUnicode(Result.value.sdata); end; end; procedure _lng_begin_proc(parser:TParser; const name:string); var oldb, tmp, old_loc, loc_dt, fname:PScData; s:string; begin oldb := parser.VarList.find('old_block'); tmp := parser.VarList.find('tmp_block'); old_loc := parser.VarList.find('loc_block'); fname := parser.VarList.find('_fname_'); if oldb = nil then oldb := parser.VarList.addArg('old_block'); if tmp = nil then tmp := parser.VarList.addArg('tmp_block'); if old_loc = nil then old_loc := parser.VarList.addArg('loc_block'); if fname = nil then fname := parser.VarList.addArg('_fname_'); fname.setValue(name); loc_dt := GVarList.find('blk_loc'); old_loc.setValue(loc_dt.toStr()); loc_dt.SetValue(parser.codeb.reggen(), data_code); s := parser.codeb.reggen(); tmp.SetValue(s); oldb.setValue(parser.codeb.select(s)); end; procedure _lng_end_proc(parser:TParser; const scope:string); var loc_dt:PScData; name,b:string; begin loc_dt := GVarList.find('blk_loc'); name := parser.VarList.find('_fname_').toStr(); parser.codeb.select(scope); parser.Print('procedure ' + name + ';'); parser.PrintLine(); parser.codeb.select(GVarList.find('blk_mtd_body').toStr()); parser.Print('procedure ' + GVarList.find('cur_class').toStr() + '.' + name + ';'); parser.PrintLine(); if not parser.codeb.isEmpty(loc_dt.toStr()) then begin parser.Print('var'); parser.PrintLine(); parser.codeb.CopyTo(loc_dt.toStr(), parser.codeb.CurBlockName); parser.codeb.delete(loc_dt.toStr()); end; parser.Print('begin'); parser.PrintLine(); parser.codeb.level := parser.codeb.level + 1; loc_dt.setValue(parser.VarList.find('loc_block').toStr(), data_code); b := parser.VarList.find('tmp_block').toStr(); parser.codeb.CopyTo(b, parser.codeb.CurBlockName); parser.codeb.delete(b); parser.codeb.level := parser.codeb.level - 1; parser.Print('end;'); parser.PrintLine(); parser.codeb.select(parser.VarList.find('old_block').toStr()); end; type lng_indexer = ( lng_begin, lng_end, lng_decl_class_var, lng_decl_loc_var, lng_begin_proc, lng_end_proc, lng_include, lng_get_type, lng_isFPC, lng_last); function lng_proc(parser:TParser; obj:pointer; index:integer; args:TArgs):TScData; var dt:PScData; old,s:string; t:integer; begin Result.SetValue(''); case lng_indexer(index) of lng_begin: begin parser.Print('begin'); parser.codeb.level := parser.codeb.level + 1; parser.PrintLine; end; lng_end: begin parser.codeb.level := parser.codeb.level - 1; parser.Print('end;'); parser.PrintLine; end; lng_decl_class_var: begin dt := GVarList.find('blk_pub'); if dt = nil then parser.debug('BLK_PUB - not found') else begin old := parser.codeb.select(dt.toStr()); parser.Print(args.Values[0].toStr); parser.Print(':' + args.Values[1].toStr + ';'); parser.PrintLine; parser.codeb.select(old); end; end; lng_decl_loc_var: begin dt := GVarList.find('blk_loc'); if dt = nil then parser.debug('BLK_LOC - not found') else begin old := parser.codeb.select(dt.toStr()); parser.Print(args.Values[0].toStr); parser.Print(':' + args.Values[1].toStr + ';'); parser.PrintLine; parser.codeb.select(old); end; end; lng_begin_proc: _lng_begin_proc(parser, args.Values[0].toStr); lng_end_proc: _lng_end_proc(parser, args.Values[0].toStr); lng_include: begin old := parser.codeb.select(GVarList.find('blk_inc').toStr); s := ',' + args.Values[0].toStr(); if pos(s, parser.codeb.AsCode) = 0 then begin parser.print(s); parser.PrintLine; end; parser.codeb.select(old); end; lng_get_type: begin t := args.Values[0].getType; if(t = data_code)or(t = data_array)then t := args.Values[0].getSubType; Result.Setvalue(t); end; lng_isFPC: begin if pos('fpc', lowercase(readCmp(parser.el, parser.cgt))) > 0 then Result.Setvalue(1) else Result.Setvalue(0); end; end; end; procedure fill_lng_object(var methods:TAObjMethod; var count:integer); begin RegisterUserType('PControl'); readCustomProperty := _readCustomProperty; count := integer(lng_last); setlength(methods, count); methods[integer(lng_begin)] := MakeMethod('begin', 0, ''); methods[integer(lng_end)] := MakeMethod('end', 0, ''); methods[integer(lng_decl_class_var)] := MakeMethod('decl_class_var', 2, 'name, type'); methods[integer(lng_decl_loc_var)] := MakeMethod('decl_loc_var', 2, 'name, type'); methods[integer(lng_begin_proc)] := MakeMethod('begin_proc', 1, 'name'); methods[integer(lng_end_proc)] := MakeMethod('end_proc', 1, 'scope'); methods[integer(lng_include)] := MakeMethod('include', 1, 'unit'); methods[integer(lng_get_type)] := MakeMethod('get_type', 1, 'expression'); methods[integer(lng_isFPC)] := MakeMethod('isfpc', 0, ''); end; const lng_count = 1; lngs:array[0..lng_count-1] of TLangRec = ( (entry:'MainForm'; name:'delphi'; str_del_o: ''''; str_del_c: ''''; op_del: ' + '; var_mask:'%n%i'; tostr_proc:tostr_delphi) );