unit Pas2JavaSc; { TAnsiCalculateに#Pas2JavaScを追加する #P2Js の行以後に対して 機械的な置換を行う ,begin ,　｛ ,end , ｝ 対応していない事 ・Type JavaScriptがそもそも変数に型が無いから ・ポインタや参照演算子の類 ・関数内関数 動作の安定の為にある程度処理はしてるが ・for文の変数には毎回letを付けてしまう 等 let付けの怪しさ やってくれる事 ・exit javaにはない pascalは関数の終了なので returnか　return Resultに置換 ・関数の先頭で let Result; 最後に return Result追加 ・'文字列'#13のような文字列を "文字列\r" と置換 ・inc(a)を++aに置換 inc(a,3)をa+=3に置換 ・setlength(a,3)をa.length=3に置換 length(a)をa.lengthに置換 ・piをMath.PI 他Mathにありそうな関数は Math.を付け小文字にする ・ln()をMath.log()に置換 (他にも名前が違う場合もあるだろうけど調査不足) ・sqr(x)を２乗sqr(x)に置換するので自分で２乗に修正すること例 (x)**2 のように ・変数名を最初に使った名前に大文字小文字を固定する ・$abcのような数を 0xabcと置換 ・if while for 文を置換 ・procedure をfunctionに置換 ・var const の型名を削除 ・関数内のvar定義を消して 利用時にletを付けまくる（無駄な分は自分で修正して下さい) ・AND OR XOR NOT 等の & | ^ 置換（ビット演算子としてるので論理型なら自分で修正) ・:=を= =を== <>を!= ・コメント"｛〜｝"を/*〜*/に置換 } //,"{.J}hoge{bom}", bom ,最初に見つけた{}コメントと入れ変える.hogeもbomも何も解釈しない //,"{.J}hoge{} ", ,JavaScriptには出力しない //,"{.J{hoge} ", hoge ,JavaScriptにだけ出力する //,"{.o}foo(hoge,", hoge.foo( ,オブジェクト用で 第一引数のメソッドにする //,"{.r}'hoge' ", hoge ,正規表現用でブラケットを外す(''''には対応していない\x27 を使う事 ) //,"{.E}〜{.e} ", ,出力禁止{.e}が無ければ終端まで#P2Jsの５文字も{.e}と同様の効果がある //,"{.a} ", ,直後の変数 Object.assign({},変数)と置換 //,"{.V} ", ,以後let constをvarとして出力する //,"{.v} ", ,直後のローカル変数定義をvarで出力する //,"{.L} ", ,直後の not and or を ! && || //,"{.B} ", ,直後の not and or を ^ & | /////ファイルモード // ファイルモードでは#P2Jsの5文字がファイル中にある場合に処理し、次の行より処理を始める // ファイルモードでは{#P2Js} や//#P2Jsのように行頭から始まらなくてもよいが大文字小文字は区別する interface uses Windows, SysUtils , CalcAnsiScript , uAnsiCharTools ; type TLabelD = record s: string; t: Integer end; AString = array of TLabelD; TOnTextOut = procedure(s: AnsiString) of object; TOnCMD = procedure(var p: PChar) of object; const //labelMdの内容 lbUse = 1; lbConst = 2; lbInFunc = 4; //ローカル変数 lbBool = 8; //論理型 lbFunc = 16; //メソッドメンバ lbCntM = 128; //この値をネストが深くなると加算し、浅くなると減じる lbLet = 1 shl 30; //ローカル変数 の宣言未だ type TPasRec = record name: string; //record/class名 labels: AString; //定義されるラベル end; TAPasRec = array of TPasRec; TpasMode = //関数宣言は関数内で処理するので (pasExt //初期状態 , pasVar //Var 宣言中 , pasConst //Const宣言中 , pasInFunc //関数内ブロック , pasType //Type宣言中 //そのまま出力する ); TuPas2JavaSc = class(TObject) //一つの関数にしても良いけど private tagConst: string; tagLET: string; endp: PChar; //処理する文字列の終端のアドレス fDebug: boolean; consOutDebug: boolean; isProc: boolean; //関数内かprocedure内か isLogic: boolean; // ロジックモード and or not を&& || !に finFunc: Boolean; pasMode: TpasMode; LabelCnt: Integer; ResultCnt: Integer; //関数内で何度Resultに代入したか ResultValue: string; //その１回だけの帰り値 RecDatas: TAPasRec; RecData: TPasRec; //メソッドのメンバー類が入っている nestc: Integer; isVarOut: boolean; //関数内変数の直後のラベルを書きだす LabelName: AString; //大文字小文字の間違いを減らすために LastSt: string; msgBufstr: string; inCase: boolean; //case中 CaseInBlock: boolean; //case中にbegin endがあった usedBreak: boolean; //case中でbreakを使った labelBrake: string; //ブレークラベル labelBrakeCnt: Integer; //for while repeatの番目 function isMember(var lab: string): boolean; procedure copyC(var p: PChar); //１文字の src->dst copy function isLet(var s: string): boolean; procedure NestLevel(updn: Integer); //ブロックの深さ function SetLabel(s: string; typ: integer; ref: boolean = false): string; procedure msgBuf(s: string); virtual; //dstへの出力 procedure msgNorm(s: string); virtual; //dstへの出力 procedure SwapMsgBufMd(var MsgFunc: TOnTextOut; var dtMsg: string); //バッファモード切替用 procedure outBreak(); procedure CallLp(cmd: TOnCMD; var p: PChar); //for repeat whileを呼ぶ protected msg: TOnTextOut; function prjCall(var p: PChar; c: TSysCharSet; call: string): string; //msgBufに切り替えて結果を返す function prjBool(var p: PChar; c: TSysCharSet; call: string): string; //論理値を必要とする場面 function LabelSet(lab: string; var p: PChar): boolean; procedure mVar(var p: PChar); procedure mIF(var p: PChar); procedure mFor(var p: PChar); procedure mWhile(var p: PChar); procedure mWith(var p: PChar); procedure mRepeat(var p: PChar); procedure mType(var p: PChar); procedure mFunc(var p: PChar); procedure mBlock(var p: PChar; inCase1: boolean); //begin end block procedure mTry(var p: PChar); procedure mCase(var p: PChar); procedure CmtSkip(var p: PChar; swOut: boolean = true); procedure mCmt(var p: PChar; swOut: boolean = true); //{}コメントと置換タグ procedure moji(var p: PChar); procedure kazu(var p: PChar); procedure mOrd(var p: PChar); function mathFunc(const lab: string; var p: PChar): boolean; function kakko(var p: PChar; tojiru: boolean = true): boolean; procedure Hairetu(var p: PChar); public OnTextOut: TOnTextOut; procedure Exec(var p: PChar); procedure prj(var p: PChar; c: TSysCharSet; call: string); end; TPas2JavaScCalc = class(TCalcuAddition) private OutMsgStr: AnsiString; procedure MsgOut(msg: AnsiString); public // function CallFunc(const lab: AnsiString; Labels: TAMyCalLabel): boolean ;override; // function ExeLabel(const lab: AnsiString; var ret: Extended; cmd: TGetLabelCmd): boolean; override; procedure StartEndScript(n: Integer); override; //0:start 1:end; function LineCmd(const lab: AnsiString; var p: PChar): boolean; override; //#で始まる行コマンド function FileExec(const fname: AnsiString; p: PChar): boolean; override; //ファイルモードで特別な処理がある場合 end; implementation function LabelD(nm: string; typ: Integer): TLabelD; begin Result.s := nm; Result.t := typ or lbUse; end; procedure AddStrArray(var d: AString; add: TLabelD); var n: Integer; begin n := length(d); setlength(d, n + 1); d[n] := add; end; procedure labelIsBool(var d, se: AString); var //dにsの名前のラベルを探してlbBoolを付ける i, j: Integer; begin for j := 0 to High(se) do for i := 0 to High(d) do if SameText(d[i].s, se[j].s) then begin d[i].t := d[i].t or lbBool; end; end; procedure AddRecDatas(var d: TAPasRec; add: TPasRec); var n: Integer; begin n := length(d); setlength(d, n + 1); d[n] := add; end; function SwapFlag(var localf, savef: boolean): boolean; begin Result := savef; savef := localf; localf := Result; end; function startsWith(d, s: string): boolean; begin Result := copy(d, 1, length(s)) = s; end; function startsSame(d, s: string): boolean; begin d := copy(d, 1, length(s)); Result := SameText(s, d); end; { TuPas2JavaSc } procedure TuPas2JavaSc.copyC(var p: PChar); begin if p^ = #0 then begin p := p; exit; end; msg(p^); inc(p); end; function TuPas2JavaSc.prjBool(var p: PChar; c: TSysCharSet; call: string): string; //論理値を必要とする場面 begin isLogic := True; Result := prjCall(p, c, call); end; //cは'C'以外は終了条件 procedure TuPas2JavaSc.prj(var p: PChar; c: TSysCharSet; call: string); var s: string; begin inc(Nestc); if consOutDebug then write('/*<' + call + ',' + IntToStr(Nestc) + '>*/'); if fdebug then msg('/*<' + call + ',' + IntToStr(Nestc) + '>*/'); try while p^ <> #0 do begin if not ('p' in c) then if endp <= p then break; CmtSkip(p); LastSt := p^; case p^ of #0: exit; '<': if p[1] = '>' then begin inc(p, 2); msg('!='); end else if p[1] = '=' then begin inc(p, 2); msg('<='); end else copyC(p); '>': if p[1] = '=' then begin inc(p, 2); msg('>='); end else copyC(p); ':': if p[1] = '=' then begin inc(p, 2); msg('='); end else if ':' in c then exit else copyC(p); '=': begin inc(p); msg('=='); end; '(': kakko(p); ')': if ')' in c then exit else copyC(p); '[': Hairetu(p); ']': if ']' in c then exit else copyC(p); ';': if ';' in c then exit else copyC(p); ',': if ',' in c then exit else copyC(p); '#', '''': if 'a' in c then exit else begin moji(p); if 'A' in c then exit; end; '&', //8進数 '%', //2進数 '$', '0'..'9': if '9' in c then exit else begin kazu(p); if '0' in c then exit; end; '_', 'A'..'Z', 'a'..'z': begin s := CAnsiGetAccordChars(p, LabelCharSet); LastSt := lowercase(s); //to とdowntoの区別の為に if SameText(s, 'procedure') or SameText(s, 'function') then if 'f' in c then exit else begin mFunc(p); if 'F' in c then exit; end else if SameText(s, 'type') then mType(p) else if SameText(s, 'var') then mVar(p) else if SameText(s, 'const') then pasMode := pasConst else if SameText(s, 'begin') then if '{' in c then exit else mBlock(p, 'C' in c) else if SameText(s, 'end') then if '}' in c then exit else begin msg('}'); end else if SameText(s, 'then') then if #255 in c then exit else begin msg('then'); end else if SameText(s, 'else') then if #254 in c then exit else begin msg('else'); end else if SameText(s, 'do') then if #253 in c then exit else begin msg('do'); end else if SameText(s, 'to') then if #252 in c then exit else begin msg('to'); end else if SameText(s, 'downto') then if #252 in c then exit else begin msg('downto'); end else if SameText(s, 'try') then mTry(p) else if SameText(s, 'except') then if #251 in c then exit else begin msg('except'); end else if SameText(s, 'finally') then if #251 in c then exit else begin msg('finally'); end else if SameText(s, 'on') then if #250 in c then exit else begin msg('on'); end else if SameText(s, 'repeat') then CallLp(mRepeat, p) else if SameText(s, 'until') then if #249 in c then exit else begin msg('until'); end else if SameText(s, 'case') then mCase(p) else if SameText(s, 'of') then if #248 in c then exit else begin msg('of'); end else if SameText(s, 'raise') then begin msg('throw'); end else if SameText(s, 'if') then mIF(p) else if SameText(s, 'for') then CallLp(mFor, p) else if SameText(s, 'while') then CallLp(mWhile, p) else if SameText(s, 'with') then mWith(p) else if SameText(s, 'break') then outBreak() else if SameText(s, 'continue') then msg('continue') else if SameText(s, 'exit') then if isProc then msg('return') else begin msg('return Result'); ResultCnt := -2; end else if SameText(s, 'and') then if isLogic then msg('&&') else msg('&') else if SameText(s, 'or') then if isLogic then msg('||') else msg('|') else if SameText(s, 'XOR') then msg('^') else if SameText(s, 'SHL') then msg('<<') else if SameText(s, 'NOT') then if isLogic then msg('!') else msg('~') else if SameText(s, 'DIV') then msg('/') else if SameText(s, 'MOD') then msg('%') else if SameText(s, 'self') then msg('this') else if SameText(s, 'True') then msg('true') else if SameText(s, 'False') then msg('false') else if SameText(s, 'ord') then mOrd(p) else if mathFunc(s, p) then else if LabelSet(s, p) then else ; end; else copyC(p); end; end; finally dec(nestc); end; end; procedure TuPas2JavaSc.Hairetu(var p: PChar); begin if p[0] = '[' then copyC(p); prj(p, [#0, ']'], 'Hairetu'); if p[0] = ']' then copyC(p); end; function TuPas2JavaSc.kakko(var p: PChar; tojiru: boolean): boolean; begin Result := p^ = '('; if Result then begin if tojiru then msg('('); inc(p); end; prj(p, [#0, ')'], 'Kakko'); if p^ = ')' then inc(p); if tojiru then msg(')'); end; function TuPas2JavaSc.isMember(var lab: string): boolean; var i: Integer; begin Result := false; for i := 0 to High(RecData.labels) do if SameText(RecData.labels[i].s, lab) then begin Result := True; lab := RecData.labels[i].s; isLogic := (RecData.labels[i].t and lbBool) <> 0; end; end; procedure TuPas2JavaSc.mVar(var p: PChar); begin pasMode := pasVar; if finFunc then CAnsiSkipBlank(p, true); //関数内の変数設定の改行等を削除する end; function TuPas2JavaSc.LabelSet(lab: string; var p: PChar): boolean; type TAChar2 = array[0..1] of AnsiChar; pA2 = ^TAChar2; var sp: PChar; s, Member, ext: string; buf: AString; begin Result := True; s := lab; sp := p; CAnsiSkipBlank(sp); Member := lab; ext := ''; if sp^ = '.' then begin ext := CAnsiGetAccordChars(sp, LabelCharSet + ['.']); lab := lab + ext; p := sp; CAnsiSkipBlank(sp); end; if pasMode = pasConst then begin if finFunc then SetLabel(lab, lbInFunc or lbConst) else SetLabel(lab, lbConst); msg(tagConst); msg(' '); msg(lab); CAnsiGetNextStr(p, [#0, '=']); //型定義部を外す if p^ = '=' then begin msg(p^); inc(p); end; prj(p, [#0, ';'], 'LabelSet.Const'); exit; end; SetLength(buf, 0); if pasMode = pasVar then begin if finFunc then begin //ローカル変数--------------------- CmtSkip(p, false); if isVarOut then begin msg('var ' + lab + ';'); SetLabel(s, lbInFunc); end else SetLabel(s, lbInFunc or lbLet); AddStrArray(buf, LabelD(s, 0)); isVarOut := false; CmtSkip(p, false); while p^ = ',' do begin inc(p); CmtSkip(p, false); s := CAnsiGetAccordChars(p, LabelCharSet); if isVarOut then begin msg('var ' + lab + ';'); SetLabel(s, lbInFunc); end else SetLabel(s, lbInFunc or lbLet); AddStrArray(buf, LabelD(s, 0)); CmtSkip(p, false); end; if p^ = ':' then begin inc(p); CmtSkip(p); s := CAnsiGetNextStr(p, [#0, ';']); //型定義部を外す if startsSame(s, 'bool') then labelIsBool(LabelName, buf); end; isVarOut := false; if p^ = ';' then inc(p); CAnsiSkipBlank(p, true); exit; end else begin //グローバル変数 --------------------- SetLabel(lab, 0); AddStrArray(buf, LabelD(lab, 0)); msg('var ' + lab); msg(CAnsiGetAccordChars(p, cSpace)); while p^ = ',' do begin inc(p); CmtSkip(p); s := CAnsiGetAccordChars(p, LabelCharSet); SetLabel(s, 0); AddStrArray(buf, LabelD(s, 0)); msg('; var ' + s); CmtSkip(p); end; if p^ = ':' then begin inc(p); CmtSkip(p); s := CAnsiGetNextStr(p, [#0, ';']); //型定義部を外す if startsSame(s, 'bool') then labelIsBool(LabelName, buf); end; if p^ = '=' then begin copyC(p); prj(p, [#0, ';'], 'LabelSet.var'); end; exit; end; end; if (pasMode = pasInFunc) and isMember(Member) then begin msg('this.'); msg(lab); msg(ext); exit; end; if pA2(sp)^ <> ':=' then begin msg(SetLabel(lab, 0, true)); exit; end; p := sp; inc(p, 2); if (ResultCnt >= 0) and SameText(lab, 'Result') then begin inc(ResultCnt); //Resultへの代入が複数あるなら諦める if ResultCnt = 1 then begin ResultValue := prjCall(p, [#0, ';'], 'Result'); if p[0] = ';' then inc(p); exit; end; end; if isLet(lab) then s := tagLET + ' ' else s := ''; s := s + lab + ' ='; msg(s); exit; end; function TuPas2JavaSc.isLet(var s: string): boolean; var i: Integer; begin Result := false; for i := 0 to LabelCnt - 1 do if SameText(s, LabelName[i].s) then begin Result := (LabelName[i].t and lbLet) = lbLet; if Result then begin LabelName[i].t := LabelName[i].t and (lbCntM - 1); // lbCntMより上のビットをクリアする end; s := LabelName[i].s; exit; end; end; function TuPas2JavaSc.SetLabel(s: string; typ: integer; ref: boolean): string; var i: Integer; begin //ToDo:これではローカル変数でグローバル変数が上書きされてしまうぞ for i := 0 to LabelCnt - 1 do if SameText(s, LabelName[i].s) then begin Result := LabelName[i].s; LabelName[i].t := typ or lbUse; if ref then isLogic := (LabelName[i].t and lbBool) <> 0; exit; end; LabelName[LabelCnt].s := s; LabelName[LabelCnt].t := typ or lbUse; inc(LabelCnt); if LabelCnt >= length(LabelName) then begin SetLength(LabelName, length(LabelName) * 2); end; Result := s; end; procedure TuPas2JavaSc.NestLevel(updn: Integer); var i: Integer; begin for i := 0 to LabelCnt - 1 do begin if ((LabelName[i].t and lbInFunc) <> 0) and ((LabelName[i].t and lblet) = 0) then begin LabelName[i].t := LabelName[i].t + updn * lbCntM; end; end; end; procedure TuPas2JavaSc.mOrd(var p: PChar); var pSave: PChar; begin pSave := p; CAnsiSkipBlank(p); if p^ = '(' then begin inc(p); CAnsiSkipBlank(p); if (p[0] = '''') and (p[0] = p[2]) then begin msg(format('/*%s*/0x%2.2x', [p[1], ord(p[1])])); if (p[0] = p[1]) and (p[0] = p[3]) then inc(p, 4) else inc(p, 4); CAnsiSkipBlank(p); if p^ = '(' then inc(p); end else begin kakko(p, false); msg('.codePointAt(0)'); end; exit; end; p := pSave; end; //java mathクラスの処理と間違えそうなsqrの処理 //inc/decを++/-- に置換する function TuPas2JavaSc.mathFunc(const lab: AnsiString; var p: PChar): boolean; const math = 'PI,power,ln,sqr,abs,acos,acosh,asin,atan,atan2,atanh,cbrt,ceil,cos,cosh,exp,floor,hypot,log,log10,log2,max,min,pow,random,round,sign,sin,sinh,sqrt,tan,trunc,'; var s, v: string; n: Integer; sp: PChar; begin sp := p; CAnsiSkipBlank(sp); s := LowerCase(lab); if s = 'pi' then begin Result := True; msg('Math.PI'); exit; end; Result := false; if (s = 'char') then begin if sp^ <> '(' then exit; msg('String.fromCharCode'); Result := true; exit; end; if (s = 'inc') or (s = 'dec') then begin CAnsiSkipBlank(p); if sp^ <> '(' then exit; p := sp + 1; v := CAnsiGetNextStr(p, [#0, ',', ')']); Result := True; v := SetLabel(v, 0); if p^ = ',' then begin inc(p); if s = 'inc' then msg(v + '+=') else msg(v + '-='); prj(p, [#0, ')'], 'f.inc'); if p^ = ')' then inc(p); end else begin if s = 'inc' then msg('++' + v) else msg('--' + v); end; if p^ = ')' then inc(p); exit; end; if (s = 'length') then begin // length ----------------- CAnsiSkipBlank(p); if p^ <> '(' then exit; inc(p); v := CAnsiGetNextStr(p, [#0, ')']); Result := True; v := SetLabel(v, 0); msg(v + '.length'); if p^ = ')' then inc(p); exit; end; if (s = 'setlength') then begin // SetLength ----------------- CAnsiSkipBlank(p); if p^ <> '(' then exit; inc(p); v := CAnsiGetNextStr(p, [#0, ',']); Result := True; if isLet(v) then msg(tagLET + ' ' + v + ';'); msg(v + '.length = '); if p^ = ',' then inc(p); prj(p, [#0, ')'], 'f.Length'); if p^ = ')' then inc(p); exit; end; if (s = 'inttostr') or (s = 'floattostr') then begin if p^ <> '(' then exit; msg('String'); kakko(p); Result := True; exit; end; n := Pos(',' + s + ',', math); Result := false; if n < 1 then begin if sp = '(' then begin Result := True; p := sp; msg(lab); kakko(p); end; exit; end; CAnsiSkipBlank(p); if p^ <> '(' then exit; Result := True; if s = 'power' then msg('Math.pow') else if s = 'ln' then msg('Math.log') else if s = 'sqr' then msg('２乗sqr') else begin s := copy(math, n + 1, 10); n := Pos(',', s); s := copy(s, 1, n - 1); msg('Math.' + s); end; kakko(p); end; //複数行コメントの処理 procedure TuPas2JavaSc.CmtSkip(var p: PChar; swOut: boolean); procedure m(s: AnsiString); begin if swOut then msg(s); end; begin repeat m(CAnsiGetAccordChars(p, cSpace)); case p^ of '/': if p[1] = '/' then begin m(CAnsiGetNextStr(p, [#0, #13, #10])); continue; end; '{': begin mCmt(p); continue; end; '(': if p[1] = '*' then begin mCmt(p); continue; end; else break; end; break; until false; end; procedure TuPas2JavaSc.mCmt(var p: PChar; swOut: boolean); procedure m(s: AnsiString); begin if swOut then msg(s); end; var s: string; ps: PChar; opsiz: Integer; begin opsiz := 4; ps := p; if CAnsiCmpStrs(p, ['(*']) then begin inc(p); opsiz := 5; end; if (p[1] = '.') then //ちょっと手抜き if (((ps[0] = '{') and (p[3] = '}')) or CAnsiCmpStrs(p + 3, ['*)'])) then case p[2] of 'J': begin inc(p, opsiz); if ps[0] = '{' then begin CAnsiGetSplitStr(p, '{'); msg(CAnsiGetSplitStr(p, '}')); end else begin CAnsiGetSplitStr(p, '(*'); msg(CAnsiGetSplitStr(p, '*)')); end; exit; end; 'o': begin inc(p, opsiz); s := CAnsiGetSplitStr(p, '('); msg(prjCall(p, [#0, ','], '{.o}')); if p[0] = ',' then inc(p); msg('.'); msg(s); msg('('); kakko(p); exit; end; 'a': begin inc(p, opsiz); s := CAnsiGetAccordChars(p, LabelCharSet); msg('Object.assign({},'); msg(s); msg(')'); exit; end; 'r': begin inc(p, opsiz); s := p[0]; inc(p); msg(CAnsiGetSplitStr(p, s)); exit; end; 'E': begin inc(p, opsiz); CAnsiFindStrs(p, ['{.e}', '(*.e*)', '']); exit; end; 'V': begin inc(p, opsiz); tagConst := 'var'; tagLET := 'var'; exit; end; 'v': begin inc(p, opsiz); isVarOut := true; exit; end; 'L': begin inc(p, opsiz); isLogic := true; exit; end; 'B': begin inc(p, opsiz); isLogic := false; exit; end; end; m('/*'); inc(p); if ps[0] = '{' then begin m(CAnsiGetNextStr(p, [#0, '}']) + '*/'); if p^ = '}' then inc(p); end else begin m(CAnsiGetSplitStr(p, '*)') + '*/'); end; end; // Typeの処理方法が思いつかないのでそのまま出力 procedure TuPas2JavaSc.mType(var p: PChar); var s, lab, typeName: string; RecData: TPasRec; no: Integer; fEnum: boolean; begin pasMode := pasType; msg('/*type*/'); while not (p^ in [#0]) do begin CmtSkip(p); case p^ of '_', 'A'..'Z', 'a'..'z': begin s := CAnsiGetAccordChars(p, LabelCharSet); if SameText(s, 'procedure') or SameText(s, 'function') then begin pasMode := pasExt; LastSt := lowercase(s); mFunc(p); exit; end else if SameText(s, 'var') then begin pasMode := pasVar; exit; end else if SameText(s, 'type') then msg('type') else if SameText(s, 'const') then begin pasMode := pasConst; exit; end ; msg(CAnsiGetAccordChars(p, cSpace)); if p[0] = '=' then begin typeName := s; inc(p); msg(CAnsiGetAccordChars(p, cSpace)); s := CAnsiGetAccordChars(p, LabelCharSet); if SameText(s, 'procedure') or SameText(s, 'function') then begin msg('/*'); msg(typeName); msg('='); msg(s); msg(CAnsiGetNextStr(p, [#0, #13, #10])); msg('*/'); continue; end; if SameText(s, 'record') or SameText(s, 'class') then begin CAnsiSkip(p, [' ', #9, #13, #10]); if p[0] = '(' then begin inc(p); msg('/*' + CAnsiGetSplitStr(p, ')') + '*/'); end; if p[0] = ';' then begin //事前定義 msg('/*'); msg(typeName); msg('='); msg(s); msg('*/'); inc(p); continue; end; RecData.name := typeName; SetLength(RecData.labels, 0); msg('function ' + typeName + '(){'); while not (p^ in [#0]) do begin CmtSkip(p); case p^ of '_', 'A'..'Z', 'a'..'z': begin s := CAnsiGetAccordChars(p, LabelCharSet); if SameText(s, 'procedure') or SameText(s, 'function') then begin msg(cvU('/*◆function')); msg(CAnsiGetAccordChars(p, cSpace)); s := CAnsiGetAccordChars(p, LabelCharSet); AddStrArray(RecData.labels, LabelD(s, lbFunc)); msg(s); msg(CAnsiGetNextStr(p, [#0, #13, #10])); msg(cvU('◆*/')); continue; end else if SameText(s, 'end') then begin msg(' return this;}'); AddRecDatas(RecDatas, RecData); break; end else if SameText(s, 'private') then msg('/*private*/') else if SameText(s, 'protected') then msg('/*protected*/') else if SameText(s, 'public') then msg('/*public*/') else begin lab := s; msg('this.' + lab); if p^ = ':' then begin //型名は読み飛ばす inc(p); CmtSkip(p); s := CAnsiGetNextStr(p, [#0, ',', ';']); //型定義部を外す if startsSame(s, 'bool') then AddStrArray(RecData.labels, LabelD(lab, lbBool)) else AddStrArray(RecData.labels, LabelD(lab, 0)); if startsSame(s, 'double') or startsSame(s, 'Int') then msg('=0 /*' + s + '*/') else if startsSame(s, 'string') then msg('="" /*' + s + '*/') else if startsSame(s, 'array') then msg('=[] /*' + s + '*/') else msg('/*' + s + '*/') end else if p[0] in [',', ';'] then copyC(p); end; end; else copyC(p); end; end; end else begin // class or record end fEnum := true; if SameText(s, 'set') then begin //set of はコメントアウト msg('/* '); msg(s); msg(CAnsiGetAccordChars(p, cSpace)); s := CAnsiGetAccordChars(p, LabelCharSet); msg(s); //of msg('*/ '); fEnum := false; end else begin msg('/*'); msg(typeName); msg('='); msg(s); msg(CAnsiGetNextStr(p, [#0, ';'])); msg('*/'); if p[0] = ';' then inc(p); continue; end; msg(CAnsiGetAccordChars(p, cSpace)); if p[0] = '(' then begin //列挙型 msg(tagConst); msg(' '); msg(typeName); msg('='); msg('{'); inc(p); no := 0; repeat msg(CAnsiGetAccordChars(p, cSpace)); CmtSkip(p); case p^ of ',': begin msg(','); inc(p); continue; end; ')': begin msg('}'); inc(p); break; ; end; //列挙型終わり '_', 'A'..'Z', 'a'..'z': begin msg(CAnsiGetAccordChars(p, LabelCharSet)); if fEnum then begin msg(':'); msg(IntToStr(no)); inc(no); end else msg(':false'); msg(CAnsiGetAccordChars(p, cSpace)); end; else begin copyC(p); msg(cvU('<◆?')); end; end; until p^ = #0; end; end; end; end; else copyC(p); end; end; end; //関数宣言　引数の型名を外してゆく procedure TuPas2JavaSc.mFunc(var p: PChar); var i, j, n, m, resultBool: Integer; ps: PChar; s, fncName, clsName: string; svIsProc, thisInFunc, thisIsProc, thisIsMe: boolean; SaveLabelName: AString; begin inCase := false; //case中 labelBrakeCnt := 0; //for while repeatの番目 svIsProc := isProc; ResultCnt := -1; thisInFunc := finFunc; thisIsProc := LastSt = 'procedure'; isProc := thisIsProc; finFunc := True; pasMode := pasInFunc; CAnsiSkipBlank(p); s := CAnsiGetAccordChars(p, LabelCharSet); fncName := s; thisIsMe := p^ = '.'; if thisIsMe then begin //メソッドの場合 clsName := s; inc(p); CAnsiSkipBlank(p); fncName := CAnsiGetAccordChars(p, LabelCharSet); n := -1; m := -1; for i := 0 to High(RecDatas) do if SameText(RecDatas[i].name, clsName) then begin n := i; clsName := RecDatas[n].name; //大文字小文字ゆらぎ対策 for j := 0 to High(RecDatas[i].labels) do if SameText(RecDatas[i].labels[j].s, fncName) then m := j; if m < 0 then AddStrArray(RecDatas[i].labels, LabelD(fncName, lbFunc)) else fncName := RecDatas[n].labels[m].s; //大文字小文字ゆらぎ対策 resultBool := RecDatas[n].labels[m].t; //帰り値が論理型か RecData := RecDatas[n]; break; end; if n < 0 then begin RecData.name := clsName; SetLength(RecData.labels, 1); RecData.labels[0] := LabelD(fncName, lbFunc); end; ps := p; if p^ = '(' then inc(p); msg(clsName); msg('.prototype.'); msg(fncName); msg('=function ('); end else begin CAnsiSkipBlank(p); ps := p; if p^ = '(' then inc(p); msg('function '); msg(s); msg('('); end; CAnsiSkipBlank(p); repeat //ループではなくbreakで抜ける為に if ps^ <> '(' then begin msg(') {'#13#10); CAnsiSkipBlank(p); if p^ = ':' then begin //型名は読み飛ばす inc(p); if startsSame(CAnsiGetNextStr(p, [#0, ';']), 'bool') then begin resultBool := resultBool or lbBool; RecDatas[n].labels[m].t := resultBool; end; end; if p^ = ';' then begin // ;は()のないprocedure/functionの終わり inc(p); CAnsiSkipBlank(p, true); end; break; end; while true do begin CmtSkip(p); if p^ = #0 then exit; msg(CAnsiGetAccordChars(p, cSpace)); s := CAnsiGetAccordChars(p, LabelCharSet); CmtSkip(p); if SameText(s, 'var') //これらは読み飛ばす or SameText(s, 'out') or SameText(s, 'const') then begin msg(CAnsiGetAccordChars(p, cSpace)); CmtSkip(p); s := CAnsiGetAccordChars(p, LabelCharSet); CmtSkip(p); end; msg(s); //引数名 SetLabel(s, lbInFunc); if p^ = ':' then begin //型名は読み飛ばす inc(p); CAnsiGetNextStr(p, [#0, ',', ';', ')']); CmtSkip(p); end; if p^ in [',', ';'] then begin msg(','); inc(p); end; if p^ = ')' then begin inc(p); msg(') {'#13#10); CAnsiSkipBlank(p, true); CmtSkip(p); if p^ = ':' then begin //型名は読み飛ばす inc(p); CAnsiSkipBlank(p, true); s := CAnsiGetNextStr(p, [#0, ' ', #9, ';']); CAnsiSkipBlank(p, true); end; if p^ = ';' then inc(p); //;は読み飛ばす CAnsiSkipBlank(p, true); break; end; end; break; until true; repeat finFunc := True; ps := p; s := prjCall(p, [#0, 'f', '{'], 'mFunc.def'); if (LastSt = 'procedure') or (LastSt = 'function') then begin //関数内関数なので p := ps; //巻き戻して finFunc := false; //変数宣言にVAR宣言をさせる prj(p, [#0, '}', 'F'], 'mFunc.In.' + fncName); CAnsiSkipBlank(p, true); if p[0] = ';' then copyC(p); end else begin msg(s); break; end; until false; if (LastSt = 'begin') then begin NestLevel(+1); isProc := thisIsProc; if not thisIsProc then begin ResultCnt := 0; finFunc := false; pasMode := pasInFunc; ps := p; SaveLabelName := LabelName; SetLength(SaveLabelName, length(LabelName)); s := prjCall(p, [#0, '}'], 'function.Code.' + fncName); if ResultCnt = 1 then begin msg(s); msg('return '); msg(ResultValue); msg(';'#13#10'}'); if fDebug then msg(format('/*end %s #(%d)*/', [fncName, nestc])); NestLevel(-1); if thisIsMe then SetLength(RecData.labels, 0); pasMode := pasExt; //関数内ブロックの終了 isProc := svIsProc; exit; end; LabelName := SaveLabelName; p := ps; end; ResultCnt := -1; if not thisIsProc then msg(tagLET + ' Result;'#13#10); //Resultをローカル変数として登録する CAnsiSkipBlank(p, true); if not thisIsProc then SetLabel('Result', lbInFunc or resultBool); finFunc := false; pasMode := pasInFunc; prj(p, [#0, '}'], 'mFunc.Code.' + fncName); if not thisIsProc then msg('return Result;//'#13#10); //Resultを返すのを追加 msg('}'); if fDebug then msg(format('/*end %s #(%d)*/', [fncName, nestc])); NestLevel(-1); if thisIsMe then SetLength(RecData.labels, 0); isProc := svIsProc; pasMode := pasExt; //関数内ブロックの終了 exit; end; isProc := svIsProc; end; procedure TuPas2JavaSc.mBlock(var p: PChar; inCase1: boolean); begin if not inCase1 then begin msg('{'); NestLevel(+1); end; CmtSkip(p); //caseの中のブロックだけ外す prj(p, [#0, '}'], 'mBlock'); if not inCase1 then begin msg('}'); NestLevel(-1); end else begin CmtSkip(p); //case 中のブロックは外せるので外す　その場合;が重なるので CaseInBlock := True; end; end; procedure TuPas2JavaSc.SwapMsgBufMd(var MsgFunc: TOnTextOut; var dtMsg: string); var buf: string; svMsgFunc: TOnTextOut; begin buf := dtMsg; SetLength(buf, length(buf)); dtMsg := MsgBufstr; SetLength(dtMsg, length(dtMsg)); MsgBufstr := buf; svMsgFunc := msg; msg := MsgFunc; MsgFunc := svMsgFunc; end; function TuPas2JavaSc.prjCall(var p: PChar; c: TSysCharSet; call: string): string; var MsgFunc: TOnTextOut; saves: string; savedbg: boolean; begin savedbg := fDebug; fDebug := false; MsgFunc := msgBuf; saves := ''; SwapMsgBufMd(MsgFunc, saves); prj(p, c, call); SwapMsgBufMd(MsgFunc, saves); Result := saves; fDebug := savedbg; end; procedure TuPas2JavaSc.CallLp(cmd: TOnCMD; var p: PChar); //for repeat whileを呼ぶ var MsgFunc: TOnTextOut; saves: string; usedBreakSv: boolean; labelBrakeSv: string; begin usedBreakSv := usedBreak; labelBrakeSv := labelBrake; usedBreak := false; //case中でbreakを使った inc(labelBrakeCnt); labelBrake := 'L' + IntToStr(labelBrakeCnt); MsgFunc := msgBuf; saves := ''; SwapMsgBufMd(MsgFunc, saves); cmd(p); SwapMsgBufMd(MsgFunc, saves); if usedBreak then begin msg(labelBrake); msg(':'); end; msg(saves); usedBreak := usedBreakSv; labelBrake := labelBrakeSv; end; procedure TuPas2JavaSc.outBreak(); begin msg('break'); if inCase then begin //case中にあるbreakはbreak labelに変換 msg(' '); msg(labelBrake); usedBreak := true; end; end; procedure TuPas2JavaSc.mCase(var p: PChar); var s: string; q: PChar; inCaseSv: boolean; CaseInBlockSv: boolean; begin inCaseSv := inCase; CaseInBlockSv := CaseInBlock; msg('switch('); CmtSkip(p); prj(p, [#248, '}', #0], 'mCase.of'); // of=#248 msg('){/* case */'); CmtSkip(p); //コメント+空白系の文字をそのまま渡す repeat inCase := false; if p^ = #0 then exit; repeat CmtSkip(p); //コメント+空白系の文字をそのまま渡す s := prjCall(p, [':', ',', #254, '}', #0], 'mCase.tag'); // else=#254 end=} if LastSt = 'end' then begin msg('}/*switch(case) end*/ '); inCase := inCaseSv; CaseInBlock := CaseInBlockSv; exit; end else if LastSt = 'else' then begin msg('default:'); break; end else begin msg('case '); msg(s); msg(':'); end; q := p; if p^ in [',', ':'] then inc(p); until not (q[0] = ','); inCase := True; CaseInBlock := false; prj(p, [#0, ';', 'b', 'C'], 'mCase.code'); //'b'break 'C'begin〜endのブロック解除 inCase := false; if CaseInBlock then if p[0] = ';' then inc(p); if p^ in [';'] then copyC(p); msg('break; '); until p[0] = #0; end; procedure TuPas2JavaSc.mTry(var p: PChar); var m, s: string; begin NestLevel(+1); msg('try {/* */'); prj(p, [#251, #0], 'mTry.In'); //finally か except m := LastSt; if LastSt = 'except' then begin msg('} catch(e){'); // s := prjCall(p, [#0, #254, #250, '}'], 'mTry.catch'); //Else=#54 ON=#250 end=} if (LastSt = 'end') or (p^ = #0) then begin //ONがない msg(s); msg('}'); //end まで NestLevel(-1); exit; end; msg(cvU('/* on は自前で修正してね　*/)')); msg(s); repeat if (LastSt = 'on') then begin msg(' if (e instanceof /*'); prj(p, [#0, ':'], 'mTry.on'); msg(cvU(' :★要修正*/)')); prj(p, [#0, #253, ';'], 'mTry.do'); //Do=#253 msg(') {'); prj(p, [#0, ';'], 'mTry.doCode'); // end else break; prj(p, [#0, #254, #250, '}'], 'mTry.else'); //Else=#54 ON=#250 end=} if (LastSt = 'on') then begin msg('} else '); // end else if (LastSt = 'else') then begin msg('} else { '); // prj(p, [#0, #254, #250, ';'], 'mTry.elseCode'); //Else=#54 ON=#250 end=} msg('} ; '); // break; end else if (LastSt = 'end') then begin msg('} ; '); // msg('/* ******' + m + ' End********* */}'); //end まで NestLevel(-1); exit; end; until LastSt <> 'on'; end else begin msg('} finally {'); end; prj(p, [#0, '}'], 'mTry.finally'); msg('/*' + m + ' End */}'); //end まで NestLevel(-1); end; procedure TuPas2JavaSc.mIF(var p: PChar); begin msg('if('); msg(prjBool(p, [#0, #255], 'mIF')); //thenまでを返す msg(')'); prj(p, [#0, #254, ';'], 'mIF.then'); //;か #254=else end直前まで if (LastSt = 'else') then begin msg('else'); prj(p, [';', #0], 'mIF.else'); end; end; procedure TuPas2JavaSc.mRepeat(var p: PChar); var ps: PChar; s: string; begin msg('do{ /*repeat*/ '); msg(CAnsiGetAccordChars(p, cSpace)); //空白系の文字をそのまま渡す NestLevel(+1); prj(p, [#0, #249], 'repeat'); //untilまで NestLevel(-1); CAnsiSkipBlank(p, true); s := prjBool(p, [#0, ';'], 'until'); //;までを返す ps := PChar(s); CmtSkipC(ps, cSpace); s := ps; s := trim(s); if SameText(s, 'true') then s := '!false'; if SameText(s, 'false') then s := '!true'; ps := PChar(s); if ps[0] = '!' then begin inc(ps); msg('}while ('); msg(ps); msg(')'); end else begin msg('}while (!('); //論理が逆なので msg(s); msg(cvU('))/*untilはtrueで終了*/')); end; end; procedure TuPas2JavaSc.mWith(var p: PChar); begin msg('with('); prj(p, [#0, #253], 'with'); //doまでを返す msg(')'); prj(p, [#0, ';'], 'with.code'); //end直前まで end; procedure TuPas2JavaSc.mWhile(var p: PChar); //var sp: PChar; begin msg('while('); msg(prjBool(p, [#0, #253], 'while')); //doまでを返す msg(')'); prj(p, [#0, ';'], 'while.code'); //end直前まで // sp := p; // msg(CAnsiGetAccordChars(p, cSpace)); //空白系の文字をそのまま渡す // if sameText(CAnsiGetAccordChars(sp, LabelCharSet), 'begin') then begin // msg('{'); // p := sp; // NestLevel(+1); // prj(p, [#0, '}'], 'while.code'); //end直前まで // msg('}'); // NestLevel(-1); // end; end; {pascal for i=0 to n do for i=n downto m do javaSC for(let i=0;i<=n;i++) for(let i=n;i>=n;i--) } procedure TuPas2JavaSc.mFor(var p: PChar); var isInc: boolean; lab: string; begin msg('for('); CAnsiSkipBlank(p); if p^ in ['_', 'A'..'Z', 'a'..'z'] then begin lab := CAnsiGetAccordChars(p, LabelCharSet); lab := setLabel(lab, lbInFunc); if isLet(lab) then msg(tagLET + ' '); msg(lab); end; prj(p, [#0, #252], 'for.to'); //to/downtoまでを返す isInc := LastSt = 'to'; if isInc then msg(';' + lab + '<=') else msg(';' + lab + '>='); prj(p, [#0, #253], 'for.do'); //doまでを返す if isInc then msg(';' + lab + '++ )') else msg(';' + lab + '-- )'); NestLevel(+1); prj(p, [#0, ';'], 'for.code'); //;までを返す NestLevel(-1); end; { 数値表現の違い , ,Pascal,javaSc , 2進数,%0101 ,0b0101 , 8進数,&0123 ,0o0123 ,16進数,$01aB ,0x01aB 他はほぼ同じなのでそのまま渡せばよい +-符号もそのまま渡せばよいので無視 ただ数値列の範囲を確認する必要がある 　数.数E±数 } procedure TuPas2JavaSc.kazu(var p: PChar); var s: string; sp: PChar; begin sp := p; inc(p); case sp^ of '&': s := '0o' + CAnsiGetAccordChars(p, ['0'..'7']); //8進数 '%': s := '0b' + CAnsiGetAccordChars(p, ['0', '1']); //2進数 '$': s := '0X' + CAnsiGetAccordChars(p, ['0'..'9', 'a'..'z', 'A'..'Z']); //16進数 '0'..'9': begin s := sp^ + CAnsiGetAccordChars(p, ['0'..'9']); if p^ = '.' then begin //小数点の後に数字 inc(p); s := s + '.' + CAnsiGetAccordChars(p, ['0'..'9']); end; if p^ in ['e', 'E'] then begin //Eの後に符号 s := s + p^; inc(p); if p^ in ['+', '-'] then begin //Eの後に符号 s := s + p^; inc(p); end; s := s + CAnsiGetAccordChars(p, ['0'..'9']); end; end; end; msg(s); end; { 文字表現の違い Pascal '文字'と(#の後に数字)の連続 ''''で'１文字 javaSc '文字'か"文字"で\\は１文字\ , ,Pascal,javaSc , CR ,#13 ,\r \x0d , LF ,#10 ,\n \x0a ,TAB ,#9 ,\t \x09 ,FEED,#12 ,\f \x0c , ,'' ,\' , ," ,\" , ,\ ,\\ } procedure TuPas2JavaSc.moji(var p: PChar); var s, n: string; c: Integer; begin s := ''; while true do begin if p^ = '#' then begin inc(p); n := CAnsiGetAccordChars(p, ['0'..'9']); if n <> '' then c := StrToInt(n) else c := 0; case c of 9: s := s + '\t'; 10: s := s + '\n'; 13: s := s + '\r'; 12: s := s + '\f'; else s := s + format('\x%2.2x', [c]); end; end else if p^ = '''' then begin inc(p); while not (p^ in [#0, #10..#13]) do if (p[0] = '''') then begin if (p[1] = p[0]) then begin inc(p, 2); s := s + '\'''; end else begin inc(p); break; end; end else if (p[0] = '"') then begin inc(p); s := s + '\"'; end else begin s := s + p[0]; inc(p); end; end else break; end; msg('"'); msg(s); msg('"'); end; procedure TuPas2JavaSc.msgNorm(s: string); begin if Assigned(OnTextOut) then OnTextOut(s); if consOutDebug then write(s); end; procedure TuPas2JavaSc.msgBuf(s: string); begin msgBufStr := addS([msgBufStr, s]); if consOutDebug then write(s); end; procedure TuPas2JavaSc.Exec(var p: PChar); begin if consOutDebug then allocConsole; tagConst := 'const'; tagLET := 'let'; msg := msgNorm; finFunc := False; pasMode := pasExt; LabelCnt := 0; nestc := 0; ResultCnt := -1; SetLength(LabelName, 4096); prj(p, [#0], 'Exec'); end; procedure writeFileStr(fname, s: ansistring); var hin: THandle; rsize: DWORD; begin rsize := 0; hin := CreateFile(pansichar(fname), GENERIC_WRITE, FILE_SHARE_WRITE, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); if hin <> INVALID_HANDLE_VALUE then try windows.Writefile(hin, pansichar(s)^, Length(s), rsize, nil); finally CloseHandle(hin); end; end; procedure TPas2JavaScCalc.MsgOut(msg: AnsiString); var w, sz: integer; begin w := length(OutMsgStr); sz := length(msg); SetLength(OutMsgStr, w + sz); move(msg[1], OutMsgStr[w + 1], sz); end; function TPas2JavaScCalc.FileExec(const fname: AnsiString; p: PChar): boolean; var s, fil: string; begin Result := CAnsiFindStrs(p, ['#P2Js']); if Result then begin CAnsiSkipBlank(p); fil := ''; if p[0] = '''' then begin inc(p); fil := CAnsiGetSplitStr(p, ''''); CAnsiSkipBlank(p); end; s := CAnsiGetAccordChars(p, LabelCharSet); CAnsiGetNextStr(p, [#0, #13, #10]); // 文字セットのどれか迄の文字列 CAnsiSkip(p, [#13, #10]); with TuPas2JavaSc.Create do try fDebug := SameText(s, 'debug'); consOutDebug := s = 'Debug'; endp := PChar(owner.MyCmd) + length(owner.MyCmd); OnTextOut := MsgOut; Exec(p); finally free end; if fil <> '' then begin writeFileStr(fil, OutMsgStr); end else begin owner.MsgOut(OutMsgStr); end; end; end; function TPas2JavaScCalc.LineCmd(const lab: AnsiString; var p: PChar): boolean; var s: string; begin Result := False; if SameText(lab, 'h') or (lab = '') then //helpの時は処理してもfalseを返す begin owner.MsgOutLn(cvU( '#P2Js の行以後に対して 機械的な置換を行う'#13#10 + '# コンソールモードでは1行単位に解釈されるので動作しない'#13#10 + '')); end; if not SameText(lab, 'P2Js') then exit; CAnsiSkipBlank(p); s := CAnsiGetAccordChars(p, LabelCharSet); CAnsiGetNextStr(p, [#0, #13, #10]); // 文字セットのどれか迄の文字列 CAnsiSkip(p, [#13, #10]); with TuPas2JavaSc.Create do try fDebug := SameText(s, 'debug'); endp := PChar(owner.MyCmd) + length(owner.MyCmd); OnTextOut := owner.MsgOut; Exec(p); finally free end; end; procedure TPas2JavaScCalc.StartEndScript(n: Integer); begin case n of //0:start 1:end; 0: begin end; 1: begin end; end; end; initialization CalcAddTCalcuAddition(TPas2JavaScCalc); end.