← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/tcl/tcl_demo.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/tcl/tcl_demo.pp
 
1
{* tcl_demo.pas
 
2
 * ------------------------------------------------
 
3
 * Copyright 2002 by Bert Raccoon aka Max Artemev
 
4
 * (bert@furry.ru, bert_raccoon@freemail.ru)
 
5
 * ------------------------------------------------
 
6
 * Demo for tcl80.pas unit.
 
7
 * Creating the Tcl interpreter, executing file, registering
 
8
 * new commands, call a function defined in the script.
 
9
 *
 
10
 * Under Win32 can cause crash.
 
11
 *}
 
12
program test;
 
13
 
 
14
uses tcl80, SysUtils;
 
15
 
 
16
{*
 
17
 * Function for testing that string is correct number
 
18
 *}
 
19
function is_num(const src: PChar): Boolean;
 
20
var
 
21
   i: integer;
 
22
begin
 
23
     is_num:=True;
 
24
     i:=0;
 
25
     repeat
 
26
        is_num:=is_num and ((src + i)^  in ['0'..'9']);
 
27
        inc(i);
 
28
     until (src + i)^ = #0;
 
29
end;
 
30
 
 
31
function Test_max(clientData: Tcl_ClientData;  {* Some user defined data. *}
 
32
                  interp: PTcl_Interp;         {* Pointer to Tcl interpreter *}
 
33
                  argc: integer;               {* Arguments counter, arguments, etc *}
 
34
                  argv: Tcl_Argv): longint;    {* Remeber! *NIX `integer` type is 16 bit! *}
 
35
                  cdecl;                       {* C calling convention *}
 
36
var
 
37
   arg    : PChar;
 
38
   idx,
 
39
   value,
 
40
   maxVal : LongInt;
 
41
begin
 
42
     maxVal := 0; {* Zero variable. Very stupid comment? ;)) *}
 
43
 
 
44
     {* The `max` can be done with at least two digits
 
45
      * In ArgvItem(argv,0) passed function name
 
46
      *}
 
47
     if (argc < 3) then
 
48
     begin
 
49
          Tcl_AppendResult(interp, ['bad # arg: ', ArgvItem(argv,0), ' num1 num2 [..numN]', nil]);
 
50
          {* Under Win32 calling of this function can cause crash *}
 
51
 
 
52
          Test_max:=TCL_ERROR;         {* Error was occured *}
 
53
          exit;                        {* Leave *}
 
54
     end;
 
55
 
 
56
     for idx := 1 to argc-1 do         {* In argv[0] passed function name, so
 
57
                                        * go from the first index, not zero.
 
58
                                        *}
 
59
     begin
 
60
          arg := ArgvItem(argv,idx);   {* get an argument *}
 
61
          if (not is_num(arg)) then    {* Is right number? *}
 
62
          begin
 
63
               Tcl_AppendResult(interp,[' "', arg, '" is not a valid integer value']);
 
64
               Test_max:=TCL_ERROR;    {* Error was occured *}
 
65
               exit;                   {* leave *}
 
66
          end;
 
67
          Value:=StrToInt(arg);        {* Convert PChar->Integer *}
 
68
          if (value > maxVal) then
 
69
             maxVal := value;          {* Calculate maximum number *}
 
70
     end;
 
71
 
 
72
     {* Set the result for the our function.
 
73
      * result type always is PChar
 
74
      *}
 
75
     Tcl_SetResult(interp, PChar(IntToStr(maxVal)), nil);
 
76
 
 
77
     {* exit successful *}
 
78
     Test_max:=TCL_OK;
 
79
end;
 
80
 
 
81
{*
 
82
 *  Old and good known Pascal procedure :)
 
83
 *}
 
84
function Test_writeln(clientData: Tcl_ClientData; interp: pTcl_Interp; argc: integer; argv: Tcl_Argv): longint; cdecl;
 
85
var
 
86
   i: integer;
 
87
   Buff: string;
 
88
begin
 
89
     Buff := '';
 
90
     for i:=1 to argc-1 do
 
91
       Buff:=Buff + ArgvItem(argv,i);  {* work around some bugs *}
 
92
     writeln(Buff);
 
93
     Test_writeln:=TCL_OK;
 
94
end;
 
95
 
 
96
 
 
97
var
 
98
   interp: PTcl_Interp;
 
99
   code: integer;
 
100
begin
 
101
     interp := Tcl_CreateInterp();  {* Create an interpreter *}
 
102
     Tcl_Init(interp);              {* Initialize *}
 
103
 
 
104
     {* Register/override in the Tcl engine our new functions *}
 
105
     Tcl_CreateCommand(interp,'max', TTclCmdProc(@Test_max),nil,nil);
 
106
     Tcl_CreateCommand(interp,'writeln',TTclCmdProc(@Test_writeln),nil,nil);
 
107
 
 
108
     code := Tcl_EvalFile(interp,'test.tcl');   {* Execute script *}
 
109
     if (code <> TCL_OK) then                   {* Is all okay? *}
 
110
        writeln(Tcl_GetStringResult(interp));
 
111
 
 
112
     {* Call a function `foo` defined in the script *}
 
113
     code := Tcl_VarEval(interp,['foo ','1 2 3',nil]);
 
114
     if (code <> TCL_OK) then
 
115
        writeln(Tcl_GetStringResult(interp));
 
116
     Tcl_DeleteInterp(interp);                  {* Release interpreter *}
 
117
end.