十進BASIC　機能拡張の手引き

十進BASIC内部構造

　十進BASICは，object Pascalのオブジェクトを生成し，オブジェクトが自立して動くコンパイラである。
　BASICの文に対応するTStatementというオブジェクト型(Class)を定義し，その下位型で仮想メソッドexecuteをoverrideすることで目的の処理を実現している。
　BASIC Generic 0.7.5.9を例に新規に命令を追加するための手順の形で内部構造を述べる。
　十進BASICのホームページでBASIC Genericのページに入り，BASIC0759Ja_Source.zip（あるいは，それ以降の版）をダウンロードし展開する。
Lazarusをダウンロードしてインストールしておく（Lazarus Download）。
　Lazarusを起動して，プロジェクトメニューから「プロジェクトを開く」を選び，BASICのsourceフォルダからbasic.lpiを選ぶ。
　Lazarusのファイルメニューで，extensio.pasをソースエディタに読み込んでみよう。
　extenssio.pasの末尾が，

begin
  tableInitProcs.accept(statementTableinit);
  tableInitProcs.accept(FunctionTableInit);
end.

となっている。
Pascalのbegin～end. (end後がピリオド)はプログラムの実行開始時に実行される。
tableInitProcs.acceptによって，命令文や組込関数を登録する。 statementTableinitを文を，FunctionTableInitを組込関数を登録するのに用いている。

単純文の追加

Procedure statementTableinitのbegin～end に書かれた

       StatementTableInitImperative('BEEP',BEEPst);

を見てみよう。これは，'BEEP'を読み込んだらBEEPstで翻訳処理を行うことの指定である。
　BEEPstの定義部は，

function BEEPst(prev,eld:TStatement):TStatement;
begin
   BEEPst:=TBEEP.create(prev,eld)
end;

となっていて，TBEEP型のオブジェクトを生成する文となっている。createの引数prev, eldは文のリンクを作るために使われるが，とりあえず，この形で書くべきものと理解しておけば十分である。
オブジェクト型TBEEPの定義は，

type
  TBEEP=class(TStatement)
     exp1,exp2:TPrincipal;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      procedure exec;override;
   end;

となっている。TBEEPは，TStatementクラスを継承する下位クラスである。
十進BASICのBEEP文は，基本は引数なしだけれども，Windowsでは2個の数値式を引数にとる形もある。TPrincipal 型の変数exp1とexp2はその数値式を保持するために用いられる。
TBEEP.createは，次のように定義されている。

constructor TBeep.create;
begin
  inherited create(prev,eld);
  if (tokenspec<>tail) and (token<>'ELSE') then
  begin
    exp1:=NExpression;
    check(',',IDH_FILE_ENLARGE);
    exp2:=NExpression;
  end;
end;

constructorでは，最初に継承元のconstructorを呼び出す。prevとeldはそこで用いられる。constructorを実行すると，オブジェクト内の変数はnilで初期化される。
BEEP文には引数なしと2個の引数を持つ場合の2通りがあるので，constructorでの処理が少しややこしい。行末注釈を除外したときの文の終わりは，tokenspec=tailで判定するけれども，BEEP文は単純実行文なので，IF … THEN ～ ELSE ～の～部分に書かれることもある。そのため，文が終わっていないことを判定するためには，上掲のようなif文を書く（ELSEはFull BASICの予約語である）。tokenは，翻訳時の現トークンを保持する大域変数である。 NExpressionは，数値式を翻訳する大域関数である。その結果をexp1とexp2に保持する。
2個の数値式の間には，コンマを書く。check(',',IDH_FILE_ENLARGE)は正しくコンマが書かれているを調べ，正しければコンマを読み飛ばし，そうでなければ，IDH_FILE_ENLARGEの情報にしたがってエラーを生成する。IDH_FILE_ENLARGEの部分は0であっても正常動作には影響しない。
destructorはオブジェクトの廃棄時に呼ばれる。必ずoverrideを付加して宣言しておく。
destructorの定義部は，

destructor TBeep.destroy;
begin
   exp1.free;
   exp2.free;
   inherited destroy
end;

となっている。TBEEPの宣言部で書いた2つの変数を削除するためexp1.free; exp2.free;を実行した後，継承元のdestructorを実行する。
TBEEP.execは，このオブジェクトに実行の順番が回ってきたときに実行される。その文がどんな文であるかにかかわらず，TStatement.execが呼び出される。そのとき，正しくTBEEP.execが実行されるために，TBEEPの宣言部でexecはoverrideを付加して宣言されている。
その中身は，次のようになっている。

procedure TBEEP.exec;
var
   freq,duration:integer;
begin
   if exp1=nil then
      SysUtils.beep
   else
      begin
         freq:=exp1.evalInteger;
         duration:=exp2.evalInteger;
         {$IFDEF Windows}
         Windows.Beep(freq,duration);
         {$ELSE}
         SysUtils.beep;
         {$ENDIF}
      end;
end;

　引数なしのときは，単純にSysUtils.beepを実行する。引数なしの判定のためにexp1がnilであるかどうかを調べている。引数を書いたときは，2つの数値式の値を求めてWindows.Beepを呼び出す。十進BASIC処理系においてTPrincipal型変数を評価して整数値を得るメソッドはevalIntegerである。ただし，Windows以外の環境でWindows.beepは使えない。そのときは，2変数の値を無視してSysUtils.beepを実行する。
{$IFDEF ○○○}～{$ELSE}～{$ENDIF}は，翻訳時スイッチである。翻訳時に○○○が定義されていると1個目の～が翻訳される。Windows環境でLazarusを実行するときは，Windowsが定義されている。

関数の追加

　GETKEYSTATE関数を見てみよう。GETKEYSTATE関数は数値式一つを引数とする数値関数である。

    {$IFNDEF Darwin}
     SuppliedFunctionTableInit('GETKEYSTATE' , GetKeyStatefnc);
    {$ENDIF}

となっている。{$IFNDEF ○○}～{$ENDIF}は，〇○が定義されていないとき，～を翻訳することを指示する。DarwinとはMAC OSのことである。MAC OSではGETKEYSTATEが無効なので翻訳できないように制限している。
　この文は，トークンが'GETKEYSTATE'であったらGetKeyStatefncを実行させることを指示している。
　GetKeyStatefncの定義部は，

function  GetKeyStatefnc:TPrincipal;
begin
      GetKeyStatefnc:=NOperation(TGetKeyState.create)
end;

となっている。SuppliedFunctionTableInitに登録する関数は，TPrincipal値をとる。
TGetKeyStateクラスの定義部は，

    TGetKeyState=class(TMiscInt)
       exp:TPrincipal;
      constructor create;
      function evalLongint:longint;override;
      destructor destroy;override;
    end;

となっている。引数の数値式を保持するためにTPrincipal型の変数expを持っている。GETKEYSTATEは，LongInt値を与える関数evalLongintを定義することで関数としての動作を獲得する。EvalLongintで値を定めることで関数値を定める関数は，TMiscIntクラスを継承して定義する。
　TGetKeyStateのconstructorは次のようになっている。checkTokenはcheckとほぼ同等だけれど，正しくないときに半強制的にプログラムを修正する点が異なる。

constructor TGetKeyState.create;
begin
     inherited create;
     checkToken('(',IDH_EXTENSION) ;
     exp:=NExpression;
     checkToken(')',IDH_EXTENSION);
end;

　TGetKeyStateのdestructorは次にようになっている。

destructor TGetKeyState.destroy;
begin
    exp.free;
    inherited destroy
end;

　GetKeyState関数はTMiscIntの下位クラスとして定義された。Longint型の値をとる仮想メソッドevalLongintを定義することで実際の動作が定まる。

function TGetKeyState.evalLongint:longint;
begin
   result:=GetKeyState(exp.evalinteger);
end;

　ここで用いているGetKeyStateは，LazarusのLCLライブラリのLCLIntfで定義されている。extensio.pasのuses節にLCLIntfを書くことでLCLIntfで定義された関数の利用ができる。

実数値をとる関数の追加

　実数値をとる関数は，TMiscRealの下位型で宣言し，Extended型の値を取る仮想メソッドevalXを定義することで実装する。
　注意すべきことは，Windows 64ビットのときと，CPUがARMのときは，Extended＝doubleとしてコンパイルされることである。{$IF FPC_HAS_TYPE_EXTENDED} ～｛$ELSE｝～ {$ENDIF}による場合分けが必要となるかもしれない。

文字列関数の追加

　文字列値を取る関数は，TStrExpressionクラスの下位クラスとして実装し，文字列を取るメソッドevalSをoverrideすることで実現できる。

新規ユニット雛形

次の内容をnewcmd.pasとして保存し，Lazarusのプロジェクトメニューで，「プロジェクトインスペクタ」で「追加」を選び，さらに「追加」を選んで，newcmd.pasを選択する。
　newcmdの部分は他の綴りでもよいが，ユニット名とファイル名を一致させること。
　以後，Lazarus IDEで適宜修正してコンパイルする。
—――――――――――――――――――(ここから)――――――――――――――――――――

unit newcmd;

  {$MODE DELPHI}{$H+}

interface

implementation
uses  Controls, Dialogs, Forms, SysUtils, lclintf, FileUtil, math,
    base, arithmet, texthand, variabl, struct, express, compiler, control,
 float,  helpctex, textfrm, MainFrm, sconsts, supplied;

{***********************************}
{ 単純文　パラメータは数値1個と文字列1個 }
{***********************************}

type
   TNewCommand=class(TStatement)

      exp1,exp2:TPrincipal;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      procedure exec;override;
    end;

constructor TNewCommand.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
   exp1:=NExpression;
   check(',',0);
   exp2:=SExpression;
end;

destructor TNewCommand.destroy;
begin
   exp2.free;
   exp1.free;
   inherited destroy
end;

procedure TNewCommand.exec;
var
   x:double;
  s:string;
begin
   x:=exp1.EvalF;
   s:=exp2.EvalS;
  //ここで必要な処理を記述する
end;

function  NewCommandst(prev,eld:TStatement):TStatement;
begin
    NewCommandst:=TNewCommand.create(prev,eld);
end;

{********************}
{数値関数　引数は数値一つ }
{*********************}
type
   TNewNFunction=Class(TMiscReal)
             exp:TPrincipal;
          constructor create;
          function evalX:extended;override;
          destructor destroy;override;
     end;

constructor TNewNFunction.create;
begin
    inherited create;
    check('(',0);
    exp:=NExpression;
    check(')',0);
end;

function TNewNFunction.evalX:extended;
var
   x, y: extended;
begin
   x:=exp.evalX;
  //ここで，xからyを求める
   evalX:=y;
end;

destructor TNewNFunction.destroy;
begin
   exp.free;
   inherited destroy;
end;

function NewNFunctionfnc:TPrincipal;
begin
   NewNFunctionfnc:=NOperation(TNewNFunction.create);
end;

{*********************************}
{文字列値関数  引数は文字列1個，数値1個}
{**********************************}

type
   TNewSFunction=class(TStrExpression)
             exp1,exp2:TPrincipal;
          constructor create;
          function evalS:string;override;
          destructor destroy;override;
     end;

constructor TNewSFunction.create;
begin
   inherited create;
   check('(',0);
   exp1:=SExpression;
   check(',',0);
   exp2:=NExpression;
   check(')',0);
end;

destructor TNewSFunction.destroy;
begin
   exp2.free;
   exp1.free;
   inherited destroy;
end;

function TNewSFunction.evalS:ansistring;
var
   n:longint;
   s,t:string;
begin
   s:=exp1.evalS;
   n:=exp2.evalInteger;
  //ここでs,nからtを求める
   evalS:=s;
end;

function NewSFunctionfnc:TPrincipal;
begin
   NewSFunctionfnc:=TNewSFunction.create;
end;


{**********}
{initialize}
{**********}

procedure statementTableinit;
begin
       StatementTableInitImperative('NEWCOMMAND', NewCommandst);

end;


procedure  FunctionTableInit;
begin
     SuppliedFunctionTableInit('NEWFN' , NewNFunctionfnc);
     SuppliedFunctionTableInit('NEWF$' , NewSFunctionfnc);
end;


begin
  tableInitProcs.accept(statementTableinit);
  tableInitProcs.accept(FunctionTableInit);
end.

—―――――――――――――――――――(ここまで)―—―――――――――――――――――

注意点は，ステートメント名，関数名は，文字列関数名の末尾の$を含め10文字以内で，英字は大文字で登録すること。
LCLを含め他のユニットで定義された機能を利用するときは，uses節にそのユニット名を追加する。

外部DLLのリンク

新規コマンドを作成するのに外部DLLを利用することができる。たとえば，Windowsでwin32APIのBeepを用いるためには，

function Beep(dwFreq:DWORD; dwDuration:DWORD):WINBOOL; stdcall; external 'kernel32' name 'Beep';

の一行を追加する。この一行で関数Beepを定義したことになる。externalでDLLの名称，nameでDLL内の関数名を指定する。externalとnameの指示内容（’ ’で囲まれた部分）では英字の大小の違いが識別される。引数の型と個数，結果型がDLL関数の呼び出しに用いられる。引数名は意味を持たない。 C言語向けに作成されたDLLの関数を呼び出すときは，stdcallのかわりにcdeclを書く。
はじめに示したTBEEP.execは次のように書き換えられる。

{$IFDEF Windows}
function Beep(dwFreq:DWORD; dwDuration:DWORD):WINBOOL; stdcall; external 'kernel32' name 'Beep';
{$ENDIF}
procedure TBEEP.exec;
var
   freq,duration:integer;
begin
   if exp1=nil then
      SysUtils.beep
   else
      begin
         freq:=exp1.evalInteger;
         duration:=exp2.evalInteger;
         {$IFDEF Windows}
         Beep(freq,duration);
         {$ELSE}
         SysUtils.beep;
         {$ENDIF}
      end;
end;

指定したDLLが存在しない環境では起動できなくなることに注意。

BASIC Accelerator，Paract BASIC

BASIC AcceleratorとParact BASICでは，文，関数ともに，ansistring型の値をもつ仮想メソッドcodeをoverrideしてPascal文を生成する。その際，構成要素のcodeメソッドを利用できる。
　statemen.pasやsupplied.pasを参照すれば，具体例が見つかる。
なお，生成するPascalコードで独自に用意したライブラリ内の手続きや関数を使うこともできるが，その場合には，それら（実行時に使うユニット）をstruct.pasのTProcTbl.Code中のUsesBlockに追加しなければならない。テスト段階では，RunメニューのCodeで得られるBASICunit.pasを修正して実行してもよい。なお，実行時に使うユニットでは，外部から参照される手続きや関数をinterface部で宣言しておかなければならないことにも注意。

十進BASIC 機能拡張の手引き