├── .github └── workflows │ ├── ci-linux.yml │ ├── ci-macos.yml │ └── ci-windows.yaml ├── .gitignore ├── COPYING ├── README.md ├── alire.toml ├── bin ├── clean.tcl └── install.tcl ├── demos ├── .gitignore ├── Makefile ├── alire.toml ├── freq.adb ├── freq.pl ├── freq.tcl ├── futurevalue.adb ├── futurevalue.tcl ├── futurevalue_app.adb ├── futurevalue_app.ads ├── hello_world.adb ├── tash_demos.gpr ├── tashapp.adb ├── tashapp.ads ├── tashell.adb ├── testfreq.tcl ├── timer.adb ├── timer.tcl ├── timer_app.adb ├── timer_app.ads ├── twashapp.adb ├── twashapp.ads ├── twashell.adb ├── watching.adb ├── watching.tcl ├── watching_support.adb ├── watching_support.ads └── wordify.adb ├── docs ├── README.htm ├── intro.doc ├── intro.htm ├── intro.pdf ├── pigui.doc ├── pigui.htm ├── pigui.pdf ├── sigada00.pdf ├── sigada00.ppt └── triada97.ppt ├── images ├── Fig01.gif ├── Fig09.gif ├── Fig21.gif └── tri.gif ├── src ├── Makefile ├── cargv-test.adb ├── cargv.adb ├── cargv.ads ├── chelper.adb ├── chelper.ads ├── tash-arrays.adb ├── tash-arrays.ads ├── tash-file.adb ├── tash-file.ads ├── tash-file_io.adb ├── tash-file_io.ads ├── tash-float_arrays.ads ├── tash-float_lists.ads ├── tash-floats.adb ├── tash-floats.ads ├── tash-integer_arrays.ads ├── tash-integer_lists.ads ├── tash-integers.adb ├── tash-integers.ads ├── tash-lists.adb ├── tash-lists.ads ├── tash-platform.adb ├── tash-platform.ads ├── tash-regexp.adb ├── tash-regexp.ads ├── tash-strings.adb ├── tash-strings.ads ├── tash-system.adb ├── tash-system.ads ├── tash.adb ├── tash.ads ├── tcl-ada.adb ├── tcl-ada.ads ├── tcl-async.adb ├── tcl-async.ads ├── tcl-tk-ada.adb ├── tcl-tk-ada.ads ├── tcl-tk.adb ├── tcl-tk.ads ├── tcl.adb ├── tcl.ads ├── tcl_backward_compatibility_glue.c ├── tcl_record_sizes.gpr ├── tcl_record_sizes.tcl ├── tclmacro.c └── tkmacro.c ├── tash.gpr ├── tcl_tk_options.gpr └── tests ├── .gitignore ├── Makefile ├── alire.toml ├── compare.adb ├── tash_tests.gpr ├── tashtest.adb ├── tashtest.tcl ├── testapp.adb └── testapp.ads /.github/workflows/ci-linux.yml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | name: CI Linux 4 | 5 | on: 6 | push: 7 | pull_request: 8 | 9 | jobs: 10 | build: 11 | name: CI on linux 12 | 13 | runs-on: ubuntu-latest 14 | 15 | steps: 16 | - 17 | name: Checkout 18 | uses: actions/checkout@v2 19 | - 20 | name: alire-project/setup-alire 21 | uses: alire-project/setup-alire@v1 22 | - 23 | name: Install toolchain 24 | run: | 25 | alr --non-interactive config --global --set toolchain.assistant false 26 | alr --non-interactive toolchain --install gnat_native 27 | alr --non-interactive toolchain --install gprbuild 28 | alr --non-interactive toolchain --select gnat_native 29 | alr --non-interactive toolchain --select gprbuild 30 | - 31 | name: Build and run 32 | run: | 33 | cd tests; alr --non-interactive build; ./tashtest tashtest.tcl 34 | -------------------------------------------------------------------------------- /.github/workflows/ci-macos.yml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | name: CI macOS 4 | 5 | on: 6 | push: 7 | pull_request: 8 | 9 | jobs: 10 | build: 11 | name: CI on macOS 12 | 13 | runs-on: macos-latest 14 | 15 | steps: 16 | - 17 | name: Checkout 18 | uses: actions/checkout@v2 19 | - 20 | name: alire-project/setup-alire 21 | uses: alire-project/setup-alire@v1 22 | - 23 | name: Install toolchain 24 | run: | 25 | alr --non-interactive config --global --set toolchain.assistant false 26 | alr --non-interactive toolchain --install gnat_native 27 | alr --non-interactive toolchain --install gprbuild 28 | alr --non-interactive toolchain --select gnat_native 29 | alr --non-interactive toolchain --select gprbuild 30 | - 31 | name: Set up Homebrew 32 | run: | 33 | brew update 34 | brew unlink tcl-tk 35 | brew upgrade tcl-tk 36 | - 37 | name: Build and run 38 | run: | 39 | eval $(brew shellenv) 40 | cd tests; alr --non-interactive build; ./tashtest tashtest.tcl 41 | -------------------------------------------------------------------------------- /.github/workflows/ci-windows.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | name: CI Windows 4 | 5 | on: 6 | push: 7 | pull_request: 8 | 9 | jobs: 10 | build: 11 | name: CI on windows 12 | 13 | runs-on: windows-latest 14 | 15 | steps: 16 | - 17 | name: Checkout 18 | uses: actions/checkout@v2 19 | - 20 | name: alire-project/setup-alire 21 | uses: alire-project/setup-alire@v1 22 | - 23 | name: Install toolchain 24 | run: | 25 | alr --non-interactive config --global --set toolchain.assistant false 26 | alr --non-interactive toolchain --install gnat_native 27 | alr --non-interactive toolchain --install gprbuild 28 | alr --non-interactive toolchain --select gnat_native 29 | alr --non-interactive toolchain --select gprbuild 30 | - 31 | name: Build and run 32 | run: | 33 | cd tests; alr --non-interactive build; ./tashtest tashtest.tcl 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.orig 2 | *~ 3 | 4 | .build* 5 | *-stamp 6 | gpr_query.db* 7 | gnatinspect.db 8 | auto.cgpr 9 | 10 | include* 11 | lib-* 12 | 13 | src/tcl_record_sizes* 14 | 15 | alire 16 | config 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Tcl Ada SHell # 2 | 3 | Tcl Ada SHell (Tash) is an Ada binding to Tcl/Tk. 4 | 5 | Its purpose is to 6 | 7 | * allow a Tcl program to use Ada in place of C to implement Tcl commands where additional execution speed, more complex data structures, or better name space management is needed, and 8 | 9 | * support the rapid development of Platform-Independent Graphical User Interfaces via Tk. 10 | 11 | ## Installation and usage ## 12 | 13 | This branch is designed to be used with [Alire](https://alire.ada.dev/docs/#introduction). 14 | ``` 15 | alr init --bin my_project 16 | cd my_project 17 | alr with tash 18 | ``` 19 | 20 | ## Licensing ## 21 | 22 | The software is released under the GPL Version 2, with the following additional permission: 23 | 24 | >As a special exception, if other files instantiate generics from this unit, or you link this unit with other files to produce an executable, this unit does not by itself cause the resulting executable to be covered by the GNU General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Public License. 25 | 26 | ## Skinny Tcl Binding ## 27 | 28 | TASH includes both skinny and medium bindings to Tcl. The skinny binding is a direct translation of the public Tcl interface, `tcl.h`. It is implemented in the Ada package `Tcl`. It includes all the definitions in `tcl.h`, both functions and data types. All data types are implemented with Ada equivalents from `Interfaces.C`. All functions take C data types and use return codes for status information. 29 | 30 | ## Medium Tcl Binding ## 31 | 32 | In addition to the skinny binding, TASH provides a medium binding to Tcl. This binding replaces C data types with Ada types (e.g. `String` is used in place of `Interfaces.C.Strings.chars_ptr`), uses exceptions in place of return codes and uses generic packages to implement Tcl `clientdata` types. 33 | 34 | ## The TASHELL Interpreter ## 35 | 36 | The Tcl distribution includes a Tcl shell interpreter, named `tclsh`. The TASH binding derives its name from the Ada version of the Tcl shell interpreter: Tcl Ada SHell. Just like `tclsh`, `tashell` reads and interprets a Tcl script. It is also a good starting point for building a custom Tcl interpreter in which new Tcl commands are implemented in Ada rather than C. 37 | 38 | An early paper describing the rationale of the design of TASH is available in several different formats in the docs directory. 39 | 40 | ## Skinny Tk Binding ## 41 | 42 | TASH includes both skinny and medium bindings to Tk. The skinny binding is a direct translation of the public Tk interface, `tk.h`, and is implemented in the Ada package, `Tcl.Tk`. 43 | 44 | ## Medium Tk Binding ## 45 | 46 | An early, experimental medium binding to Tk is provided in the Ada package, `Tcl.Tk.Ada`. This binding does not yet support all Tk widgets. 47 | 48 | ## The TWASHELL Interpreter ## 49 | 50 | `twashell` is the Tcl Windowing Ada SHell. It is the Ada version of the Tcl/Tk `wish` program. Just like `wish`, it reads and interprets a Tcl/Tk script. It is also a starting point for building a custom Tcl/Tk interpreter in which new Tcl/Tk commands are implemented in Ada rather than C. 51 | 52 | An early paper describing how `twashell` is a Platform-Independent toolkit for development of Graphical User Interfaces is available in several different formats in the docs directory. 53 | 54 | -------------------------------------------------------------------------------- /alire.toml: -------------------------------------------------------------------------------- 1 | name = "tash" 2 | description = "Binding to Tcl/Tk" 3 | long-description = """ 4 | Tash (previously known as Tcl Ada Shell) is an Ada binding to Tcl/Tk. 5 | 6 | Its purpose is to 7 | 8 | * allow a Tcl program to use Ada in place of C to implement Tcl 9 | commands where additional execution speed, more complex data 10 | structures, or better name space management is needed, and 11 | 12 | * support the rapid development of Platform-Independent Graphical User 13 | Interfaces via Tk. 14 | 15 | Please note that, on macOS, tash assumes that Tcl/Tk is provided via 16 | [Homebrew](https://brew.sh). 17 | """ 18 | website = "https://github.com/simonjwright/tcladashell" 19 | version = "8.7.2" 20 | licenses = "GPL-2.0-or-later WITH GCC-exception-2.0" 21 | 22 | authors = ["Simon Wright"] 23 | maintainers = ["Simon Wright "] 24 | maintainers-logins = ["simonjwright"] 25 | 26 | project-files = ["tash.gpr"] 27 | 28 | tags = ["scripting", "tcl", "tk"] 29 | 30 | [gpr-externals] 31 | TASH_LIBRARY_TYPE = ["static", "relocatable"] 32 | 33 | [[depends-on]] 34 | "libtcl" = "~8.6.0" 35 | "libtk" = "~8.6.0" 36 | 37 | [gpr-set-externals.'case(os)'] 38 | windows = { TASH_PLATFORM = "windows" } 39 | linux = { TASH_PLATFORM = "linux" } 40 | macos = { TASH_PLATFORM = "macos" } 41 | 42 | [[actions]] 43 | type = "post-fetch" 44 | command = ["make", "-C", "src", "tcl_record_sizes.ads"] 45 | -------------------------------------------------------------------------------- /bin/clean.tcl: -------------------------------------------------------------------------------- 1 | #------------------------------------------------ 2 | # 3 | # NAME: clean.tcl 4 | # 5 | # ABSTRACT: This Tcl script cleans up after a build. 6 | # It was written so that a common command can be 7 | # executed to clean up after a make regardless of 8 | # whether this is a Windows or Unix platform. 9 | # 10 | # USAGE: tclsh clean.tcl [ file | directory ] ... 11 | # 12 | # DESCRIPTION: Deletes all object files (*.o), Ada library 13 | # files and other GNAT artifacts (*.ali, b_*.c), 14 | # various temporary editor files (*~ .*~ #* .#*), 15 | # executable files (*.exe), core files, and all 16 | # files specified in command line arguments. 17 | # 18 | # If first argument is a directory, changes to 19 | # the directory before deleting files. For any 20 | # subsequent directories, changes to the it 21 | # relative to original current working directory 22 | # and deletes files there. 23 | # 24 | #------------------------------------------------ 25 | 26 | # Procedure compares two strings, returns 1 if equal, 0 if not 27 | #------------------------------------------------------------- 28 | proc cequal {left right} { 29 | return [expr [string compare $left $right] == 0] 30 | } 31 | 32 | # Procedure deletes files in current working directory 33 | #----------------------------------------------------- 34 | proc Clean {} { 35 | 36 | # get tail of directory so we can later test whether 37 | # we're in Windows or not 38 | #--------------------------------------------------- 39 | set tail [file tail [pwd]] 40 | 41 | if ![catch {eval glob *.o *.ali b_*.c *~ .*~ #* .#* *.exe core} files] { 42 | 43 | foreach file $files { 44 | if [cequal $tail "win"] { 45 | # we don't want to delete tclmacro.o and tkmacro.o 46 | # in Windows because not everyone will have a C 47 | # compiler so they can rebuild them. 48 | #------------------------------------------------- 49 | if [regexp "macro.o" $file] { 50 | continue 51 | } 52 | } 53 | 54 | # delete the file 55 | #---------------- 56 | catch {file delete $file} 57 | } 58 | } 59 | } 60 | 61 | set firstArg [lindex $argv 0] 62 | if [cequal $firstArg ""] { 63 | 64 | # no command line arguments, but make sure 65 | # current directory is cleaned up 66 | #----------------------------------------- 67 | set argv [list .] 68 | 69 | } elseif ![file isdirectory $firstArg] { 70 | 71 | # first command line argument is not a directory, 72 | # so prepend current directory onto argument list 73 | #------------------------------------------------ 74 | set argv [lreplace $argv 0 0 . $firstArg] 75 | } 76 | 77 | # save original "current working directory" 78 | #------------------------------------------ 79 | set origCWD [pwd] 80 | 81 | # loop through each command line argument 82 | #---------------------------------------- 83 | foreach arg $argv { 84 | 85 | if [file isdirectory [file join $origCWD $arg]] { 86 | # Command line argument is a directory, so 87 | # cd into it and delete files. 88 | #----------------------------------------- 89 | cd [file join $origCWD $arg] 90 | Clean 91 | } else { 92 | # Command line argument is a regular file, so just delete it 93 | #----------------------------------------------------------- 94 | if ![catch {eval glob $arg} files] { 95 | catch {eval file delete $files} 96 | } 97 | } 98 | 99 | } 100 | 101 | -------------------------------------------------------------------------------- /bin/install.tcl: -------------------------------------------------------------------------------- 1 | #---------------------------------------------------------------- 2 | # 3 | # NAME: install.tcl 4 | # 5 | # ABSTRACT: This Tcl script installs files into a target 6 | # directory. It only copies files which don't 7 | # exist or are older in the target directory. 8 | # 9 | # It was written so that a common command can be 10 | # executed to install TASH files regardless of 11 | # whether this is a Windows or Unix platform. 12 | # 13 | proc usage {} { 14 | puts stderr "usage: tclsh install.tcl \[-v\] \[-s\] \[-x exclude-regexp\]\ 15 | file... target-directory" 16 | puts stderr " -v : verify; don't install files" 17 | puts stderr " -s : silent" 18 | puts stderr " -x exclude-regexp : exclude files whose names match" 19 | puts stderr " this regular expression" 20 | puts stderr " file... : names of files or directories" 21 | puts stderr " to be installed" 22 | puts stderr " target-directory : directory in which to install" 23 | } 24 | # 25 | #---------------------------------------------------------------- 26 | 27 | proc copyFile {source target verify silent exclude} { 28 | if { [string compare $exclude ""] != 0 && [regexp $exclude $source] } { 29 | return 30 | } 31 | if [file isdirectory $source] { 32 | copyDir $source $target $verify $silent $exclude 33 | return 34 | } 35 | set sourceFile $source 36 | 37 | # build full target file name 38 | #---------------------------- 39 | if [file isdirectory $target] { 40 | set name [file tail $sourceFile] 41 | set targetFile [file join $target $name] 42 | } else { 43 | set targetFile $target 44 | } 45 | 46 | if [file exists $targetFile] { 47 | 48 | # file already exists, so check last modified time 49 | #------------------------------------------------- 50 | set sourceFileTime [file mtime $sourceFile] 51 | set targetFileTime [file mtime $targetFile] 52 | if {$sourceFileTime > $targetFileTime} { 53 | if $verify { 54 | puts stdout "need to update $targetFile" 55 | } else { 56 | if { ! $silent } { 57 | puts stdout "updating $targetFile" 58 | } 59 | if [catch {file copy -force $sourceFile $targetFile} error] { 60 | puts stderr " $error" 61 | } 62 | } 63 | } 64 | 65 | } else { 66 | 67 | # file doesn't exist, so copy it 68 | #------------------------------- 69 | if $verify { 70 | puts stdout "need to install $targetFile" 71 | } else { 72 | if { ! $silent } { 73 | puts stdout "installing $targetFile" 74 | } 75 | if [catch {file copy -force $sourceFile $targetFile} error] { 76 | puts stderr " $error" 77 | } 78 | } 79 | } 80 | } 81 | 82 | proc copyDir {sourceDir targetDir verify silent exclude} { 83 | if [regexp $exclude $sourceDir] { 84 | return 85 | } 86 | set sourceTail [file tail $sourceDir] 87 | set targetTail [file tail $targetDir] 88 | 89 | if {[string compare $sourceTail $targetTail] == 0} { 90 | if [file isdirectory $targetDir] { 91 | # target directory already exists and is a directory, 92 | # so just copy the files in $sourceDir 93 | #---------------------------------------------------- 94 | if { ! [catch {glob [file join $sourceDir *]} files] } { 95 | foreach file $files { 96 | copyFile $file $targetDir $verify $silent $exclude 97 | } 98 | } 99 | } elseif [file exists $targetDir] { 100 | # target is not a directory 101 | #-------------------------- 102 | puts stderr "$targetDir is not a directory" 103 | } else { 104 | # target directory does not exist, so create it 105 | #---------------------------------------------- 106 | if $verify { 107 | puts stdout "need to create $targetDir" 108 | } else { 109 | if { ! $silent } { 110 | puts stdout "creating $targetDir" 111 | } 112 | if [catch {file mkdir $targetDir} error] { 113 | puts stderr " $error" 114 | } else { 115 | copyDir $sourceDir $targetDir $verify $silent $exclude 116 | } 117 | } 118 | } 119 | } else { 120 | copyDir $sourceDir [file join $targetDir $sourceTail] $verify \ 121 | $silent $exclude 122 | } 123 | } 124 | 125 | 126 | # show usage if no arguments 127 | #--------------------------- 128 | if {[llength $argv] < 2} { 129 | usage 130 | exit 131 | } 132 | 133 | # get target directory and remove it from command line arguments 134 | #--------------------------------------------------------------- 135 | set target [lindex $argv end] 136 | set argv [lreplace $argv end end] 137 | 138 | # check for verify (-v) command line argument 139 | #-------------------------------------------- 140 | set pos [lsearch -exact $argv "-v"] 141 | if {$pos >= 0} { 142 | set verify 1 143 | set argv [lreplace $argv $pos $pos] 144 | } else { 145 | set verify 0 146 | } 147 | 148 | # check for silent (-s) command line argument 149 | #-------------------------------------------- 150 | set pos [lsearch -exact $argv "-s"] 151 | if {$pos >= 0} { 152 | set silent 1 153 | set argv [lreplace $argv $pos $pos] 154 | } else { 155 | set silent 0 156 | } 157 | 158 | # check for exclude-regexp (-x) command line argument 159 | #---------------------------------------------------- 160 | set pos [lsearch -exact $argv "-x"] 161 | if {$pos >= 0} { 162 | set excludepos [expr $pos + 1] 163 | set exclude [lindex $argv $excludepos] 164 | set argv [lreplace $argv $pos $excludepos] 165 | } else { 166 | set exclude "" 167 | } 168 | 169 | if $verify { 170 | puts stdout "Verify: $verify" 171 | puts stdout "Silent: $silent" 172 | puts stdout "Exclude: $exclude" 173 | puts stdout "Files: $argv" 174 | puts stdout "Target: $target" 175 | } 176 | 177 | # check if target directory really is a directory 178 | #------------------------------------------------ 179 | if { ! [file exists $target] } { 180 | file mkdir $target 181 | } elseif { ! [file isdirectory $target] } { 182 | puts stderr "Error: target directory, $target, is a file!" 183 | exit 184 | } 185 | 186 | 187 | # copy the files 188 | #--------------- 189 | foreach file [eval glob $argv] { 190 | copyFile $file $target $verify $silent $exclude 191 | } 192 | 193 | exit 194 | 195 | -------------------------------------------------------------------------------- /demos/.gitignore: -------------------------------------------------------------------------------- 1 | freq 2 | futurevalue 3 | hello_world 4 | tashell 5 | timer 6 | twashell 7 | watching 8 | wordify 9 | 10 | freq.unsorted 11 | freq.*.out 12 | words 13 | -------------------------------------------------------------------------------- /demos/Makefile: -------------------------------------------------------------------------------- 1 | # Copyright (C) 1997-2000 Terry J. Westley 2 | # Copyright (C) Simon Wright 3 | 4 | # This package is free software; you can redistribute it and/or 5 | # modify it under terms of the GNU General Public License as 6 | # published by the Free Software Foundation; either version 2, or 7 | # (at your option) any later version. This package is distributed in 8 | # the hope that it will be useful, but WITHOUT ANY WARRANTY; without 9 | # even the implied warranty of MERCHANTABILITY or FITNESS FOR A 10 | # PARTICULAR PURPOSE. See the GNU General Public License for more 11 | # details. You should have received a copy of the GNU General Public 12 | # License distributed with this package; see file COPYING. If not, 13 | # write to the Free Software Foundation, 59 Temple Place - Suite 14 | # 330, Boston, MA 02111-1307, USA. 15 | 16 | # This makefile builds and runs the demo programs. 17 | 18 | all:: 19 | alr build 20 | 21 | test:: 22 | ./timer 23 | 24 | test:: 25 | ./futurevalue 26 | 27 | test:: 28 | ./tashell testfreq.tcl ../src words 29 | 30 | test:: 31 | echo 1023 | ./watching watching.tcl 32 | -------------------------------------------------------------------------------- /demos/alire.toml: -------------------------------------------------------------------------------- 1 | description = "Tcl Ada Shell demos" 2 | name = "tash_demos" 3 | licenses = "GPL-2.0-or-later WITH GCC-exception-2.0" 4 | version = "8" 5 | 6 | authors = ["Simon Wright"] 7 | maintainers = ["Simon Wright "] 8 | maintainers-logins = ["simonjwright"] 9 | 10 | project-files = ["tash_demos.gpr"] 11 | executables = [ 12 | "freq", 13 | "futurevalue", 14 | "hello_world", 15 | "tashell", 16 | "timer", 17 | "twashell", 18 | "watching", 19 | "wordify" 20 | ] 21 | 22 | [[depends-on]] 23 | tash = "*" 24 | 25 | [[pins]] 26 | tash = { path='..' } 27 | -------------------------------------------------------------------------------- /demos/freq.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- freq.adb -- This program demonstrates how the TASH Ada/Tcl interface 4 | -- provides Tcl features for use in an Ada program. 5 | -- 6 | -- Copyright (c) 1995-1997 Terry J. Westley 7 | -- 8 | -- See the file "license.htm" for information on usage and 9 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 | -- 11 | -- This program reads lines from standard input and counts the number 12 | -- of occurrences of each unique line. Frequency counts are written 13 | -- to standard out. 14 | -- 15 | -------------------------------------------------------------------- 16 | 17 | with Ada.Text_IO; 18 | with CHelper; 19 | with Interfaces.C.Strings; 20 | with Tcl; 21 | with Tcl.Ada; 22 | 23 | procedure Freq is -- Frequency counter 24 | 25 | use Tcl; 26 | 27 | package C renames Interfaces.C; 28 | package Hash is new Tcl.Ada.Generic_Hash (Integer); 29 | use Hash; 30 | 31 | Line : C.Strings.chars_ptr := C.Strings.Null_Ptr; 32 | Freq_Count : Integer; 33 | Item : C.Strings.chars_ptr; 34 | Hash_Table : aliased Tcl_HashTable_Rec; 35 | Freq_Hash : constant Tcl_HashTable := Hash_Table'Unchecked_Access; 36 | Entry_Ptr : Tcl_HashEntry; 37 | Is_New_Entry : aliased C.int; 38 | Search_Rec : aliased Tcl_HashSearch_Rec; 39 | Search : constant Tcl_HashSearch := Search_Rec'Unchecked_Access; 40 | 41 | procedure Get_Line (Line : in out C.Strings.chars_ptr); 42 | procedure Get_Line (Line : in out C.Strings.chars_ptr) is 43 | -- This procedure gets a line from standard input and converts 44 | -- it to a "C" string. 45 | Input_Line : String (1 .. 1024); 46 | Length : Natural; 47 | begin -- Get_Line 48 | Ada.Text_IO.Get_Line (Input_Line, Length); 49 | C.Strings.Free (Line); 50 | Line := C.Strings.New_String (Input_Line (1 .. Length)); 51 | end Get_Line; 52 | 53 | use type Interfaces.C.int; 54 | 55 | begin -- Freq 56 | 57 | -- create a hash table for holding frequency counts 58 | Tcl_InitHashTable (Freq_Hash, TCL_STRING_KEYS); 59 | 60 | -- read lines from standard input until 61 | -- end of file encountered 62 | while not Ada.Text_IO.End_Of_File loop 63 | Get_Line (Line); 64 | -- create (or find, if already created) an entry for this line 65 | Entry_Ptr := Tcl_CreateHashEntry (Freq_Hash, Line, Is_New_Entry'Access); 66 | if Is_New_Entry = 1 then 67 | Freq_Count := 1; 68 | else 69 | -- get the frequency count from the hash 70 | Freq_Count := Tcl_GetHashValue (Entry_Ptr) + 1; 71 | end if; 72 | -- Store the updated frequency count in the table. 73 | -- WARNING: We take advantage of the fact that an integer is the 74 | -- same size as a C pointer and store the count in the table, 75 | -- rather than a pointer to it. 76 | Tcl_SetHashValue (Entry_Ptr, Freq_Count); 77 | end loop; 78 | 79 | -- iterate through every item and print it and its frequency count 80 | Entry_Ptr := Tcl_FirstHashEntry (Freq_Hash, Search); 81 | while Entry_Ptr /= null loop 82 | Freq_Count := Tcl_GetHashValue (Entry_Ptr); 83 | Item := Tcl_GetHashKey (Freq_Hash, Entry_Ptr); 84 | Ada.Text_IO.Put_Line 85 | (CHelper.Value (Item) & Integer'Image (Freq_Count)); 86 | Entry_Ptr := Tcl_NextHashEntry (Search); 87 | end loop; 88 | 89 | -- delete the frequency counter hash table 90 | Tcl_DeleteHashTable (Freq_Hash); 91 | 92 | end Freq; 93 | -------------------------------------------------------------------------------- /demos/freq.pl: -------------------------------------------------------------------------------- 1 | #-------------------------------------------------------------------- 2 | # 3 | # freq.pl -- 4 | # This program reads lines from standard input and counts the number 5 | # of occurrences of each unique line. Frequency counts are written 6 | # to standard out. This Perl version was written after both the 7 | # Tcl and Ada versions because I wanted to add another timing 8 | # benchmark. Since Perl is one of the faster scripting languages, 9 | # I thought it would be interesting to see how it does against 10 | # the Tcl bytecode compiler and Ada 11 | # 12 | # Copyright (c) 1998 Terry J. Westley 13 | # 14 | # See the file "license.htm" for information on usage and 15 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 16 | # 17 | #-------------------------------------------------------------------- 18 | 19 | # read lines from standard input until end of file encountered, 20 | # incrementing frequency count for each line 21 | #------------------------------------------------------------- 22 | while (<>) { 23 | chop; 24 | $Freq{$_}++; 25 | } 26 | 27 | # iterate through every item and print it and its frequency count 28 | #---------------------------------------------------------------- 29 | foreach $item (keys (%Freq)) { 30 | print "$item $Freq{$item}\n"; 31 | } 32 | -------------------------------------------------------------------------------- /demos/freq.tcl: -------------------------------------------------------------------------------- 1 | #-------------------------------------------------------------------- 2 | # 3 | # freq.tcl -- 4 | # This program reads lines from standard input and counts the number 5 | # of occurrences of each unique line. Frequency counts are written 6 | # to standard out. 7 | # 8 | # Copyright (c) 1995-1997 Terry J. Westley 9 | # 10 | # See the file "license.htm" for information on usage and 11 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 | # 13 | #-------------------------------------------------------------------- 14 | 15 | # read lines from standard input until 16 | # end of file encountered 17 | while {[gets stdin line] >= 0} { 18 | if [info exists Freq($line)] { 19 | # the item is already in the array, 20 | # so just increment its count 21 | incr Freq($line) 22 | } else { 23 | # the item is not in the array yet, 24 | # so initialize its count 25 | set Freq($line) 1 26 | } 27 | } 28 | 29 | # iterate through every item and print it 30 | # and its frequency count 31 | foreach item [array names Freq] { 32 | puts stdout "$item $Freq($item)" 33 | } 34 | -------------------------------------------------------------------------------- /demos/futurevalue.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------ 2 | -- 3 | -- futurevalue.adb -- 4 | -- This program demonstrates how the TASH Ada/Tk interface 5 | -- provides Tk features for use in an Ada program. 6 | -- 7 | -- It implements a simple GUI for computing Future Value 8 | -- of a series of fixed monthly investments. 9 | -- 10 | -- Copyright (c) 1997 Terry J. Westley 11 | -- Copyright (c) 2017-2022 Simon Wright 12 | -- 13 | -- See the file "license.htm" for information on usage and 14 | -- redistribution of this file, and a DISCLAIMER OF ALL WARRANTIES. 15 | -- 16 | ------------------------------------------------ 17 | 18 | with CArgv; 19 | with Interfaces.C; 20 | with Tcl.Tk; 21 | 22 | with FutureValue_App; 23 | 24 | procedure FutureValue is 25 | Argc : Interfaces.C.int; 26 | Argv : CArgv.Chars_Ptr_Ptr; 27 | begin 28 | -- Get command-line arguments and put them into C-style "argv," 29 | -- as required by Tcl_Main. 30 | CArgv.Create (Argc, Argv); 31 | 32 | -- Start Tcl/Tk (and never return!) 33 | Tcl.Tk.Tk_Main (Argc, Argv, FutureValue_App.Init'Access); 34 | end FutureValue; 35 | -------------------------------------------------------------------------------- /demos/futurevalue.tcl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #\ 3 | exec wish $0 $@ 4 | 5 | #------------------------------------------------ 6 | # 7 | # futurevalue.tcl -- 8 | # This program the use of Tcl/Tk to implement a simple GUI for 9 | # computing Future Value of a series of fixed monthly investments. 10 | # 11 | # Copyright (c) 1997 Terry J. Westley 12 | # 13 | # See the file "license.htm" for information on usage and 14 | # redistribution of this file, and a DISCLAIMER OF ALL WARRANTIES. 15 | # 16 | #------------------------------------------------ 17 | 18 | proc computeFutureValue {} { 19 | set msa [.msa.entry get] 20 | if {$msa == "" || $msa < 0} return 21 | 22 | set int [.int.entry get] 23 | if {$int == "" || $int < 0} return 24 | 25 | set yrs [.yrs.entry get] 26 | if {$yrs == "" || $yrs < 0} return 27 | 28 | set mint [expr ($int) / 1200.0] 29 | set mos [expr ($yrs) * 12] 30 | set fv [format "%7.2f" [expr ($msa) * (pow(1+$mint,$mos) - 1)/$mint]] 31 | .fv.result configure -text $fv 32 | } 33 | 34 | wm title . "Future Value of Savings" 35 | 36 | set form [list \ 37 | [list msa "Monthly Savings Amount:" 100] \ 38 | [list int "Annual Interest Rate:" 8] \ 39 | [list yrs "Number of Years:" 30]] 40 | 41 | # Create and initialize three widgets for: 42 | # Monthly Savings Amount, 43 | # Annual Interest Rate, and 44 | # Number of Years. 45 | #---------------------------------------- 46 | foreach field $form { 47 | set name [lindex $field 0] 48 | set label [lindex $field 1] 49 | set value [lindex $field 2] 50 | frame .$name -bd 2 51 | pack .$name -side top -fill x 52 | entry .$name.entry -width 20 -bg white 53 | pack .$name.entry -side right 54 | label .$name.label -text $label 55 | pack .$name.label -side right 56 | .$name.entry insert end $value 57 | } 58 | 59 | focus .msa.entry 60 | 61 | frame .fv -bd 2 62 | pack .fv -side top -fill x 63 | label .fv.result -width 20 -relief sunken 64 | pack .fv.result -side right 65 | button .fv.button -text "Compute Future Value:" \ 66 | -command computeFutureValue -pady 1 67 | pack .fv.button -side right 68 | 69 | bind .fv.button {computeFutureValue} 70 | 71 | -------------------------------------------------------------------------------- /demos/futurevalue_app.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------ 2 | -- 3 | -- futurevalue_app.adb -- 4 | -- This program demonstrates how the TASH Ada/Tk interface 5 | -- provides Tk features for use in an Ada program. 6 | -- 7 | -- It implements a simple GUI for computing Future Value 8 | -- of a series of fixed monthly investments. 9 | -- 10 | -- Copyright (c) 2017-2022 Simon Wright 11 | -- Copyright (c) 1997 Terry J. Westley 12 | -- 13 | -- See the file "license.htm" for information on usage and 14 | -- redistribution of this file, and a DISCLAIMER OF ALL WARRANTIES. 15 | -- 16 | ------------------------------------------------ 17 | 18 | with CArgv; 19 | with Tcl.Ada; 20 | with Tcl.Tk; 21 | with Tcl.Tk.Ada; 22 | 23 | package body FutureValue_App is 24 | 25 | -- use a decimal type for ease in formatting for display 26 | type Money is delta 0.01 digits 14; 27 | 28 | Frame : Tcl.Tk.Ada.Frame; 29 | Label : Tcl.Tk.Ada.Label; 30 | Button : Tcl.Tk.Ada.Button; 31 | Amt_Entry : Tcl.Tk.Ada.EntryWidget; 32 | Rate_Entry : Tcl.Tk.Ada.EntryWidget; 33 | Yrs_Entry : Tcl.Tk.Ada.EntryWidget; 34 | Result : Tcl.Tk.Ada.Label; 35 | 36 | function Compute_Future_Value_Command 37 | (ClientData : Integer; 38 | Interp : Tcl.Tcl_Interp; 39 | Argc : Interfaces.C.int; 40 | Argv : CArgv.Chars_Ptr_Ptr) 41 | return Interfaces.C.int; 42 | pragma Convention (C, Compute_Future_Value_Command); 43 | 44 | -- Declare a procedure, suitable for creating a Tcl command, 45 | -- which will compute the Future Value. 46 | ------------------------------------------------------------- 47 | function Compute_Future_Value_Command 48 | (ClientData : Integer; 49 | Interp : Tcl.Tcl_Interp; 50 | Argc : Interfaces.C.int; 51 | Argv : CArgv.Chars_Ptr_Ptr) 52 | return Interfaces.C.int 53 | is 54 | pragma Unreferenced (ClientData, Argc, Argv); 55 | Amount : Money; 56 | Future_Value : Money; 57 | Annual_Rate : Float; 58 | Rate : Float; 59 | Years : Integer; 60 | Months : Integer; 61 | 62 | begin -- Compute_Future_Value_Command 63 | 64 | -- get the monthly investment amount from its text entry field, 65 | -- evaluate it in case it is an expression, 66 | -- and make sure it is not less than zero 67 | ---------------------------------------------------------------- 68 | Amount := 69 | Money (Tcl.Ada.Tcl_ExprDouble (Interp, Tcl.Tk.Ada.get (Amt_Entry))); 70 | if Amount < 0.0 then 71 | return Tcl.TCL_OK; 72 | end if; 73 | 74 | -- get the annual interest rate from its text entry field 75 | -- evaluate it in case it is an expression, 76 | -- and make sure it is not less than zero 77 | ---------------------------------------------------------- 78 | Annual_Rate := 79 | Float (Tcl.Ada.Tcl_ExprDouble (Interp, Tcl.Tk.Ada.get (Rate_Entry))); 80 | if Annual_Rate < 0.0 then 81 | return Tcl.TCL_OK; 82 | end if; 83 | 84 | -- get the number of years from its text entry field 85 | -- evaluate it in case it is an expression, 86 | -- and make sure it is not less than zero 87 | ----------------------------------------------------- 88 | Years := 89 | Integer (Tcl.Ada.Tcl_ExprLong (Interp, Tcl.Tk.Ada.get (Yrs_Entry))); 90 | if Years < 0 then 91 | return Tcl.TCL_OK; 92 | end if; 93 | 94 | -- compute the monthly interest rate 95 | ------------------------------------- 96 | Rate := Annual_Rate / 1200.0; 97 | 98 | -- compute the number of months 99 | ------------------------------- 100 | Months := Years * 12; 101 | 102 | -- compute future value with the formula: 103 | -- n 104 | -- (1 + i) - 1 105 | -- Future Value = (M) * -------------- 106 | -- i 107 | -- 108 | -- where M = Monthly savings 109 | -- i = interest per month 110 | -- n = number of months 111 | ------------------------------------------ 112 | Future_Value := 113 | Money (Float (Amount) * ((1.0 + Rate) ** Months - 1.0) / Rate); 114 | 115 | -- put the future value into the result label 116 | ---------------------------------------------- 117 | Tcl.Tk.Ada.configure (Result, "-text " & Money'Image (Future_Value)); 118 | 119 | -- return TCL_OK to keep Tcl happy 120 | ----------------------------------- 121 | return Tcl.TCL_OK; 122 | 123 | exception 124 | when others => 125 | return Tcl.TCL_OK; 126 | 127 | end Compute_Future_Value_Command; 128 | 129 | function Init (Interp : Tcl.Tcl_Interp) return Interfaces.C.int is 130 | package CreateCommands is new Tcl.Ada.Generic_Command (Integer); 131 | Command : Tcl.Tcl_Command; 132 | pragma Unreferenced (Command); 133 | use type Interfaces.C.int; 134 | begin 135 | 136 | Tcl.Tk.Ada.Set_Trace (False); 137 | 138 | -- Initialize Tcl 139 | if Tcl.Tcl_Init (Interp) = Tcl.TCL_ERROR then 140 | return Tcl.TCL_ERROR; 141 | end if; 142 | 143 | -- Initialize Tk 144 | if Tcl.Tk.Tk_Init (Interp) = Tcl.TCL_ERROR then 145 | return Tcl.TCL_ERROR; 146 | end if; 147 | 148 | -- Create a new Tcl command to compute future value. 149 | Command := 150 | CreateCommands.Tcl_CreateCommand 151 | (Interp, 152 | "computeFutureValue", 153 | Compute_Future_Value_Command'Access, 154 | 0, 155 | null); 156 | 157 | -- Set the Tk context so that we may use shortcut Tk calls that 158 | -- do not require reference to the interpreter. 159 | Tcl.Tk.Ada.Set_Context (Interp); 160 | 161 | -- Create a frame, label and entry field for savings amount 162 | Tcl.Tk.Ada.Create (Frame, ".amt", "-bd 2"); 163 | Tcl.Tk.Ada.Pack (Frame, "-side top -fill x"); 164 | Tcl.Tk.Ada.Create (Amt_Entry, ".amt.entry", "-width 20 -bg white"); 165 | Tcl.Tk.Ada.Pack (Amt_Entry, "-side right"); 166 | Tcl.Tk.Ada.Create 167 | (Label, 168 | ".amt.label", 169 | "-text ""Monthly Savings Amount:"""); 170 | Tcl.Tk.Ada.Pack (Label, "-side right"); 171 | 172 | -- Initialize savings amount 173 | Tcl.Ada.Tcl_Eval (Interp, ".amt.entry insert end 100"); 174 | 175 | -- Create a frame, label and entry field for interest rate 176 | Tcl.Tk.Ada.Create (Frame, ".rate", "-bd 2"); 177 | Tcl.Tk.Ada.Pack (Frame, "-side top -fill x"); 178 | Tcl.Tk.Ada.Create (Rate_Entry, ".rate.entry", "-width 20 -bg white"); 179 | Tcl.Tk.Ada.Pack (Rate_Entry, "-side right"); 180 | Tcl.Tk.Ada.Create 181 | (Label, 182 | ".rate.label", 183 | "-text ""Annual Interest Rate:"""); 184 | Tcl.Tk.Ada.Pack (Label, "-side right"); 185 | 186 | -- Initialize interest rate 187 | Tcl.Ada.Tcl_Eval (Interp, ".rate.entry insert end 8"); 188 | 189 | -- Create a frame, label and entry field for number of years 190 | Tcl.Tk.Ada.Create (Frame, ".yrs", "-bd 2"); 191 | Tcl.Tk.Ada.Pack (Frame, "-side top -fill x"); 192 | Tcl.Tk.Ada.Create (Yrs_Entry, ".yrs.entry", "-width 20 -bg white"); 193 | Tcl.Tk.Ada.Pack (Yrs_Entry, "-side right"); 194 | Tcl.Tk.Ada.Create (Label, ".yrs.label", "-text ""Number of Years:"""); 195 | Tcl.Tk.Ada.Pack (Label, "-side right"); 196 | 197 | -- Initialize savings amount 198 | Tcl.Ada.Tcl_Eval (Interp, ".yrs.entry insert end 30"); 199 | 200 | -- Create a frame, button, and result label for computed result 201 | Tcl.Tk.Ada.Create (Frame, ".fv", "-bd 2"); 202 | Tcl.Tk.Ada.Pack (Frame, "-side top -fill x"); 203 | Tcl.Tk.Ada.Create (Result, ".fv.result", "-width 20 -relief sunken"); 204 | Tcl.Tk.Ada.Pack (Result, "-side right"); 205 | Tcl.Tk.Ada.Create 206 | (Button, 207 | ".fv.button", 208 | "-text ""Compute Future Value:""" 209 | & " -command computeFutureValue -pady 1"); 210 | Tcl.Tk.Ada.Pack (Button, "-side right"); 211 | 212 | -- Add a window title 213 | Tcl.Ada.Tcl_Eval (Interp, "wm title . ""Future Value of Savings"""); 214 | 215 | -- Set focus to the first entry field 216 | Tcl.Ada.Tcl_Eval (Interp, "focus .amt.entry"); 217 | 218 | -- bind Return to the button 219 | Tcl.Tk.Ada.Bind (Button, "", "computeFutureValue"); 220 | 221 | return Tcl.TCL_OK; 222 | 223 | end Init; 224 | 225 | end FutureValue_App; 226 | -------------------------------------------------------------------------------- /demos/futurevalue_app.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------ 2 | -- 3 | -- futurevalue_app.ads -- 4 | -- This program demonstrates how the TASH Ada/Tk interface 5 | -- provides Tk features for use in an Ada program. 6 | -- 7 | -- It implements a simple GUI for computing Future Value 8 | -- of a series of fixed monthly investments. 9 | -- 10 | -- Copyright (c) 2017-2022 Simon Wright 11 | -- 12 | -- See the file "license.htm" for information on usage and 13 | -- redistribution of this file, and a DISCLAIMER OF ALL WARRANTIES. 14 | -- 15 | ------------------------------------------------ 16 | 17 | with Interfaces.C; 18 | with Tcl; 19 | 20 | package FutureValue_App is 21 | 22 | function Init (Interp : Tcl.Tcl_Interp) return Interfaces.C.int; 23 | pragma Convention (C, Init); 24 | 25 | end FutureValue_App; 26 | -------------------------------------------------------------------------------- /demos/hello_world.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Hello_World body 4 | -- 5 | -- File Name: hello_world.adb 6 | -- 7 | -- Purpose: This procedure is a dummy main unit which withs 8 | -- all the packages to be included in the TASH 9 | -- library so that gnatmake can build all units. 10 | -- 11 | -- It also serves as a quick test that everything 12 | -- compiled OK. 13 | -- 14 | -- Copyright (c) 1999-2000 Terry J. Westley 15 | -- 16 | -- Tash is free software; you can redistribute it and/or modify it under 17 | -- terms of the GNU General Public License as published by the Free 18 | -- Software Foundation; either version 2, or (at your option) any later 19 | -- version. Tash is distributed in the hope that it will be useful, but 20 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 21 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 22 | -- for more details. You should have received a copy of the GNU General 23 | -- Public License distributed with Tash; see file COPYING. If not, write to 24 | -- 25 | -- Software Foundation 26 | -- 59 Temple Place - Suite 330 27 | -- Boston, MA 02111-1307, USA 28 | -- 29 | -- As a special exception, if other files instantiate generics from this 30 | -- unit, or you link this unit with other files to produce an executable, 31 | -- this unit does not by itself cause the resulting executable to be 32 | -- covered by the GNU General Public License. This exception does not 33 | -- however invalidate any other reasons why the executable file might be 34 | -- covered by the GNU Public License. 35 | -- 36 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 37 | -- 38 | -------------------------------------------------------------------- 39 | 40 | with Ada.Text_IO; 41 | with CArgv; 42 | with Interfaces.C; 43 | with Tcl.Ada; 44 | with Tcl.Tk.Ada; 45 | 46 | procedure Hello_World is -- Hello_World 47 | 48 | use type Interfaces.C.int; 49 | 50 | package CreateCommands is new Tcl.Ada.Generic_Command (Integer); 51 | 52 | Argc : Interfaces.C.int; 53 | Argv : CArgv.Chars_Ptr_Ptr; 54 | Interp : Tcl.Tcl_Interp; 55 | Hello_Button : Tcl.Tk.Ada.Button; 56 | Exit_Button : Tcl.Tk.Ada.Button; 57 | Command : Tcl.Tcl_Command; 58 | pragma Unreferenced (Command); 59 | 60 | function Hello_Command 61 | (ClientData : Integer; 62 | Interp : Tcl.Tcl_Interp; 63 | Argc : Interfaces.C.int; 64 | Argv : CArgv.Chars_Ptr_Ptr) 65 | return Interfaces.C.int; 66 | pragma Convention (C, Hello_Command); 67 | -- Declare a procedure, suitable for creating a Tcl command, 68 | -- which will print "Hello World" when the "Hello World" 69 | -- button is pressed. 70 | 71 | function Hello_Command 72 | (ClientData : Integer; 73 | Interp : Tcl.Tcl_Interp; 74 | Argc : Interfaces.C.int; 75 | Argv : CArgv.Chars_Ptr_Ptr) 76 | return Interfaces.C.int 77 | is 78 | pragma Unreferenced (ClientData, Interp, Argc, Argv); 79 | begin -- Hello_Command 80 | Ada.Text_IO.Put_Line ("Hello: Welcome to my TASH world!"); 81 | return Tcl.TCL_OK; 82 | end Hello_Command; 83 | 84 | function Exit_Command 85 | (ClientData : Integer; 86 | Interp : Tcl.Tcl_Interp; 87 | Argc : Interfaces.C.int; 88 | Argv : CArgv.Chars_Ptr_Ptr) 89 | return Interfaces.C.int; 90 | pragma Convention (C, Exit_Command); 91 | -- Declare a procedure, suitable for creating a Tcl command, 92 | -- which will terminate the program when pressed. 93 | 94 | function Exit_Command 95 | (ClientData : Integer; 96 | Interp : Tcl.Tcl_Interp; 97 | Argc : Interfaces.C.int; 98 | Argv : CArgv.Chars_Ptr_Ptr) 99 | return Interfaces.C.int 100 | is 101 | pragma Unreferenced (ClientData, Argc, Argv); 102 | Result : Interfaces.C.int; 103 | pragma Unreferenced (Result); 104 | begin -- Exit_Command 105 | Result := Tcl.Ada.Tcl_Eval (Interp, "destroy ."); 106 | return Tcl.Ada.Tcl_Eval (Interp, "exit"); 107 | end Exit_Command; 108 | 109 | begin -- Hello_World 110 | 111 | -- Get command-line arguments and put them into C-style "argv" 112 | -------------------------------------------------------------- 113 | CArgv.Create (Argc, Argv); 114 | 115 | -- Tcl needs to know the path name of the executable 116 | -- otherwise Tcl.Tcl_Init below will fail. 117 | ---------------------------------------------------- 118 | Tcl.Tcl_FindExecutable (Argv.all); 119 | 120 | -- Create one Tcl interpreter 121 | ----------------------------- 122 | Interp := Tcl.Tcl_CreateInterp; 123 | 124 | -- Initialize Tcl 125 | ----------------- 126 | if Tcl.Tcl_Init (Interp) = Tcl.TCL_ERROR then 127 | Ada.Text_IO.Put_Line 128 | ("Hello_World: Tcl.Tcl_Init failed: " & 129 | Tcl.Ada.Tcl_GetStringResult (Interp)); 130 | return; 131 | end if; 132 | 133 | -- Initialize Tk 134 | ---------------- 135 | if Tcl.Tk.Tk_Init (Interp) = Tcl.TCL_ERROR then 136 | Ada.Text_IO.Put_Line ("Cannot run GUI version of hello_world: "); 137 | Ada.Text_IO.Put_Line (" " & Tcl.Ada.Tcl_GetStringResult (Interp)); 138 | Ada.Text_IO.Put_Line ("Hello: Welcome to my TASH world!"); 139 | return; 140 | end if; 141 | 142 | -- Set the Tk context so that we may use shortcut Tk 143 | -- calls that require reference to the interpreter. 144 | ---------------------------------------------------- 145 | Tcl.Tk.Ada.Set_Context (Interp); 146 | 147 | -- Create several new Tcl commands to call Ada subprograms 148 | ---------------------------------------------------------- 149 | Command := 150 | CreateCommands.Tcl_CreateCommand 151 | (Interp, 152 | "Hello", 153 | Hello_Command'Access, 154 | 0, 155 | null); 156 | Command := 157 | CreateCommands.Tcl_CreateCommand 158 | (Interp, 159 | "Exit", 160 | Exit_Command'Access, 161 | 0, 162 | null); 163 | 164 | -- Create and pack the Hello button 165 | ----------------------------------- 166 | Hello_Button := Tcl.Tk.Ada.Create (".hello", "-text Hello -command Hello"); 167 | Tcl.Tk.Ada.Pack (Hello_Button, "-side left -fill both -expand yes"); 168 | 169 | -- Create and pack the Exit button 170 | ---------------------------------- 171 | Exit_Button := Tcl.Tk.Ada.Create (".exit", "-text Exit -command Exit"); 172 | Tcl.Tk.Ada.Pack (Exit_Button, "-side left -fill both -expand yes"); 173 | 174 | -- Loop inside Tk, waiting for commands to execute. 175 | -- When there are no windows left, Tcl.Tk.Tk_MainLoop returns and we exit. 176 | -------------------------------------------------------------------------- 177 | Tcl.Tk.Tk_MainLoop; 178 | 179 | end Hello_World; 180 | -------------------------------------------------------------------------------- /demos/tash_demos.gpr: -------------------------------------------------------------------------------- 1 | -- Copyright (C) Simon Wright 2 | 3 | -- This package is free software; you can redistribute it and/or 4 | -- modify it under terms of the GNU General Public License as 5 | -- published by the Free Software Foundation; either version 2, or 6 | -- (at your option) any later version. This package is distributed in 7 | -- the hope that it will be useful, but WITHOUT ANY WARRANTY; without 8 | -- even the implied warranty of MERCHANTABILITY or FITNESS FOR A 9 | -- PARTICULAR PURPOSE. See the GNU General Public License for more 10 | -- details. You should have received a copy of the GNU General Public 11 | -- License distributed with this package; see file COPYING. If not, 12 | -- write to the Free Software Foundation, 59 Temple Place - Suite 13 | -- 330, Boston, MA 02111-1307, USA. 14 | 15 | -- This file provides the compilation options for building the Tash 16 | -- demos. 17 | 18 | with "../tash"; 19 | 20 | project Tash_Demos is 21 | 22 | for Main use 23 | ( 24 | "freq.adb", 25 | "futurevalue.adb", 26 | "hello_world.adb", 27 | "tashell.adb", 28 | "timer.adb", 29 | "twashell.adb", 30 | "watching.adb", 31 | "wordify.adb" 32 | ); 33 | 34 | for Exec_Dir use "."; 35 | 36 | -- The source locations for the project. 37 | for Source_Dirs use ("."); 38 | 39 | -- Each Project that contains source must have its own build 40 | -- directory. 41 | for Object_Dir use ".build"; 42 | 43 | for Create_Missing_Dirs use "true"; 44 | 45 | -- GCC configuration options. 46 | package Compiler renames Tash.Compiler; 47 | 48 | -- GNATBIND configuration options. 49 | package Binder is 50 | for Default_Switches ("ada") use ("-E"); 51 | end Binder; 52 | 53 | package Linker renames Tash.Linker; 54 | 55 | end Tash_Demos; 56 | -------------------------------------------------------------------------------- /demos/tashapp.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- tashapp.adb -- 4 | -- 5 | -- Copyright (c) 1995-1997 Terry J. Westley 6 | -- 7 | -- See the file "license.htm" for information on usage and 8 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9 | -- 10 | -------------------------------------------------------------------- 11 | 12 | with Tcl.Ada; 13 | 14 | package body TashApp is 15 | 16 | use type C.int; 17 | 18 | function Init (Interp : in Tcl.Tcl_Interp) return C.int is 19 | begin -- Init 20 | 21 | if Tcl.Tcl_Init (Interp) = Tcl.TCL_ERROR then 22 | return Tcl.TCL_ERROR; 23 | end if; 24 | 25 | -- Call the init procedures for included packages. Each call should 26 | -- look like this: 27 | -- 28 | -- if Mod.Init(interp) = Tcl.TCL_ERROR then 29 | -- return Tcl.TCL_ERROR; 30 | -- end if; 31 | -- 32 | -- where "Mod" is the name of the module. 33 | 34 | -- Call CreateCommand for application-specific commands, if 35 | -- they weren't already created by the init procedures called above. 36 | 37 | -- Specify a user-specific startup file to invoke if the application 38 | -- is run interactively. Typically the startup file is "~/.apprc" 39 | -- where "app" is the name of the application. If this line is deleted 40 | -- then no user-specific startup file will be run under any conditions. 41 | 42 | declare 43 | Result : constant String := 44 | Tcl.Ada.Tcl_SetVar 45 | (Interp, 46 | "tcl_rcFileName", 47 | "~/.tashrc", 48 | Tcl.TCL_GLOBAL_ONLY); 49 | pragma Unreferenced (Result); -- but wanted! 50 | begin 51 | return Tcl.TCL_OK; 52 | end; 53 | 54 | end Init; 55 | 56 | end TashApp; 57 | -------------------------------------------------------------------------------- /demos/tashapp.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- tashapp.ads -- This package provides the Init function required 4 | -- in the call to Tcl_Main. 5 | -- 6 | -- Copyright (c) 1995-1997 Terry J. Westley 7 | -- 8 | -- See the file "license.htm" for information on usage and 9 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 | -- 11 | -- Note, this function is in a separate library package to satisfy 12 | -- accessibility levels in refering to Init'access in call to Tcl_Init. 13 | -- 14 | -------------------------------------------------------------------- 15 | 16 | with Interfaces.C; 17 | with Tcl; 18 | 19 | package TashApp is 20 | 21 | package C renames Interfaces.C; 22 | 23 | function Init (Interp : in Tcl.Tcl_Interp) return C.int; 24 | pragma Convention (C, Init); 25 | 26 | end TashApp; 27 | -------------------------------------------------------------------------------- /demos/tashell.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Tashell.adb -- Tcl Ada SHell. This program is the Ada version of the 4 | -- tclsh program included in the Tcl distribution. 5 | -- 6 | -- Copyright (c) 1995-1997 Terry J. Westley 7 | -- 8 | -- See the file "license.htm" for information on usage and 9 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 | -- 11 | -------------------------------------------------------------------- 12 | 13 | with CArgv; 14 | with TashApp; 15 | with Tcl; use Tcl; 16 | 17 | procedure Tashell is -- Tcl Ada SHell 18 | 19 | -- Argc and Argv include the command name 20 | Argc : C.int; 21 | Argv : CArgv.Chars_Ptr_Ptr; 22 | 23 | begin -- Tashell 24 | 25 | -- Get command-line arguments and put them into C-style "argv", 26 | -- as required by Tcl_Main. 27 | CArgv.Create (Argc, Argv); 28 | 29 | -- Start Tcl (and never return!) 30 | Tcl_Main (Argc, Argv, TashApp.Init'Access); 31 | 32 | end Tashell; 33 | -------------------------------------------------------------------------------- /demos/testfreq.tcl: -------------------------------------------------------------------------------- 1 | #------------------------------------------------ 2 | # 3 | # testfreq.tcl -- 4 | # This is a Tcl script which tests the freq program. 5 | # 6 | #------------------------------------------------ 7 | 8 | proc cequal {left right} { 9 | return [expr [string compare $left $right] == 0] 10 | } 11 | 12 | proc lempty {string} { 13 | return [expr [string length $string] == 0] 14 | } 15 | 16 | # Get command line arguments 17 | #--------------------------- 18 | set source_dir [lindex $argv 0] 19 | set words [lindex $argv 1] 20 | set supports_tash [lindex $argv 2] 21 | set head [lindex $argv 3] 22 | 23 | set pwd [pwd] 24 | set wordify [file join $pwd wordify] 25 | set input_file [file join $source_dir tcl.ads] 26 | set tashell [file join $pwd tashell] 27 | set freq [file join $pwd freq] 28 | set freq2 [file join $pwd freq2] 29 | set compare [file join $pwd .. tests compare] 30 | 31 | puts stdout "Testing freq" 32 | 33 | # Delete output files 34 | #-------------------- 35 | puts stdout " Deleting output files..." 36 | file delete $words freq.tcl.out freq.ada.out freq.perl.out freq2.ada.out 37 | 38 | # Prepare file of words 39 | #---------------------- 40 | puts stdout " Preparing file of words..." 41 | if [lempty $head] { 42 | exec $wordify < $input_file > $words 43 | } else { 44 | # catch PROGRAM_ERROR from wordify 45 | catch {exec $wordify < $input_file | head -$head > $words} 46 | } 47 | 48 | # Execute Tcl script version 49 | #--------------------------- 50 | puts stdout " Executing Tcl script version..." 51 | set tcl_time [time "exec $tashell freq.tcl < $words > freq.unsorted" 1] 52 | exec sort freq.unsorted > freq.tcl.out 53 | 54 | # Execute Ada version 55 | #-------------------- 56 | puts stdout " Executing Ada version..." 57 | set ada_time [time "exec $freq < $words > freq.unsorted" 1] 58 | exec sort freq.unsorted > freq.ada.out 59 | 60 | # Execute Ada version 2 61 | #---------------------- 62 | if {$supports_tash == yes} { 63 | puts stdout " Executing Ada version 2..." 64 | set ada_time2 [time "exec $freq2 < $words > freq2.unsorted" 1] 65 | exec sort freq.unsorted > freq2.ada.out 66 | } 67 | 68 | # Execute Perl version 69 | #--------------------- 70 | puts stdout " Executing Perl version..." 71 | if [catch { 72 | set perl_time [time "exec perl freq.pl < $words > freq.unsorted" 1] 73 | exec sort freq.unsorted > freq.perl.out 74 | } error] { 75 | puts stdout " $error" 76 | set perl_time 0 77 | } 78 | 79 | # Compare outputs of all versions 80 | #-------------------------------- 81 | puts stdout " Comparing outputs..." 82 | catch {exec $compare freq.tcl.out freq.ada.out} diff 83 | if {$supports_tash == yes} { 84 | catch {exec $compare freq.tcl.out freq2.ada.out} diff2 85 | } else { 86 | set diff2 "" 87 | } 88 | catch {exec $compare freq.tcl.out freq.perl.out} perldiff 89 | if {[lempty $diff] && [lempty $diff2] && [lempty $perldiff]} { 90 | puts stdout "Freq test PASSED" 91 | } else { 92 | if { ! [lempty $diff] } { 93 | puts stdout "Ada Freq test FAILED: $diff" 94 | } 95 | if { ! [lempty $diff2] } { 96 | puts stdout "Ada Freq 2 test FAILED: $diff2" 97 | } 98 | if { ! [lempty $perldiff] } { 99 | puts stdout "Perl Freq test FAILED: $perldiff" 100 | } 101 | } 102 | 103 | # Display timing results 104 | #----------------------- 105 | set tcl_time [expr [lindex $tcl_time 0] / 1000000.0] 106 | puts stdout [format " Elapsed time for executing Tcl version: \ 107 | %6.2f seconds" $tcl_time] 108 | 109 | set ada_time [expr [lindex $ada_time 0] / 1000000.0] 110 | puts stdout [format " Elapsed time for executing Ada version: \ 111 | %6.2f seconds" $ada_time] 112 | 113 | if {$supports_tash == yes} { 114 | set ada_time2 [expr [lindex $ada_time2 0] / 1000000.0] 115 | puts stdout [format " Elapsed time for executing Ada version 2: \ 116 | %6.2f seconds" $ada_time2] 117 | } 118 | 119 | set perl_time [expr [lindex $perl_time 0] / 1000000.0] 120 | puts stdout [format " Elapsed time for executing Perl version: \ 121 | %6.2f seconds" $perl_time] 122 | -------------------------------------------------------------------------------- /demos/timer.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------ 2 | -- 3 | -- timer.adb -- This program demonstrates how the TASH Ada/Tk interface 4 | -- provides Tk features for use in an Ada program. 5 | -- 6 | -- Copyright (c) 2017-2022 Simon Wright 7 | -- Copyright (c) 1996-1999 Terry J. Westley 8 | -- 9 | -- See the file "license.htm" for information on usage and 10 | -- redistribution of this file, and a DISCLAIMER OF ALL WARRANTIES. 11 | -- 12 | -- This program was adapted from the demo program distributed with Tk. 13 | -- It provides a simple stop watch timer facility. 14 | -- 15 | ------------------------------------------------ 16 | 17 | with CArgv; 18 | with Interfaces.C; 19 | with Tcl.Tk; 20 | 21 | with Timer_App; 22 | 23 | procedure Timer is 24 | Argc : Interfaces.C.int; 25 | Argv : CArgv.Chars_Ptr_Ptr; 26 | begin 27 | -- Get command-line arguments and put them into C-style "argv," 28 | -- as required by Tcl_Main. 29 | CArgv.Create (Argc, Argv); 30 | 31 | -- Start Tcl/Tk (and never return!) 32 | Tcl.Tk.Tk_Main (Argc, Argv, Timer_App.Init'Access); 33 | end Timer; 34 | -------------------------------------------------------------------------------- /demos/timer.tcl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #\ 3 | exec wish $0 $@ 4 | 5 | #------------------------------------------------ 6 | # 7 | # timer.tcl -- 8 | # This script provides a simple stop watch timer facility. 9 | # It was adapted from the demo program distributed with Tk. 10 | # 11 | # Execute it in any of several ways: 12 | # 1) wish -f timer.tcl 13 | # 2) twash timer.tcl 14 | # 3) ./timer.tcl 15 | # 16 | # Copyright (c) 1996-1997 Terry J. Westley 17 | # 18 | # See the file "license.htm" for information on usage and 19 | # redistribution of this file, and a DISCLAIMER OF ALL WARRANTIES. 20 | # 21 | #------------------------------------------------ 22 | 23 | proc Update {} { 24 | global seconds hundredths 25 | .counter config -text [format "%d.%02d" $seconds $hundredths] 26 | } 27 | 28 | proc tick {} { 29 | global seconds hundredths stopped 30 | if $stopped return 31 | after 50 tick 32 | set hundredths [expr $hundredths+5] 33 | if {$hundredths >= 100} { 34 | set hundredths 0 35 | set seconds [expr $seconds+1] 36 | } 37 | Update 38 | } 39 | 40 | proc Start {} { 41 | global stopped 42 | if $stopped { 43 | set stopped 0 44 | .stop config -text Stop -command Stop 45 | tick 46 | } 47 | } 48 | 49 | proc Reset {} { 50 | global seconds hundredths stopped 51 | set seconds 0 52 | set hundredths 0 53 | set stopped 1 54 | Update 55 | } 56 | 57 | proc Stop {} { 58 | global stopped 59 | set stopped 1 60 | .stop config -text Reset -command Reset 61 | } 62 | 63 | label .counter -text 0.00 -relief raised -width 10 64 | pack .counter -side bottom -fill both 65 | 66 | button .start -text Start -command Start 67 | pack .start -side left -fill both -expand yes 68 | 69 | button .stop -text Reset -command Reset 70 | pack .stop -side left -fill both -expand yes 71 | 72 | bind . {destroy .;exit} 73 | bind . {destroy .;exit} 74 | 75 | Reset 76 | 77 | focus . 78 | -------------------------------------------------------------------------------- /demos/timer_app.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------ 2 | -- 3 | -- timer_app.adb -- This program demonstrates how the TASH Ada/Tk interface 4 | -- provides Tk features for use in an Ada program. 5 | -- 6 | -- Copyright (c) 2017-2022 Simon Wright 7 | -- Copyright (c) 1997 Terry J. Westley 8 | -- 9 | -- See the file "license.htm" for information on usage and 10 | -- redistribution of this file, and a DISCLAIMER OF ALL WARRANTIES. 11 | -- 12 | -- This program was adapted from the demo program distributed with Tk. 13 | -- It provides a simple stop watch timer facility. 14 | -- 15 | ------------------------------------------------ 16 | 17 | -- This package provides the Init function required for the demo 18 | -- program Timer. 19 | 20 | with CArgv; 21 | with Tcl.Ada; 22 | with Tcl.Tk; 23 | with Tcl.Tk.Ada; 24 | 25 | package body Timer_App is 26 | 27 | use Tcl; 28 | 29 | type Timer_Type is delta 0.01 digits 8 range 0.0 .. 999999.99; 30 | 31 | Counter : Tcl.Tk.Ada.Label; 32 | Start_Button : Tcl.Tk.Ada.Button; 33 | Stop_Button : Tcl.Tk.Ada.Button; 34 | Time_Value : Timer_Type := 0.0; 35 | Stopped : Boolean := True; 36 | 37 | -- Update the window by displaying the current value of the timer. 38 | ------------------------------------------------------------------- 39 | procedure Update; 40 | procedure Update is 41 | begin -- Update 42 | Tcl.Tk.Ada.configure 43 | (Counter, 44 | "-text " & Timer_Type'Image (Time_Value)); 45 | end Update; 46 | 47 | -- Increment the timer by one "tick." A tick is 50 milliseconds 48 | -- (or 5 hundredths of a second). 49 | ----------------------------------------------------------------- 50 | procedure Tick; 51 | procedure Tick is 52 | begin -- Tick 53 | 54 | -- if the timer is stopped, do not increment 55 | -- its value or reschedule tick for future execution. 56 | ------------------------------------------------------ 57 | if Stopped then 58 | return; 59 | end if; 60 | 61 | -- Schedule tick to be called again in 50 milliseconds. 62 | -------------------------------------------------------- 63 | Tcl.Tk.Ada.After (50, "tick"); 64 | 65 | -- Increment the timer value 66 | ------------------------------ 67 | Time_Value := Time_Value + 0.05; 68 | 69 | -- Update the timer display. 70 | ---------------------------- 71 | Update; 72 | 73 | end Tick; 74 | 75 | function Tick_Command 76 | (ClientData : Integer; 77 | Interp : Tcl.Tcl_Interp; 78 | Argc : Interfaces.C.int; 79 | Argv : CArgv.Chars_Ptr_Ptr) 80 | return Interfaces.C.int; 81 | pragma Convention (C, Tick_Command); 82 | 83 | -- Declare a procedure, suitable for creating a Tcl command, 84 | -- which will increment the timer. 85 | ------------------------------------------------------------- 86 | function Tick_Command 87 | (ClientData : Integer; 88 | Interp : Tcl.Tcl_Interp; 89 | Argc : Interfaces.C.int; 90 | Argv : CArgv.Chars_Ptr_Ptr) 91 | return Interfaces.C.int 92 | is 93 | pragma Unreferenced (ClientData, Interp, Argc, Argv); 94 | begin -- Tick_Command 95 | Tick; 96 | return Tcl.TCL_OK; 97 | end Tick_Command; 98 | 99 | function Start_Command 100 | (ClientData : Integer; 101 | Interp : Tcl.Tcl_Interp; 102 | Argc : Interfaces.C.int; 103 | Argv : CArgv.Chars_Ptr_Ptr) 104 | return Interfaces.C.int; 105 | pragma Convention (C, Start_Command); 106 | 107 | -- Declare a procedure, suitable for creating a Tcl command, 108 | -- which will start the timer if it is currently stopped. Also, 109 | -- change the Stop button (currently labeled "Reset") to display "Stop." 110 | ------------------------------------------------------------------------- 111 | function Start_Command 112 | (ClientData : Integer; 113 | Interp : Tcl.Tcl_Interp; 114 | Argc : Interfaces.C.int; 115 | Argv : CArgv.Chars_Ptr_Ptr) 116 | return Interfaces.C.int 117 | is 118 | pragma Unreferenced (ClientData, Interp, Argc, Argv); 119 | begin -- Start_Command 120 | if Stopped then 121 | Stopped := False; 122 | Tcl.Tk.Ada.configure (Stop_Button, "-text Stop -command Stop"); 123 | Tick; 124 | Tcl.Tk.Ada.Set_Trace (False); 125 | end if; 126 | return Tcl.TCL_OK; 127 | end Start_Command; 128 | 129 | function Stop_Command 130 | (ClientData : Integer; 131 | Interp : Tcl.Tcl_Interp; 132 | Argc : Interfaces.C.int; 133 | Argv : CArgv.Chars_Ptr_Ptr) 134 | return Interfaces.C.int; 135 | pragma Convention (C, Stop_Command); 136 | 137 | -- Declare a procedure, suitable for creating a Tcl command, 138 | -- which will stop incrementing the timer. Also, relabel the 139 | -- Stop button to be a Reset button. 140 | -------------------------------------------------------------- 141 | function Stop_Command 142 | (ClientData : Integer; 143 | Interp : Tcl.Tcl_Interp; 144 | Argc : Interfaces.C.int; 145 | Argv : CArgv.Chars_Ptr_Ptr) 146 | return Interfaces.C.int 147 | is 148 | pragma Unreferenced (ClientData, Interp, Argc, Argv); 149 | begin -- Stop_Command 150 | Tcl.Tk.Ada.Set_Trace (True); 151 | Stopped := True; 152 | Tcl.Tk.Ada.configure (Stop_Button, "-text Reset -command Reset"); 153 | return Tcl.TCL_OK; 154 | end Stop_Command; 155 | 156 | -- Reset the timer's value to 0.0 and update the display. 157 | ---------------------------------------------------------- 158 | procedure Reset; 159 | procedure Reset is 160 | begin -- Reset 161 | Time_Value := 0.0; 162 | Stopped := True; 163 | Update; 164 | end Reset; 165 | 166 | function Reset_Command 167 | (ClientData : Integer; 168 | Interp : Tcl.Tcl_Interp; 169 | Argc : Interfaces.C.int; 170 | Argv : CArgv.Chars_Ptr_Ptr) 171 | return Interfaces.C.int; 172 | pragma Convention (C, Reset_Command); 173 | 174 | -- Declare a procedure, suitable for creating a Tcl command, 175 | -- which will reset the timer to 0.0 and update the display. 176 | ------------------------------------------------------------- 177 | function Reset_Command 178 | (ClientData : Integer; 179 | Interp : Tcl.Tcl_Interp; 180 | Argc : Interfaces.C.int; 181 | Argv : CArgv.Chars_Ptr_Ptr) 182 | return Interfaces.C.int 183 | is 184 | pragma Unreferenced (ClientData, Interp, Argc, Argv); 185 | begin -- Reset_Command 186 | Reset; 187 | return Tcl.TCL_OK; 188 | end Reset_Command; 189 | 190 | function Init (Interp : Tcl.Tcl_Interp) 191 | return Interfaces.C.int 192 | is 193 | package CreateCommands is new Tcl.Ada.Generic_Command (Integer); 194 | Command : Tcl.Tcl_Command; 195 | pragma Unreferenced (Command); 196 | use type Interfaces.C.int; 197 | begin 198 | Tcl.Tk.Ada.Set_Trace (True); 199 | 200 | -- Initialize Tcl 201 | if Tcl.Tcl_Init (Interp) = Tcl.TCL_ERROR then 202 | return Tcl.TCL_ERROR; 203 | end if; 204 | 205 | -- Initialize Tk 206 | if Tcl.Tk.Tk_Init (Interp) = Tcl.TCL_ERROR then 207 | return Tcl.TCL_ERROR; 208 | end if; 209 | 210 | -- Create several new Tcl commands to call Ada subprograms. 211 | Command := 212 | CreateCommands.Tcl_CreateCommand 213 | (Interp, 214 | "tick", 215 | Tick_Command'Access, 216 | 0, 217 | null); 218 | Command := 219 | CreateCommands.Tcl_CreateCommand 220 | (Interp, 221 | "Start", 222 | Start_Command'Access, 223 | 0, 224 | null); 225 | Command := 226 | CreateCommands.Tcl_CreateCommand 227 | (Interp, 228 | "Stop", 229 | Stop_Command'Access, 230 | 0, 231 | null); 232 | Command := 233 | CreateCommands.Tcl_CreateCommand 234 | (Interp, 235 | "Reset", 236 | Reset_Command'Access, 237 | 0, 238 | null); 239 | 240 | -- Set the Tk context so that we may use shortcut Tk calls 241 | -- that require reference to the interpreter. 242 | Tcl.Tk.Ada.Set_Context (Interp); 243 | 244 | -- Create and pack the counter text widget 245 | Counter := 246 | Tcl.Tk.Ada.Create (".counter", "-text 0.00 -relief raised -width 10"); 247 | Tcl.Tk.Ada.Pack (Counter, "-side bottom -fill both"); 248 | 249 | -- Create and pack the Start button 250 | Start_Button := Tcl.Tk.Ada.Create (".start", 251 | "-text Start -command Start"); 252 | Tcl.Tk.Ada.Pack (Start_Button, "-side left -fill both -expand yes"); 253 | 254 | -- Create and pack the Stop button 255 | ----------------------------------- 256 | Stop_Button := Tcl.Tk.Ada.Create (".stop", "-text Reset -command Reset"); 257 | Tcl.Tk.Ada.Pack (Stop_Button, "-side left -fill both -expand yes"); 258 | 259 | -- Bind ^C and ^Q keys to exit 260 | ------------------------------- 261 | Tcl.Tk.Ada.Bind_To_Main_Window (Interp, 262 | "", 263 | "{destroy .;exit}"); 264 | Tcl.Tk.Ada.Bind_To_Main_Window (Interp, 265 | "", 266 | "{destroy .;exit}"); 267 | 268 | -- Reset timer value to 0.0 269 | ---------------------------- 270 | Reset; 271 | 272 | return Tcl.TCL_OK; 273 | 274 | end Init; 275 | 276 | end Timer_App; 277 | -------------------------------------------------------------------------------- /demos/timer_app.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------ 2 | -- 3 | -- timer_app.ads -- This program demonstrates how the TASH Ada/Tk interface 4 | -- provides Tk features for use in an Ada program. 5 | -- 6 | -- Copyright (c) 2017-2022 Simon Wright 7 | -- 8 | -- See the file "license.htm" for information on usage and 9 | -- redistribution of this file, and a DISCLAIMER OF ALL WARRANTIES. 10 | -- 11 | -- This program was adapted from the demo program distributed with Tk. 12 | -- It provides a simple stop watch timer facility. 13 | -- 14 | ------------------------------------------------ 15 | 16 | with Interfaces.C; 17 | with Tcl; 18 | 19 | package Timer_App is 20 | 21 | function Init (Interp : Tcl.Tcl_Interp) return Interfaces.C.int; 22 | pragma Convention (C, Init); 23 | 24 | end Timer_App; 25 | -------------------------------------------------------------------------------- /demos/twashapp.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- twashapp.adb -- 4 | -- 5 | -- Copyright (c) 1995-1997 Terry J. Westley 6 | -- 7 | -- See the file "license.htm" for information on usage and 8 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9 | -- 10 | -------------------------------------------------------------------- 11 | 12 | with Tcl.Ada; 13 | with Tcl.Tk; 14 | 15 | package body TWashApp is 16 | 17 | use type C.int; 18 | 19 | function Init (Interp : Tcl.Tcl_Interp) return C.int is 20 | begin -- Init 21 | 22 | if Tcl.Tcl_Init (Interp) = Tcl.TCL_ERROR then 23 | return Tcl.TCL_ERROR; 24 | end if; 25 | 26 | if Tcl.Tk.Tk_Init (Interp) = Tcl.TCL_ERROR then 27 | return Tcl.TCL_ERROR; 28 | end if; 29 | 30 | -- Call the init procedures for included packages. Each call should 31 | -- look like this: 32 | -- 33 | -- if Mod.Init(interp) = Tcl.TCL_ERROR then 34 | -- return Tcl.TCL_ERROR; 35 | -- end if; 36 | -- 37 | -- where "Mod" is the name of the module. 38 | 39 | -- Call CreateCommand for application-specific commands, if 40 | -- they weren't already created by the init procedures called above. 41 | 42 | -- Specify a user-specific startup file to invoke if the application 43 | -- is run interactively. Typically the startup file is "~/.apprc" 44 | -- where "app" is the name of the application. If this line is deleted 45 | -- then no user-specific startup file will be run under any conditions. 46 | 47 | declare 48 | Result : constant String := 49 | Tcl.Ada.Tcl_SetVar 50 | (Interp, 51 | "tcl_rcFileName", 52 | "~/.twashrc", 53 | Tcl.TCL_GLOBAL_ONLY); 54 | pragma Unreferenced (Result); -- but needed! 55 | begin 56 | return Tcl.TCL_OK; 57 | end; 58 | 59 | end Init; 60 | 61 | end TWashApp; 62 | -------------------------------------------------------------------------------- /demos/twashapp.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- twashapp.ads -- This package provides the Init function required 4 | -- in the call to Tk_Main. 5 | -- 6 | -- Copyright (c) 1995-1997 Terry J. Westley 7 | -- 8 | -- See the file "license.htm" for information on usage and 9 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 | -- 11 | -------------------------------------------------------------------- 12 | 13 | with Interfaces.C; 14 | with Tcl; 15 | 16 | package TWashApp is 17 | 18 | package C renames Interfaces.C; 19 | 20 | function Init (Interp : Tcl.Tcl_Interp) return C.int; 21 | pragma Convention (C, Init); 22 | 23 | end TWashApp; 24 | -------------------------------------------------------------------------------- /demos/twashell.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- twashell.adb -- Tcl Windowing Ada SHell. This program is the Ada version 4 | -- of the wish program included in the Tk distribution. 5 | -- 6 | -- Copyright (c) 1995-1997 Terry J. Westley 7 | -- 8 | -- See the file "license.htm" for information on usage and 9 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 | -- 11 | -- 12 | -------------------------------------------------------------------- 13 | 14 | with CArgv; 15 | with Interfaces.C; 16 | with Tcl.Tk; 17 | with Tcl; 18 | with TWashApp; 19 | 20 | procedure TWASHell is -- Tcl Windowing Ada SHell 21 | 22 | package C renames Interfaces.C; 23 | 24 | -- Argc and Argv include the command name 25 | Argc : C.int; 26 | Argv : CArgv.Chars_Ptr_Ptr; 27 | 28 | begin -- TWASHell 29 | 30 | -- Get command-line arguments and put them into C-style "argv," 31 | -- as required by Tk_Main. 32 | CArgv.Create (Argc, Argv); 33 | 34 | -- Start Tcl 35 | Tcl.Tk.Tk_Main (Argc, Argv, TWashApp.Init'Access); 36 | 37 | end TWASHell; 38 | -------------------------------------------------------------------------------- /demos/watching.adb: -------------------------------------------------------------------------------- 1 | -- Copyright 2017-2022 Simon Wright 2 | -- 3 | -- This unit is free software; you can redistribute it and/or modify 4 | -- it as you wish. This unit is distributed in the hope that it will 5 | -- be useful, but WITHOUT ANY WARRANTY; without even the implied 6 | -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 7 | 8 | -- This program (with watching.tcl) demonstrates the use of 9 | -- Tcl_SetVar[2]() to get an Ada-domain value back into the Tcl 10 | -- domain without the use of polling. 11 | 12 | with CArgv; 13 | with Interfaces.C; 14 | with Tcl; 15 | 16 | with Watching_Support; 17 | 18 | procedure Watching is 19 | 20 | -- Argc and Argv include the command name 21 | Argc : Interfaces.C.int; 22 | Argv : CArgv.Chars_Ptr_Ptr; 23 | 24 | begin 25 | 26 | -- Get command-line arguments and put them into C-style "argv", 27 | -- as required by Tcl_Main. 28 | CArgv.Create (Argc, Argv); 29 | 30 | -- Start Tcl (and never return!) 31 | Tcl.Tcl_Main (Argc, Argv, Watching_Support.Init'Unrestricted_Access); 32 | 33 | end Watching; 34 | -------------------------------------------------------------------------------- /demos/watching.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/tcl 2 | 3 | # Created 2014 by Simon Wright from 4 | # http://www.wellho.net/forum/The-Tcl-programming-language/Tracing-a-variable-in-Tcl.html 5 | # 6 | # This unit is free software; you can redistribute it and/or modify it 7 | # as you wish. This unit is distributed in the hope that it will be 8 | # useful, but WITHOUT ANY WARRANTY; without even the implied warranty 9 | # of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | # 11 | # This program (with watching.adb) demonstrates the use of 12 | # Tcl_SetVar[2]() to get an Ada-domain value back into the Tcl 13 | # domain without the use of polling. 14 | 15 | proc watch {varname key op} { 16 | if {$key != ""} { 17 | set varname ${varname}($key) 18 | } 19 | upvar $varname var 20 | puts "$varname is $var (operation $op)" 21 | } 22 | 23 | trace variable tellback w watch 24 | trace variable value w watch 25 | 26 | puts -nonewline "Give me a big number: " 27 | flush stdout 28 | 29 | gets stdin value 30 | 31 | while {$value > 100} { 32 | set value [expr $value / 2 - 2] 33 | puts "square $value returns [square $value]" 34 | } 35 | 36 | puts "final value is $value" 37 | -------------------------------------------------------------------------------- /demos/watching_support.adb: -------------------------------------------------------------------------------- 1 | -- Copyright 2017-2022 Simon Wright 2 | -- 3 | -- This unit is free software; you can redistribute it and/or modify 4 | -- it as you wish. This unit is distributed in the hope that it will 5 | -- be useful, but WITHOUT ANY WARRANTY; without even the implied 6 | -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 7 | 8 | -- This program (with watching.tcl) demonstrates the use of 9 | -- Tcl_SetVar[2]() to get an Ada-domain value back into the Tcl 10 | -- domain without the use of polling. 11 | 12 | with CArgv; 13 | with Interfaces.C.Strings; 14 | with Tcl.Ada; 15 | with Tcl.Async; 16 | 17 | package body Watching_Support is 18 | 19 | -- Handy wrapper for C.Strings.Free, so it can be used to free 20 | -- results. 21 | procedure Freeproc (BlockPtr : Interfaces.C.Strings.chars_ptr); 22 | pragma Convention (C, Freeproc); 23 | 24 | function Square 25 | (Client_Data : Integer; 26 | Interp : Tcl.Tcl_Interp; 27 | Argc : Interfaces.C.int; 28 | Argv : CArgv.Chars_Ptr_Ptr) return Interfaces.C.int; 29 | pragma Convention (C, Square); 30 | 31 | function Init (Interp : Tcl.Tcl_Interp) return Interfaces.C.int is 32 | 33 | package CreateCommands is new Tcl.Ada.Generic_Command (Integer); 34 | Command : Tcl.Tcl_Command; 35 | pragma Unreferenced (Command); 36 | 37 | use type Interfaces.C.int; 38 | 39 | begin 40 | 41 | if Tcl.Tcl_Init (Interp) = Tcl.TCL_ERROR then 42 | return Tcl.TCL_ERROR; 43 | end if; 44 | 45 | Tcl.Async.Register (Interp); 46 | 47 | Command := CreateCommands.Tcl_CreateCommand 48 | (Interp, 49 | "square", 50 | Square'Unrestricted_Access, 51 | 0, 52 | null); 53 | 54 | return Tcl.TCL_OK; 55 | 56 | end Init; 57 | 58 | procedure Freeproc (BlockPtr : Interfaces.C.Strings.chars_ptr) 59 | is 60 | Tmp : Interfaces.C.Strings.chars_ptr := BlockPtr; 61 | begin 62 | Interfaces.C.Strings.Free (Tmp); 63 | end Freeproc; 64 | 65 | function Square 66 | (Client_Data : Integer; 67 | Interp : Tcl.Tcl_Interp; 68 | Argc : Interfaces.C.int; 69 | Argv : CArgv.Chars_Ptr_Ptr) return Interfaces.C.int 70 | is 71 | pragma Unreferenced (Client_Data); 72 | Input : Integer; 73 | Squared : Integer; 74 | use type Interfaces.C.int; 75 | begin 76 | pragma Assert (Argc = 2, "'square' requires one integer argument"); 77 | 78 | Input := Integer'Value 79 | (Interfaces.C.Strings.Value 80 | (CArgv.Argv_Pointer.Value (Argv) (1))); 81 | Squared := Input * Input; 82 | 83 | Tcl.Tcl_SetResult 84 | (Interp, 85 | Interfaces.C.Strings.New_String (Integer'Image (Squared)), 86 | Freeproc'Unrestricted_Access); 87 | 88 | Tcl.Async.Set (Tcl_Array => "tellback", 89 | Index => "42", 90 | Value => Integer'Image (Squared)); 91 | 92 | return Tcl.TCL_OK; 93 | end Square; 94 | 95 | end Watching_Support; 96 | -------------------------------------------------------------------------------- /demos/watching_support.ads: -------------------------------------------------------------------------------- 1 | -- Copyright 2017-2022 Simon Wright 2 | -- 3 | -- This unit is free software; you can redistribute it and/or modify 4 | -- it as you wish. This unit is distributed in the hope that it will 5 | -- be useful, but WITHOUT ANY WARRANTY; without even the implied 6 | -- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 7 | 8 | -- This program (with watching.tcl) demonstrates the use of 9 | -- Tcl_SetVar[2]() to get an Ada-domain value back into the Tcl 10 | -- domain without the use of polling. 11 | 12 | with Interfaces.C; 13 | with Tcl; 14 | 15 | package Watching_Support is 16 | 17 | function Init (Interp : Tcl.Tcl_Interp) return Interfaces.C.int; 18 | pragma Convention (C, Init); 19 | 20 | end Watching_Support; 21 | -------------------------------------------------------------------------------- /demos/wordify.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- wordify.adb -- This program copies standard input to standard output, 4 | -- removing punctuation and writing one word per output line. 5 | -- A word is considered to be a sequence of letters, numbers, 6 | -- and (sorta like Ada identifiers) underscores. 7 | -- 8 | -- Copyright (c) 1998 Terry J. Westley 9 | -- Copyright (c) 2006-2022 Simon Wright 10 | -- 11 | -- See the file "license.htm" for information on usage and 12 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 | -- 14 | -------------------------------------------------------------------- 15 | 16 | with Ada.Characters.Handling; use Ada.Characters.Handling; 17 | with Ada.Text_IO; 18 | 19 | procedure Wordify is 20 | 21 | Line : String (1 .. 1024); 22 | Length : Natural; 23 | At_End_Of_Line : Boolean := True; 24 | 25 | begin -- Wordify 26 | 27 | while not Ada.Text_IO.End_Of_File loop 28 | Ada.Text_IO.Get_Line (Line, Length); 29 | for I in 1 .. Length loop 30 | if Is_Alphanumeric (Line (I)) or else Line (I) = '_' then 31 | Ada.Text_IO.Put (Line (I)); 32 | At_End_Of_Line := False; 33 | elsif not At_End_Of_Line then 34 | Ada.Text_IO.New_Line; 35 | At_End_Of_Line := True; 36 | end if; 37 | end loop; 38 | end loop; 39 | 40 | end Wordify; 41 | -------------------------------------------------------------------------------- /docs/README.htm: -------------------------------------------------------------------------------- 1 | 4 | 5 | 6 | 7 | 8 | 10 | 11 | TASH Documentation Index 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 105 | 106 | 107 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 176 | 182 | 183 | 184 |

 

TCL 23 | ADA 24 | SHELL 25 |

 

Documentation Index

37 |
38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 91 | 92 | 93 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 |
TASH
Home
Introduction to TASH
Download Now
TASH Software License
Release Notes
Documentation Index
Install and Build
Mailing List
Tcl/Tk
Scriptics Home
74 | Scriptics’ Intro to Tcl/Tk
Tcl/Tk Consortium
Books
Ada
Ada Home
90 | FAQ at Ada Home
94 | Tutorial at Ada Home
ACM SIGAda
Books
103 |
104 | 		  108 | 109 | 110 | 111 | 112 |
113 | 114 | 115 | 116 |

TASH: Tcl Ada SHell, An Ada/Tcl Binding

117 | 118 |

A binding to Tcl from Ada is described. The goal 119 | of this binding is to make scripting language features, such as 120 | associative arrays, regular expression matching, and execution 121 | of OS commands available to an Ada programmer and to allow a Tcl 122 | programmer to use Ada in place of C where needed. This binding 123 | exploits several new features of Ada 95 that make interfacing 124 | to C much cleaner and more direct than Ada 83.

125 | 126 |

This paper is available in HTML 127 | and MS Word 7.0 formats.

128 | 129 |

TASH: A Free Platform-Independent 130 | Graphical User Interface Development Toolkit for Ada

131 | 132 |

A platform-independent Application Programming Interface 133 | (API) for developing Graphical User Interfaces (GUI) is described. 134 | This API includes a complete "thin" binding to Tcl 135 | and an experimental "thick" binding to Tk from Ada 136 | 95. Several features of Ada 95 such as access to subprograms, 137 | tagged types, and interface to C were used in this binding.

138 | 139 |

This paper is available in HTML 140 | and MS Word 7.0 formats.

141 | 142 |

TASH: An Alternative to the Windows API

143 | 144 |

I gave this presentation at Tri-Ada '97 in the Developing 145 | Solutions in Windows 95 / NT with Ada tuturial. It describes how 146 | an Ada programmer can use TASH to perform GUI development with Ada 147 | in Windows 95/NT. 148 | 149 |

This presentation is available in 150 | MS PowerPoint 4.0 format. 151 | 152 | 153 | 154 |

155 | 156 | 		 
  Author   E-Mail Address Last Revised  
  Terry J. Westley   175 | twestley@buffalo.veridian.com  
185 | 186 | 187 | 188 | -------------------------------------------------------------------------------- /docs/intro.doc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/docs/intro.doc -------------------------------------------------------------------------------- /docs/intro.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/docs/intro.pdf -------------------------------------------------------------------------------- /docs/pigui.doc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/docs/pigui.doc -------------------------------------------------------------------------------- /docs/pigui.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/docs/pigui.pdf -------------------------------------------------------------------------------- /docs/sigada00.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/docs/sigada00.pdf -------------------------------------------------------------------------------- /docs/sigada00.ppt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/docs/sigada00.ppt -------------------------------------------------------------------------------- /docs/triada97.ppt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/docs/triada97.ppt -------------------------------------------------------------------------------- /images/Fig01.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/images/Fig01.gif -------------------------------------------------------------------------------- /images/Fig09.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/images/Fig09.gif -------------------------------------------------------------------------------- /images/Fig21.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/images/Fig21.gif -------------------------------------------------------------------------------- /images/tri.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simonjwright/tcladashell/4c588c12752a81819b9e0cf186ffb765d86637c0/images/tri.gif -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # Copyright (C) Simon Wright 2 | 3 | # This package is free software; you can redistribute it and/or 4 | # modify it under terms of the GNU General Public License as 5 | # published by the Free Software Foundation; either version 2, or 6 | # (at your option) any later version. This package is distributed in 7 | # the hope that it will be useful, but WITHOUT ANY WARRANTY; without 8 | # even the implied warranty of MERCHANTABILITY or FITNESS FOR A 9 | # PARTICULAR PURPOSE. See the GNU General Public License for more 10 | # details. You should have received a copy of the GNU General Public 11 | # License distributed with this package; see file COPYING. If not, 12 | # write to the Free Software Foundation, 59 Temple Place - Suite 13 | # 330, Boston, MA 02111-1307, USA. 14 | 15 | # Builds tcl_record_sizes.ads. 16 | 17 | # Naming the executable tcl_record_sizes.exe means we don't need to 18 | # worry whether we're running on Windows. 19 | 20 | TCLSH = tclsh 21 | ifeq (, $(shell command -v $(TCLSH) 2>/dev/null)) 22 | TCLSH = tclsh8.6 23 | endif 24 | 25 | all:: tcl_record_sizes.ads 26 | 27 | tcl_record_sizes.ads: tcl_record_sizes.exe 28 | ./$< >$@ 29 | 30 | tcl_record_sizes.exe: tcl_record_sizes.c 31 | gprbuild -P tcl_record_sizes.gpr -o $@ 32 | 33 | tcl_record_sizes.c: tcl_record_sizes.tcl 34 | $(TCLSH) $< >$@ 35 | -------------------------------------------------------------------------------- /src/cargv-test.adb: -------------------------------------------------------------------------------- 1 | -- $Id$ 2 | 3 | with Ada.Exceptions; 4 | with Ada.Text_IO; use Ada.Text_IO; 5 | 6 | procedure CArgv.Test is 7 | Argv : Chars_Ptr_Ptr 8 | := Empty & "this" & "is" & "four" & "arguments"; 9 | begin 10 | for I in 0 .. 4 loop 11 | Put_Line (I'Img & " " & Arg (Argv, CNatural (I))); 12 | end loop; 13 | exception 14 | when E : others => 15 | Put_Line (Ada.Exceptions.Exception_Information (E)); 16 | end CArgv.Test; 17 | -------------------------------------------------------------------------------- /src/cargv.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- cargv.adb -- 4 | -- 5 | -- Copyright (c) 1995-2000 Terry J. Westley 6 | -- 7 | -- See the file "license.htm" for information on usage and 8 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9 | -- 10 | -- 01-Sep-97 TJW Fixed dangling pointer problem independently 11 | -- discovered by me and Brett Kettering (thanks, Brett!). 12 | -- 13 | -- 24-Mar-98 TJW Again, Brett found one of my bugs, this time, in 14 | -- the "&" function. 15 | -- 16 | -- 8.x.08 sjw Implemented Arg; tidied. 17 | -- 18 | -------------------------------------------------------------------- 19 | 20 | with Ada.Command_Line; 21 | with Ada.Text_IO; 22 | 23 | package body CArgv is 24 | 25 | -- To make operators visible: 26 | use type CNatural; 27 | use type C.Strings.chars_ptr; 28 | 29 | type Vector_Access is access Vector; 30 | 31 | Empty_Vector : Vector := (0 => C.Strings.Null_Ptr); 32 | 33 | procedure Create (Argc : out CNatural; Argv : out Chars_Ptr_Ptr) is 34 | Size : constant CNatural 35 | := CNatural (Ada.Command_Line.Argument_Count + 1); 36 | Vec : Vector_Access := new Vector (0 .. Size); 37 | begin -- Create 38 | Vec (0) := C.Strings.New_String (Ada.Command_Line.Command_Name); 39 | for i in 1 .. Size - 1 loop 40 | Vec (i) := 41 | C.Strings.New_String (Ada.Command_Line.Argument (Integer (i))); 42 | end loop; 43 | Vec (Size) := C.Strings.Null_Ptr; 44 | Argc := Size; 45 | Argv := Vec (Vec'First)'Access; 46 | end Create; 47 | 48 | procedure Show (Argc : CNatural; Argv : Chars_Ptr_Ptr) is 49 | Ptr : Chars_Ptr_Ptr := Argv; 50 | use Ada.Text_IO; 51 | begin -- Show 52 | Put_Line ("Argc :" & CNatural'Image (Argc)); 53 | for i in 0 .. Argc - 1 loop 54 | Put (CNatural'Image (i) & " : "); 55 | if Ptr.all = C.Strings.Null_Ptr then 56 | Put_Line (""); 57 | else 58 | Put_Line (C.Strings.Value (Ptr.all)); 59 | end if; 60 | Argv_Pointer.Increment (Ptr); 61 | end loop; 62 | end Show; 63 | 64 | procedure Free (Argv : in out Chars_Ptr_Ptr) is 65 | pragma Warnings (Off, Argv); -- logically in out 66 | Ptr : Chars_Ptr_Ptr := Argv; 67 | begin -- Free 68 | while Ptr.all /= C.Strings.Null_Ptr loop 69 | C.Strings.Free (Ptr.all); 70 | Argv_Pointer.Increment (Ptr); 71 | end loop; 72 | -- This is only a partial free because the argv array 73 | -- itself is not freed. 74 | -- Free_Vector (Argv); 75 | end Free; 76 | 77 | function Arg (Argv : Chars_Ptr_Ptr; N : CNatural) return String is 78 | L : constant CNatural := CNatural (Argv_Pointer.Virtual_Length (Argv)); 79 | begin -- Arg 80 | if N >= L then 81 | raise Constraint_Error; 82 | end if; 83 | return C.Strings.Value (Argv_Pointer.Value (Argv) (N)); 84 | end Arg; 85 | 86 | function Empty return Chars_Ptr_Ptr is 87 | begin -- Empty 88 | return Empty_Vector (Empty_Vector'First)'Access; 89 | end Empty; 90 | 91 | function "&" (Argv : Chars_Ptr_Ptr; Arg : String) return Chars_Ptr_Ptr is 92 | Size : constant CNatural := 93 | CNatural (Argv_Pointer.Virtual_Length (Argv)) + 1; 94 | Vec : Vector_Access := new Vector (0 .. Size); 95 | begin -- "&" 96 | 97 | -- Copy the existing argv. Note that Vec(Size-1) should be 98 | -- the location of its null pointer. 99 | Vec (0 .. Size - 1) := Argv_Pointer.Value (Argv); 100 | 101 | -- Create the new string and put its pointer where the 102 | -- null pointer of the argv was. 103 | Vec (Size - 1) := C.Strings.New_String (Arg); 104 | 105 | -- Insert null pointer for the new argv 106 | Vec (Size) := C.Strings.Null_Ptr; 107 | 108 | return Vec (Vec'First)'Access; 109 | 110 | end "&"; 111 | 112 | function Argc (Argv : Chars_Ptr_Ptr) return CNatural is 113 | begin -- Argc 114 | return CNatural (Argv_Pointer.Virtual_Length (Argv)); 115 | end Argc; 116 | 117 | end CArgv; 118 | -------------------------------------------------------------------------------- /src/cargv.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- cargv.ads -- Create C-style "argv" vectors from strings and 4 | -- Ada.Command_Line. 5 | -- 6 | -- Copyright (c) 1995-2000 Terry J. Westley 7 | -- 8 | -- See the file "license.htm" for information on usage and 9 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 | -- 11 | -- This package provides the data type Chars_Ptr_Ptr which corresponds 12 | -- to the char** of C and subprograms for creating and manipulating 13 | -- arrays of C strings. 14 | -- 15 | -------------------------------------------------------------------- 16 | 17 | with Interfaces.C.Pointers; 18 | with Interfaces.C.Strings; 19 | 20 | package CArgv is 21 | 22 | package C renames Interfaces.C; 23 | 24 | subtype CNatural is C.int range 0 .. C.int'Last; 25 | 26 | type Vector is array (CNatural range <>) of aliased C.Strings.chars_ptr; 27 | -- This is a C-style "argv" vector. 28 | 29 | package Argv_Pointer 30 | is new C.Pointers (Index => CNatural, 31 | Element => C.Strings.chars_ptr, 32 | Element_Array => Vector, 33 | Default_Terminator => C.Strings.Null_Ptr); 34 | 35 | subtype Chars_Ptr_Ptr is Argv_Pointer.Pointer; 36 | -- This is C char ** 37 | 38 | --------------------------------------------------------------------- 39 | -- 40 | -- The following subprograms support converting command line 41 | -- arguments to C-style argc/argv command line arguments. 42 | -- 43 | --------------------------------------------------------------------- 44 | 45 | procedure Create (Argc : out CNatural; Argv : out Chars_Ptr_Ptr); 46 | -- Create returns the command line arguments from Ada.Command_Line 47 | -- and converts them to a C-style, null-terminated argument vector. 48 | 49 | procedure Show (Argc : CNatural; Argv : Chars_Ptr_Ptr); 50 | -- Prints Argc and Argv to standard out. 51 | 52 | procedure Free (Argv : in out Chars_Ptr_Ptr); 53 | -- Free all space used by Argv. 54 | 55 | -- Example of getting Ada command line arguments and passing them 56 | -- to a C function requiring argc/argv arguments: 57 | -- 58 | -- declare 59 | -- Argc : C.Int; 60 | -- Argv : CArgv.Chars_Ptr_Ptr; 61 | -- begin 62 | -- CArgv.Create (Argc, Argv); 63 | -- Tcl.Tcl_Concat (Argc, Argv); 64 | -- CArgv.Free (Argv); 65 | -- end; 66 | 67 | --------------------------------------------------------------------- 68 | -- 69 | -- The following subprogram supports retrieving a command line 70 | -- argument from C-style argv command line arguments. 71 | -- 72 | --------------------------------------------------------------------- 73 | 74 | function Arg (Argv : Chars_Ptr_Ptr; N : CNatural) return String; 75 | -- Returns the Nth argument from Argv. 76 | 77 | --------------------------------------------------------------------- 78 | -- 79 | -- The following subprograms support creating C-style argc/argv 80 | -- argument vectors from strings. 81 | -- 82 | --------------------------------------------------------------------- 83 | 84 | function Empty return Chars_Ptr_Ptr; 85 | -- An empty Chars_Ptr_Ptr, used for constructors. 86 | 87 | function "&" (Argv : Chars_Ptr_Ptr; Arg : String) return Chars_Ptr_Ptr; 88 | -- Construct a Chars_Ptr_Ptr using concat operation. 89 | 90 | function Argc (Argv : Chars_Ptr_Ptr) return CNatural; 91 | -- Returns the number of arguments in a Chars_Ptr_Ptr. 92 | 93 | -- Example of creating a Chars_Ptr_Ptr to pass to a C function requiring 94 | -- argc/argv arguments: 95 | -- 96 | -- declare 97 | -- Argv : CArgv.Chars_Ptr_Ptr := 98 | -- Empty & "this" & "is" & "four" & "arguments"; 99 | -- begin 100 | -- Tcl.Tcl_Concat (CArgv.Argc (Argv), Argv); 101 | -- CArgv.Free (Argv); 102 | -- end; 103 | 104 | end CArgv; 105 | -------------------------------------------------------------------------------- /src/chelper.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- chelper.ads -- Provides additional C data types not in Interfaces.C. 4 | -- Also provides for the type Interfaces.C.Strings those 5 | -- operations available for manipulating Ada strings in 6 | -- Ada.Strings.Fixed. 7 | -- 8 | -- Copyright (c) 1995-2000 Terry J. Westley 9 | -- 10 | -- See the file "license.htm" for information on usage and 11 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 | -- 13 | -------------------------------------------------------------------- 14 | 15 | with Ada.Strings.Maps; 16 | with Interfaces.C.Strings; 17 | 18 | package CHelper is 19 | 20 | package C renames Interfaces.C; 21 | 22 | type Int_Ptr is access all C.int; -- int * 23 | type Int_Ptr_Ptr is access all Int_Ptr; -- int ** 24 | type Long_Ptr is access all C.long; -- long * 25 | type Double_Ptr is access all C.double; -- double * 26 | type Int_Array is array (C.int range <>) of C.int; 27 | 28 | function To_C (Str : String) return C.Strings.chars_ptr renames 29 | C.Strings.New_String; 30 | 31 | function "&" (Left, Right : C.Strings.chars_ptr) return String; 32 | 33 | function "&" 34 | (Left : C.Strings.chars_ptr; 35 | Right : String) 36 | return String; 37 | 38 | function "&" 39 | (Left : String; 40 | Right : C.Strings.chars_ptr) 41 | return String; 42 | 43 | function Length (Source : C.Strings.chars_ptr) return Natural; 44 | function Length (Source : C.Strings.chars_ptr) return C.int; 45 | 46 | function Value (Item : C.Strings.chars_ptr) return String; 47 | pragma Inline (Value); 48 | 49 | -------------------------------------------------------- 50 | -- Conversion, Concatenation, and Selection Functions -- 51 | -------------------------------------------------------- 52 | 53 | procedure Append 54 | (Source : in out C.Strings.chars_ptr; 55 | New_Item : C.Strings.chars_ptr); 56 | 57 | procedure Append 58 | (Source : in out C.Strings.chars_ptr; 59 | New_Item : String); 60 | 61 | procedure Append 62 | (Source : in out C.Strings.chars_ptr; 63 | New_Item : Character); 64 | 65 | function Element 66 | (Source : C.Strings.chars_ptr; 67 | Index : Positive) 68 | return Character; 69 | 70 | procedure Replace_Element 71 | (Source : in out C.Strings.chars_ptr; 72 | Index : Positive; 73 | By : Character); 74 | 75 | function Slice 76 | (Source : C.Strings.chars_ptr; 77 | Low : Positive; 78 | High : Natural) 79 | return String; 80 | 81 | function "=" (Left, Right : C.Strings.chars_ptr) return Boolean; 82 | 83 | function "=" 84 | (Left : C.Strings.chars_ptr; 85 | Right : String) 86 | return Boolean; 87 | 88 | function "=" 89 | (Left : String; 90 | Right : C.Strings.chars_ptr) 91 | return Boolean; 92 | 93 | function "<" (Left, Right : C.Strings.chars_ptr) return Boolean; 94 | 95 | function "<" 96 | (Left : C.Strings.chars_ptr; 97 | Right : String) 98 | return Boolean; 99 | 100 | function "<" 101 | (Left : String; 102 | Right : C.Strings.chars_ptr) 103 | return Boolean; 104 | 105 | function "<=" (Left, Right : C.Strings.chars_ptr) return Boolean; 106 | 107 | function "<=" 108 | (Left : C.Strings.chars_ptr; 109 | Right : String) 110 | return Boolean; 111 | 112 | function "<=" 113 | (Left : String; 114 | Right : C.Strings.chars_ptr) 115 | return Boolean; 116 | 117 | function ">" (Left, Right : C.Strings.chars_ptr) return Boolean; 118 | 119 | function ">" 120 | (Left : C.Strings.chars_ptr; 121 | Right : String) 122 | return Boolean; 123 | 124 | function ">" 125 | (Left : String; 126 | Right : C.Strings.chars_ptr) 127 | return Boolean; 128 | 129 | function ">=" (Left, Right : C.Strings.chars_ptr) return Boolean; 130 | 131 | function ">=" 132 | (Left : C.Strings.chars_ptr; 133 | Right : String) 134 | return Boolean; 135 | 136 | function ">=" 137 | (Left : String; 138 | Right : C.Strings.chars_ptr) 139 | return Boolean; 140 | 141 | ------------------------ 142 | -- Search Subprograms -- 143 | ------------------------ 144 | 145 | function Index 146 | (Source : C.Strings.chars_ptr; 147 | Pattern : String; 148 | Going : Ada.Strings.Direction := Ada.Strings.Forward; 149 | Mapping : Ada.Strings.Maps.Character_Mapping := 150 | Ada.Strings.Maps.Identity) 151 | return Natural; 152 | 153 | function Index 154 | (Source : C.Strings.chars_ptr; 155 | Pattern : String; 156 | Going : Ada.Strings.Direction := Ada.Strings.Forward; 157 | Mapping : Ada.Strings.Maps.Character_Mapping_Function) 158 | return Natural; 159 | 160 | function Index 161 | (Source : C.Strings.chars_ptr; 162 | Set : Ada.Strings.Maps.Character_Set; 163 | Test : Ada.Strings.Membership := Ada.Strings.Inside; 164 | Going : Ada.Strings.Direction := Ada.Strings.Forward) 165 | return Natural; 166 | 167 | function Index_Non_Blank 168 | (Source : C.Strings.chars_ptr; 169 | Going : Ada.Strings.Direction := Ada.Strings.Forward) 170 | return Natural; 171 | 172 | function Count 173 | (Source : C.Strings.chars_ptr; 174 | Pattern : String; 175 | Mapping : Ada.Strings.Maps.Character_Mapping := 176 | Ada.Strings.Maps.Identity) 177 | return Natural; 178 | 179 | function Count 180 | (Source : C.Strings.chars_ptr; 181 | Pattern : String; 182 | Mapping : Ada.Strings.Maps.Character_Mapping_Function) 183 | return Natural; 184 | 185 | function Count 186 | (Source : C.Strings.chars_ptr; 187 | Set : Ada.Strings.Maps.Character_Set) 188 | return Natural; 189 | 190 | procedure Find_Token 191 | (Source : C.Strings.chars_ptr; 192 | Set : Ada.Strings.Maps.Character_Set; 193 | Test : Ada.Strings.Membership; 194 | First : out Positive; 195 | Last : out Natural); 196 | 197 | ------------------------------------ 198 | -- String Translation Subprograms -- 199 | ------------------------------------ 200 | 201 | function Translate 202 | (Source : C.Strings.chars_ptr; 203 | Mapping : Ada.Strings.Maps.Character_Mapping) 204 | return C.Strings.chars_ptr; 205 | 206 | procedure Translate 207 | (Source : in out C.Strings.chars_ptr; 208 | Mapping : Ada.Strings.Maps.Character_Mapping); 209 | 210 | function Translate 211 | (Source : C.Strings.chars_ptr; 212 | Mapping : Ada.Strings.Maps.Character_Mapping_Function) 213 | return C.Strings.chars_ptr; 214 | 215 | procedure Translate 216 | (Source : in out C.Strings.chars_ptr; 217 | Mapping : Ada.Strings.Maps.Character_Mapping_Function); 218 | 219 | --------------------------------------- 220 | -- String Transformation Subprograms -- 221 | --------------------------------------- 222 | 223 | function Replace_Slice 224 | (Source : C.Strings.chars_ptr; 225 | Low : Positive; 226 | High : Natural; 227 | By : String) 228 | return C.Strings.chars_ptr; 229 | 230 | procedure Replace_Slice 231 | (Source : in out C.Strings.chars_ptr; 232 | Low : Positive; 233 | High : Natural; 234 | By : String); 235 | 236 | function Insert 237 | (Source : C.Strings.chars_ptr; 238 | Before : Positive; 239 | New_Item : String) 240 | return C.Strings.chars_ptr; 241 | 242 | procedure Insert 243 | (Source : in out C.Strings.chars_ptr; 244 | Before : Positive; 245 | New_Item : String); 246 | 247 | function Overwrite 248 | (Source : C.Strings.chars_ptr; 249 | Position : Positive; 250 | New_Item : String) 251 | return C.Strings.chars_ptr; 252 | 253 | procedure Overwrite 254 | (Source : in out C.Strings.chars_ptr; 255 | Position : Positive; 256 | New_Item : String); 257 | 258 | function Delete 259 | (Source : C.Strings.chars_ptr; 260 | From : Positive; 261 | Through : Natural) 262 | return C.Strings.chars_ptr; 263 | 264 | procedure Delete 265 | (Source : in out C.Strings.chars_ptr; 266 | From : Positive; 267 | Through : Natural); 268 | 269 | function Trim 270 | (Source : C.Strings.chars_ptr; 271 | Side : Ada.Strings.Trim_End) 272 | return C.Strings.chars_ptr; 273 | 274 | procedure Trim 275 | (Source : in out C.Strings.chars_ptr; 276 | Side : Ada.Strings.Trim_End); 277 | 278 | function Trim 279 | (Source : C.Strings.chars_ptr; 280 | Left : Ada.Strings.Maps.Character_Set; 281 | Right : Ada.Strings.Maps.Character_Set) 282 | return C.Strings.chars_ptr; 283 | 284 | procedure Trim 285 | (Source : in out C.Strings.chars_ptr; 286 | Left : Ada.Strings.Maps.Character_Set; 287 | Right : Ada.Strings.Maps.Character_Set); 288 | 289 | function Head 290 | (Source : C.Strings.chars_ptr; 291 | Count : Natural; 292 | Pad : Character := Ada.Strings.Space) 293 | return C.Strings.chars_ptr; 294 | 295 | procedure Head 296 | (Source : in out C.Strings.chars_ptr; 297 | Count : Natural; 298 | Pad : Character := Ada.Strings.Space); 299 | 300 | function Tail 301 | (Source : C.Strings.chars_ptr; 302 | Count : Natural; 303 | Pad : Character := Ada.Strings.Space) 304 | return C.Strings.chars_ptr; 305 | 306 | procedure Tail 307 | (Source : in out C.Strings.chars_ptr; 308 | Count : Natural; 309 | Pad : Character := Ada.Strings.Space); 310 | 311 | function "*" 312 | (Left : Natural; 313 | Right : Character) 314 | return C.Strings.chars_ptr; 315 | 316 | function "*" 317 | (Left : Natural; 318 | Right : String) 319 | return C.Strings.chars_ptr; 320 | 321 | function "*" 322 | (Left : Natural; 323 | Right : C.Strings.chars_ptr) 324 | return C.Strings.chars_ptr; 325 | 326 | end CHelper; 327 | -------------------------------------------------------------------------------- /src/tash-float_arrays.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.Float_Arrays spec 4 | -- 5 | -- File Name: tash-float_arrays.ads 6 | -- 7 | -- Purpose: Instantiates the Tash array type for Floats.. 8 | -- 9 | -- Copyright (c) 1999-2000 Terry J. Westley 10 | -- 11 | -- Tash is free software; you can redistribute it and/or modify it under 12 | -- terms of the GNU General Public License as published by the Free 13 | -- Software Foundation; either version 2, or (at your option) any later 14 | -- version. Tash is distributed in the hope that it will be useful, but 15 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 17 | -- for more details. You should have received a copy of the GNU General 18 | -- Public License distributed with Tash; see file COPYING. If not, write to 19 | -- 20 | -- Free Software Foundation 21 | -- 59 Temple Place - Suite 330 22 | -- Boston, MA 02111-1307, USA 23 | -- 24 | -- As a special exception, if other files instantiate generics from this 25 | -- unit, or you link this unit with other files to produce an executable, 26 | -- this unit does not by itself cause the resulting executable to be 27 | -- covered by the GNU General Public License. This exception does not 28 | -- however invalidate any other reasons why the executable file might be 29 | -- covered by the GNU Public License. 30 | -- 31 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 32 | -- 33 | -------------------------------------------------------------------- 34 | 35 | with Tash.Arrays; 36 | 37 | package Tash.Float_Arrays is new Tash.Arrays.Generic_Float_Arrays (Float); 38 | -------------------------------------------------------------------------------- /src/tash-float_lists.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.Float_Lists spec 4 | -- 5 | -- File Name: tash-float_lists.ads 6 | -- 7 | -- Purpose: Instantiates the Tash list type for Floats. 8 | -- 9 | -- Copyright (c) 1999-2000 Terry J. Westley 10 | -- 11 | -- Tash is free software; you can redistribute it and/or modify it under 12 | -- terms of the GNU General Public License as published by the Free 13 | -- Software Foundation; either version 2, or (at your option) any later 14 | -- version. Tash is distributed in the hope that it will be useful, but 15 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 17 | -- for more details. You should have received a copy of the GNU General 18 | -- Public License distributed with Tash; see file COPYING. If not, write to 19 | -- 20 | -- Free Software Foundation 21 | -- 59 Temple Place - Suite 330 22 | -- Boston, MA 02111-1307, USA 23 | -- 24 | -- As a special exception, if other files instantiate generics from this 25 | -- unit, or you link this unit with other files to produce an executable, 26 | -- this unit does not by itself cause the resulting executable to be 27 | -- covered by the GNU General Public License. This exception does not 28 | -- however invalidate any other reasons why the executable file might be 29 | -- covered by the GNU Public License. 30 | -- 31 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 32 | -- 33 | -------------------------------------------------------------------- 34 | 35 | with Tash.Lists; 36 | 37 | package Tash.Float_Lists is new Tash.Lists.Generic_Float_Lists (Float); 38 | -------------------------------------------------------------------------------- /src/tash-floats.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.Floats body 4 | -- 5 | -- File Name: tash-floats.adb 6 | -- 7 | -- Purpose: This package exports a Tash float type along with 8 | -- its operations. 9 | -- 10 | -- Copyright (c) 1999 Terry J. Westley 11 | -- 12 | -- Tash is free software; you can redistribute it and/or modify it under 13 | -- terms of the GNU General Public License as published by the Free 14 | -- Software Foundation; either version 2, or (at your option) any later 15 | -- version. Tash is distributed in the hope that it will be useful, but 16 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 18 | -- for more details. You should have received a copy of the GNU General 19 | -- Public License distributed with Tash; see file COPYING. If not, write to 20 | -- 21 | -- Free Software Foundation 22 | -- 59 Temple Place - Suite 330 23 | -- Boston, MA 02111-1307, USA 24 | -- 25 | -- As a special exception, if other files instantiate generics from this 26 | -- unit, or you link this unit with other files to produce an executable, 27 | -- this unit does not by itself cause the resulting executable to be 28 | -- covered by the GNU General Public License. This exception does not 29 | -- however invalidate any other reasons why the executable file might be 30 | -- covered by the GNU Public License. 31 | -- 32 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 33 | -- 34 | -------------------------------------------------------------------- 35 | 36 | with CHelper; 37 | 38 | package body Tash.Floats is 39 | 40 | use type Interfaces.C.int; 41 | use type Interfaces.C.double; 42 | 43 | function Is_Zero (TFloat : in Tash_Float) return Boolean is 44 | begin -- Is_Zero 45 | return Is_Null (TFloat) or else To_Float (TFloat) = 0.0; 46 | end Is_Zero; 47 | pragma Inline (Is_Zero); 48 | 49 | function To_Tash_Float (Str : in String) return Tash_Float is 50 | -- 51 | New_Obj : Tcl.Tcl_Obj; 52 | begin -- To_Tash_Float 53 | New_Obj := Tcl.Tcl_NewDoubleObj (Interfaces.C.double'Value (Str)); 54 | Tcl.Tcl_IncrRefCount (New_Obj); 55 | return (Ada.Finalization.Controlled with Obj => New_Obj); 56 | end To_Tash_Float; 57 | 58 | function To_String (TFloat : in Tash_Float) return String is 59 | -- 60 | Length : aliased Interfaces.C.int; 61 | begin -- To_String 62 | if Is_Null (TFloat) then 63 | return "0.0"; 64 | else 65 | return CHelper.Value 66 | (Tcl.Tcl_GetStringFromObj (TFloat.Obj, Length'Access)); 67 | end if; 68 | end To_String; 69 | 70 | function To_Tash_Float (LFloat : in Tash_Float_Range) return Tash_Float is 71 | -- 72 | New_Obj : Tcl.Tcl_Obj; 73 | begin -- To_Tash_Float 74 | New_Obj := Tcl.Tcl_NewDoubleObj (Interfaces.C.double (LFloat)); 75 | Tcl.Tcl_IncrRefCount (New_Obj); 76 | return (Ada.Finalization.Controlled with Obj => New_Obj); 77 | end To_Tash_Float; 78 | 79 | function "+" (LFloat : in Tash_Float_Range) return Tash_Float is 80 | begin -- "+" 81 | return To_Tash_Float (+LFloat); 82 | end "+"; 83 | 84 | function "-" (LFloat : in Tash_Float_Range) return Tash_Float is 85 | begin -- "-" 86 | return To_Tash_Float (-LFloat); 87 | end "-"; 88 | 89 | function To_Float (TFloat : in Tash_Float) return Tash_Float_Range is 90 | -- 91 | Result : Interfaces.C.int; 92 | Value : aliased Interfaces.C.double; 93 | Interp : Tcl.Tcl_Interp; 94 | begin -- To_Float 95 | if Is_Null (TFloat) then 96 | return 0.0; 97 | end if; 98 | Tash_Interp.Get (Interp); 99 | Result := 100 | Tcl.Tcl_GetDoubleFromObj 101 | (interp => Interp, 102 | objPtr => TFloat.Obj, 103 | doublePtr => Value'Access); 104 | Tash_Interp.Release (Interp); 105 | if Result /= Tcl.TCL_OK then 106 | raise Constraint_Error; 107 | end if; 108 | return Tash_Float_Range (Value); 109 | end To_Float; 110 | 111 | function "=" 112 | (Left : in Tash_Float; 113 | Right : in Tash_Float) 114 | return Boolean 115 | is 116 | begin -- "=" 117 | return To_Float (Left) = To_Float (Right); 118 | end "="; 119 | 120 | function "=" 121 | (Left : in Tash_Float; 122 | Right : in Tash_Float_Range) 123 | return Boolean 124 | is 125 | begin -- "=" 126 | return To_Float (Left) = Right; 127 | end "="; 128 | 129 | function "=" 130 | (Left : in Tash_Float_Range; 131 | Right : in Tash_Float) 132 | return Boolean 133 | is 134 | begin -- "=" 135 | return Left = To_Float (Right); 136 | end "="; 137 | 138 | function "<" 139 | (Left : in Tash_Float; 140 | Right : in Tash_Float) 141 | return Boolean 142 | is 143 | begin -- "<" 144 | return To_Float (Left) < To_Float (Right); 145 | end "<"; 146 | 147 | function "<" 148 | (Left : in Tash_Float; 149 | Right : in Tash_Float_Range) 150 | return Boolean 151 | is 152 | begin -- "<" 153 | return To_Float (Left) < Right; 154 | end "<"; 155 | 156 | function "<" 157 | (Left : in Tash_Float_Range; 158 | Right : in Tash_Float) 159 | return Boolean 160 | is 161 | begin -- "<" 162 | return Left < To_Float (Right); 163 | end "<"; 164 | 165 | function "<=" 166 | (Left : in Tash_Float; 167 | Right : in Tash_Float) 168 | return Boolean 169 | is 170 | begin -- "<=" 171 | return To_Float (Left) <= To_Float (Right); 172 | end "<="; 173 | 174 | function "<=" 175 | (Left : in Tash_Float; 176 | Right : in Tash_Float_Range) 177 | return Boolean 178 | is 179 | begin -- "<=" 180 | return To_Float (Left) <= Right; 181 | end "<="; 182 | 183 | function "<=" 184 | (Left : in Tash_Float_Range; 185 | Right : in Tash_Float) 186 | return Boolean 187 | is 188 | begin -- "<=" 189 | return Left <= To_Float (Right); 190 | end "<="; 191 | 192 | function ">" 193 | (Left : in Tash_Float; 194 | Right : in Tash_Float) 195 | return Boolean 196 | is 197 | begin -- ">" 198 | return To_Float (Left) > To_Float (Right); 199 | end ">"; 200 | 201 | function ">" 202 | (Left : in Tash_Float; 203 | Right : in Tash_Float_Range) 204 | return Boolean 205 | is 206 | begin -- ">" 207 | return To_Float (Left) > Right; 208 | end ">"; 209 | 210 | function ">" 211 | (Left : in Tash_Float_Range; 212 | Right : in Tash_Float) 213 | return Boolean 214 | is 215 | begin -- ">" 216 | return Left > To_Float (Right); 217 | end ">"; 218 | 219 | function ">=" 220 | (Left : in Tash_Float; 221 | Right : in Tash_Float) 222 | return Boolean 223 | is 224 | begin -- ">=" 225 | return To_Float (Left) >= To_Float (Right); 226 | end ">="; 227 | 228 | function ">=" 229 | (Left : in Tash_Float; 230 | Right : in Tash_Float_Range) 231 | return Boolean 232 | is 233 | begin -- ">=" 234 | return To_Float (Left) >= Right; 235 | end ">="; 236 | 237 | function ">=" 238 | (Left : in Tash_Float_Range; 239 | Right : in Tash_Float) 240 | return Boolean 241 | is 242 | begin -- ">=" 243 | return Left >= To_Float (Right); 244 | end ">="; 245 | 246 | function "abs" (Right : in Tash_Float) return Tash_Float is 247 | begin -- "abs" 248 | return To_Tash_Float (Standard. "abs" (To_Float (Right))); 249 | end "abs"; 250 | 251 | function "+" 252 | (Left : in Tash_Float; 253 | Right : in Tash_Float) 254 | return Tash_Float 255 | is 256 | begin -- "+" 257 | return To_Tash_Float 258 | (Standard. "+" (To_Float (Left), To_Float (Right))); 259 | end "+"; 260 | 261 | function "+" 262 | (Left : in Tash_Float; 263 | Right : in Tash_Float_Range) 264 | return Tash_Float 265 | is 266 | begin -- "+" 267 | return To_Tash_Float (Standard. "+" (To_Float (Left), Right)); 268 | end "+"; 269 | 270 | function "+" 271 | (Left : in Tash_Float_Range; 272 | Right : in Tash_Float) 273 | return Tash_Float 274 | is 275 | begin -- "+" 276 | return To_Tash_Float (Standard. "+" (Left, To_Float (Right))); 277 | end "+"; 278 | 279 | function "-" 280 | (Left : in Tash_Float; 281 | Right : in Tash_Float) 282 | return Tash_Float 283 | is 284 | begin -- "-" 285 | return To_Tash_Float 286 | (Standard. "-" (To_Float (Left), To_Float (Right))); 287 | end "-"; 288 | 289 | function "-" 290 | (Left : in Tash_Float; 291 | Right : in Tash_Float_Range) 292 | return Tash_Float 293 | is 294 | begin -- "-" 295 | return To_Tash_Float (Standard. "-" (To_Float (Left), Right)); 296 | end "-"; 297 | 298 | function "-" 299 | (Left : in Tash_Float_Range; 300 | Right : in Tash_Float) 301 | return Tash_Float 302 | is 303 | begin -- "-" 304 | return To_Tash_Float (Standard. "-" (Left, To_Float (Right))); 305 | end "-"; 306 | 307 | function "*" 308 | (Left : in Tash_Float; 309 | Right : in Tash_Float) 310 | return Tash_Float 311 | is 312 | begin -- "*" 313 | return To_Tash_Float 314 | (Standard. "*" (To_Float (Left), To_Float (Right))); 315 | end "*"; 316 | 317 | function "*" 318 | (Left : in Tash_Float; 319 | Right : in Tash_Float_Range) 320 | return Tash_Float 321 | is 322 | begin -- "*" 323 | return To_Tash_Float (Standard. "*" (To_Float (Left), Right)); 324 | end "*"; 325 | 326 | function "*" 327 | (Left : in Tash_Float_Range; 328 | Right : in Tash_Float) 329 | return Tash_Float 330 | is 331 | begin -- "*" 332 | return To_Tash_Float (Standard. "*" (Left, To_Float (Right))); 333 | end "*"; 334 | 335 | function "/" 336 | (Left : in Tash_Float; 337 | Right : in Tash_Float) 338 | return Tash_Float 339 | is 340 | begin -- "/" 341 | return To_Tash_Float 342 | (Standard. "/" (To_Float (Left), To_Float (Right))); 343 | end "/"; 344 | 345 | function "/" 346 | (Left : in Tash_Float; 347 | Right : in Tash_Float_Range) 348 | return Tash_Float 349 | is 350 | begin -- "/" 351 | return To_Tash_Float (Standard. "/" (To_Float (Left), Right)); 352 | end "/"; 353 | 354 | function "/" 355 | (Left : in Tash_Float_Range; 356 | Right : in Tash_Float) 357 | return Tash_Float 358 | is 359 | begin -- "/" 360 | return To_Tash_Float (Standard. "/" (Left, To_Float (Right))); 361 | end "/"; 362 | 363 | function "**" 364 | (Left : in Tash_Float; 365 | Right : in Integer) 366 | return Tash_Float 367 | is 368 | begin -- "**" 369 | return To_Tash_Float (Standard. "**" (To_Float (Left), Right)); 370 | end "**"; 371 | 372 | end Tash.Floats; 373 | -------------------------------------------------------------------------------- /src/tash-floats.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.Floats spec 4 | -- 5 | -- File Name: tash-floats.ads 6 | -- 7 | -- Purpose: This package exports a Tash float type along with 8 | -- its operations. 9 | -- 10 | -- Copyright (c) 1999 Terry J. Westley 11 | -- 12 | -- Tash is free software; you can redistribute it and/or modify it under 13 | -- terms of the GNU General Public License as published by the Free 14 | -- Software Foundation; either version 2, or (at your option) any later 15 | -- version. Tash is distributed in the hope that it will be useful, but 16 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 18 | -- for more details. You should have received a copy of the GNU General 19 | -- Public License distributed with Tash; see file COPYING. If not, write to 20 | -- 21 | -- Free Software Foundation 22 | -- 59 Temple Place - Suite 330 23 | -- Boston, MA 02111-1307, USA 24 | -- 25 | -- As a special exception, if other files instantiate generics from this 26 | -- unit, or you link this unit with other files to produce an executable, 27 | -- this unit does not by itself cause the resulting executable to be 28 | -- covered by the GNU General Public License. This exception does not 29 | -- however invalidate any other reasons why the executable file might be 30 | -- covered by the GNU Public License. 31 | -- 32 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 33 | -- 34 | -------------------------------------------------------------------- 35 | 36 | with Ada.Finalization; 37 | 38 | package Tash.Floats is 39 | 40 | -------------------------------------------------------- 41 | -- A Tash float is derived from a Tash object. 42 | -- 43 | -- When used in an expression, an uninitialized Tash float 44 | -- evaluates to 0.0. 45 | -------------------------------------------------------- 46 | 47 | type Tash_Float is new Tash.Tash_Object with null record; 48 | 49 | Null_Tash_Float : constant Tash_Float; 50 | 51 | ----------------------------------------------- 52 | -- Inherits Is_Null function from Tash. It 53 | -- returns True if TFloat has not been initialized 54 | -- or has been set to Null_Tash_Float. 55 | ----------------------------------------------- 56 | 57 | -- function Is_Null ( 58 | -- TFloat : in Tash_Float) return Boolean; 59 | 60 | ----------------------------------------------- 61 | -- Returns True if Is_Null(TFloat) is true or 62 | -- To_Float(TFloat) = 0.0. 63 | ----------------------------------------------- 64 | 65 | function Is_Zero (TFloat : in Tash_Float) return Boolean; 66 | 67 | ----------------------------------------------- 68 | -- Convert a string to a Tash float. 69 | -- Raises Constraint_Error if number is invalid 70 | -- or outside the range of Tash_Float. 71 | ----------------------------------------------- 72 | 73 | function To_Tash_Float (Str : in String) return Tash_Float; 74 | 75 | -------------------------------------------------------- 76 | -- Convert a Tash float to a string. Returns "0.0" for 77 | -- an uninitialized Tash_Float. 78 | -- 79 | -- Recall that all non-string Tash data types have a dual 80 | -- representation. At any time, you may fetch either the 81 | -- string representation or the native (i.e. Float) 82 | -- representation. The string representation is updated 83 | -- to correspond with the native data type only when the 84 | -- string is fetched. 85 | -------------------------------------------------------- 86 | 87 | function To_String (TFloat : in Tash_Float) return String; 88 | 89 | -------------------------------------------------------- 90 | -- Convert Ada floats to and from Tash floats. 91 | -------------------------------------------------------- 92 | 93 | subtype Tash_Float_Range is Long_Float range 94 | Long_Float (Interfaces.C.double'First) .. 95 | Long_Float (Interfaces.C.double'Last); 96 | -- This subtype will not compile if standard Ada Long_Float range 97 | -- is smaller than Tash float range. It is also used to assure 98 | -- that we don't attempt to convert Ada floats outside the Tash 99 | -- float range to/from Tash floats. 100 | 101 | function To_Tash_Float (LFloat : in Tash_Float_Range) return Tash_Float; 102 | 103 | function "+" (LFloat : in Tash_Float_Range) return Tash_Float; 104 | 105 | function "-" (LFloat : in Tash_Float_Range) return Tash_Float; 106 | 107 | function To_Float (TFloat : in Tash_Float) return Tash_Float_Range; 108 | 109 | -------------------------------------------------------- 110 | -- Compare Tash and standard Ada floats 111 | -------------------------------------------------------- 112 | 113 | function "=" 114 | (Left : in Tash_Float; 115 | Right : in Tash_Float) 116 | return Boolean; 117 | 118 | function "=" 119 | (Left : in Tash_Float; 120 | Right : in Tash_Float_Range) 121 | return Boolean; 122 | 123 | function "=" 124 | (Left : in Tash_Float_Range; 125 | Right : in Tash_Float) 126 | return Boolean; 127 | 128 | function "<" 129 | (Left : in Tash_Float; 130 | Right : in Tash_Float) 131 | return Boolean; 132 | 133 | function "<" 134 | (Left : in Tash_Float; 135 | Right : in Tash_Float_Range) 136 | return Boolean; 137 | 138 | function "<" 139 | (Left : in Tash_Float_Range; 140 | Right : in Tash_Float) 141 | return Boolean; 142 | 143 | function "<=" 144 | (Left : in Tash_Float; 145 | Right : in Tash_Float) 146 | return Boolean; 147 | 148 | function "<=" 149 | (Left : in Tash_Float; 150 | Right : in Tash_Float_Range) 151 | return Boolean; 152 | 153 | function "<=" 154 | (Left : in Tash_Float_Range; 155 | Right : in Tash_Float) 156 | return Boolean; 157 | 158 | function ">" 159 | (Left : in Tash_Float; 160 | Right : in Tash_Float) 161 | return Boolean; 162 | 163 | function ">" 164 | (Left : in Tash_Float; 165 | Right : in Tash_Float_Range) 166 | return Boolean; 167 | 168 | function ">" 169 | (Left : in Tash_Float_Range; 170 | Right : in Tash_Float) 171 | return Boolean; 172 | 173 | function ">=" 174 | (Left : in Tash_Float; 175 | Right : in Tash_Float) 176 | return Boolean; 177 | 178 | function ">=" 179 | (Left : in Tash_Float; 180 | Right : in Tash_Float_Range) 181 | return Boolean; 182 | 183 | function ">=" 184 | (Left : in Tash_Float_Range; 185 | Right : in Tash_Float) 186 | return Boolean; 187 | 188 | -------------------------------------------------------- 189 | -- Tash float arithmetic operations 190 | -------------------------------------------------------- 191 | 192 | function "abs" (Right : in Tash_Float) return Tash_Float; 193 | 194 | function "+" 195 | (Left : in Tash_Float; 196 | Right : in Tash_Float) 197 | return Tash_Float; 198 | 199 | function "+" 200 | (Left : in Tash_Float; 201 | Right : in Tash_Float_Range) 202 | return Tash_Float; 203 | 204 | function "+" 205 | (Left : in Tash_Float_Range; 206 | Right : in Tash_Float) 207 | return Tash_Float; 208 | 209 | function "-" 210 | (Left : in Tash_Float; 211 | Right : in Tash_Float) 212 | return Tash_Float; 213 | 214 | function "-" 215 | (Left : in Tash_Float; 216 | Right : in Tash_Float_Range) 217 | return Tash_Float; 218 | 219 | function "-" 220 | (Left : in Tash_Float_Range; 221 | Right : in Tash_Float) 222 | return Tash_Float; 223 | 224 | function "*" 225 | (Left : in Tash_Float; 226 | Right : in Tash_Float) 227 | return Tash_Float; 228 | 229 | function "*" 230 | (Left : in Tash_Float; 231 | Right : in Tash_Float_Range) 232 | return Tash_Float; 233 | 234 | function "*" 235 | (Left : in Tash_Float_Range; 236 | Right : in Tash_Float) 237 | return Tash_Float; 238 | 239 | function "/" 240 | (Left : in Tash_Float; 241 | Right : in Tash_Float) 242 | return Tash_Float; 243 | 244 | function "/" 245 | (Left : in Tash_Float; 246 | Right : in Tash_Float_Range) 247 | return Tash_Float; 248 | 249 | function "/" 250 | (Left : in Tash_Float_Range; 251 | Right : in Tash_Float) 252 | return Tash_Float; 253 | 254 | function "**" 255 | (Left : in Tash_Float; 256 | Right : in Integer) 257 | return Tash_Float; 258 | 259 | private 260 | 261 | Null_Tash_Float : constant Tash_Float := (Ada.Finalization.Controlled with 262 | Obj => null); 263 | 264 | Verbose : Boolean := False; 265 | 266 | end Tash.Floats; 267 | -------------------------------------------------------------------------------- /src/tash-integer_arrays.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.Integer_Arrays spec 4 | -- 5 | -- File Name: tash-integer_arrays.ads 6 | -- 7 | -- Purpose: Instantiates the Tash array type for Integers. 8 | -- 9 | -- Copyright (c) 1999-2000 Terry J. Westley 10 | -- 11 | -- Tash is free software; you can redistribute it and/or modify it under 12 | -- terms of the GNU General Public License as published by the Free 13 | -- Software Foundation; either version 2, or (at your option) any later 14 | -- version. Tash is distributed in the hope that it will be useful, but 15 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 17 | -- for more details. You should have received a copy of the GNU General 18 | -- Public License distributed with Tash; see file COPYING. If not, write to 19 | -- 20 | -- Free Software Foundation 21 | -- 59 Temple Place - Suite 330 22 | -- Boston, MA 02111-1307, USA 23 | -- 24 | -- As a special exception, if other files instantiate generics from this 25 | -- unit, or you link this unit with other files to produce an executable, 26 | -- this unit does not by itself cause the resulting executable to be 27 | -- covered by the GNU General Public License. This exception does not 28 | -- however invalidate any other reasons why the executable file might be 29 | -- covered by the GNU Public License. 30 | -- 31 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 32 | -- 33 | -------------------------------------------------------------------- 34 | 35 | with Tash.Arrays; 36 | 37 | package Tash.Integer_Arrays is new Tash.Arrays.Generic_Integer_Arrays ( 38 | Integer); 39 | -------------------------------------------------------------------------------- /src/tash-integer_lists.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.Integer_Lists spec 4 | -- 5 | -- File Name: tash-integer_lists.ads 6 | -- 7 | -- Purpose: Instantiates the Tash list type for Integers. 8 | -- 9 | -- Copyright (c) 1999-2000 Terry J. Westley 10 | -- 11 | -- Tash is free software; you can redistribute it and/or modify it under 12 | -- terms of the GNU General Public License as published by the Free 13 | -- Software Foundation; either version 2, or (at your option) any later 14 | -- version. Tash is distributed in the hope that it will be useful, but 15 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 17 | -- for more details. You should have received a copy of the GNU General 18 | -- Public License distributed with Tash; see file COPYING. If not, write to 19 | -- 20 | -- Free Software Foundation 21 | -- 59 Temple Place - Suite 330 22 | -- Boston, MA 02111-1307, USA 23 | -- 24 | -- As a special exception, if other files instantiate generics from this 25 | -- unit, or you link this unit with other files to produce an executable, 26 | -- this unit does not by itself cause the resulting executable to be 27 | -- covered by the GNU General Public License. This exception does not 28 | -- however invalidate any other reasons why the executable file might be 29 | -- covered by the GNU Public License. 30 | -- 31 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 32 | -- 33 | -------------------------------------------------------------------- 34 | 35 | with Tash.Lists; 36 | 37 | package Tash.Integer_Lists is new Tash.Lists.Generic_Integer_Lists (Integer); 38 | -------------------------------------------------------------------------------- /src/tash-integers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.Integers spec 4 | -- 5 | -- File Name: tash-integers.ads 6 | -- 7 | -- Purpose: This package exports a Tash integer type along with 8 | -- its operations. 9 | -- 10 | -- Copyright (c) 1999 Terry J. Westley 11 | -- 12 | -- Tash is free software; you can redistribute it and/or modify it under 13 | -- terms of the GNU General Public License as published by the Free 14 | -- Software Foundation; either version 2, or (at your option) any later 15 | -- version. Tash is distributed in the hope that it will be useful, but 16 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 18 | -- for more details. You should have received a copy of the GNU General 19 | -- Public License distributed with Tash; see file COPYING. If not, write to 20 | -- 21 | -- Free Software Foundation 22 | -- 59 Temple Place - Suite 330 23 | -- Boston, MA 02111-1307, USA 24 | -- 25 | -- As a special exception, if other files instantiate generics from this 26 | -- unit, or you link this unit with other files to produce an executable, 27 | -- this unit does not by itself cause the resulting executable to be 28 | -- covered by the GNU General Public License. This exception does not 29 | -- however invalidate any other reasons why the executable file might be 30 | -- covered by the GNU Public License. 31 | -- 32 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 33 | -- 34 | -------------------------------------------------------------------- 35 | 36 | with Ada.Finalization; 37 | 38 | package Tash.Integers is 39 | 40 | -------------------------------------------------------- 41 | -- A Tash integer is derived from a Tash object. 42 | -- 43 | -- When used in any expression, an uninitialized Tash_Integer 44 | -- has the value of 0. 45 | -------------------------------------------------------- 46 | 47 | type Tash_Integer is new Tash.Tash_Object with null record; 48 | 49 | Null_Tash_Integer : constant Tash_Integer; 50 | 51 | ----------------------------------------------- 52 | -- Inherits Is_Null function from Tash. It 53 | -- returns True if TInteger has not been initialized 54 | -- or has been set to Null_Tash_Integer. 55 | ----------------------------------------------- 56 | 57 | -- function Is_Null ( 58 | -- TInteger : in Tash_Integer) return Boolean; 59 | 60 | ----------------------------------------------- 61 | -- Returns True if Is_Null(TInteger) is true or 62 | -- To_Integer(TInteger) = 0. 63 | ----------------------------------------------- 64 | 65 | function Is_Zero (TInteger : in Tash_Integer) return Boolean; 66 | 67 | ----------------------------------------------- 68 | -- Convert a string to a Tash integer. 69 | -- Raises Constraint_Error if number is invalid 70 | -- or outside the range of Tash_Integer. 71 | ----------------------------------------------- 72 | 73 | function To_Tash_Integer (Str : in String) return Tash_Integer; 74 | 75 | -------------------------------------------------------- 76 | -- Convert a Tash integer to a string. Returns "0" for 77 | -- an uninitialized Tash_Integer. 78 | -- 79 | -- Recall that all non-string Tash data types have a dual 80 | -- representation. At any time, you may fetch either the 81 | -- string representation or the native (i.e. Integer) 82 | -- representation. The string representation is updated 83 | -- to correspond with the native data type only when the 84 | -- string is fetched. 85 | -------------------------------------------------------- 86 | 87 | function To_String (TInteger : in Tash_Integer) return String; 88 | 89 | -------------------------------------------------------- 90 | -- Convert Ada integers to and from Tash integers. 91 | -------------------------------------------------------- 92 | 93 | subtype Tash_Integer_Range is Long_Integer range 94 | Long_Integer (Interfaces.C.long'First) .. 95 | Long_Integer (Interfaces.C.long'Last); 96 | -- This subtype will not compile if standard Ada long_integer range 97 | -- is smaller than Tash long_integer range. It is also used to assure 98 | -- that we don't attempt to convert Ada long_integers outside the Tash 99 | -- long_integer range to/from Tash long_integers. 100 | 101 | function To_Tash_Integer 102 | (LInteger : in Tash_Integer_Range) 103 | return Tash_Integer; 104 | 105 | function "+" (LInteger : in Tash_Integer_Range) return Tash_Integer; 106 | 107 | function "-" (LInteger : in Tash_Integer_Range) return Tash_Integer; 108 | 109 | function To_Integer 110 | (TInteger : in Tash_Integer) 111 | return Tash_Integer_Range; 112 | 113 | -------------------------------------------------------- 114 | -- Increment a Tash integer. If TInteger is uninitialized, 115 | -- it will be set to 1. 116 | -- 117 | -- Note different formal argument name for the increment 118 | -- amount in these two subprograms. This helps to disambiguate 119 | -- the following call when Tash.Integers."-" is visible: 120 | -- 121 | -- Incr (A, -1); 122 | -- 123 | -- Instead, use one of the following calls: 124 | -- 125 | -- Incr (A, By => -1); 126 | -- Incr (A, Integer'(-1)); 127 | -- 128 | -------------------------------------------------------- 129 | 130 | procedure Incr 131 | (TInteger : in out Tash_Integer; 132 | By : in Tash_Integer_Range := 1); 133 | 134 | procedure Incr 135 | (TInteger : in out Tash_Integer; 136 | Amount : in Tash_Integer); 137 | 138 | -------------------------------------------------------- 139 | -- Compare Tash and standard Ada integers 140 | -------------------------------------------------------- 141 | 142 | function "=" 143 | (Left : in Tash_Integer; 144 | Right : in Tash_Integer) 145 | return Boolean; 146 | 147 | function "=" 148 | (Left : in Tash_Integer; 149 | Right : in Tash_Integer_Range) 150 | return Boolean; 151 | 152 | function "=" 153 | (Left : in Tash_Integer_Range; 154 | Right : in Tash_Integer) 155 | return Boolean; 156 | 157 | function "<" 158 | (Left : in Tash_Integer; 159 | Right : in Tash_Integer) 160 | return Boolean; 161 | 162 | function "<" 163 | (Left : in Tash_Integer; 164 | Right : in Tash_Integer_Range) 165 | return Boolean; 166 | 167 | function "<" 168 | (Left : in Tash_Integer_Range; 169 | Right : in Tash_Integer) 170 | return Boolean; 171 | 172 | function "<=" 173 | (Left : in Tash_Integer; 174 | Right : in Tash_Integer) 175 | return Boolean; 176 | 177 | function "<=" 178 | (Left : in Tash_Integer; 179 | Right : in Tash_Integer_Range) 180 | return Boolean; 181 | 182 | function "<=" 183 | (Left : in Tash_Integer_Range; 184 | Right : in Tash_Integer) 185 | return Boolean; 186 | 187 | function ">" 188 | (Left : in Tash_Integer; 189 | Right : in Tash_Integer) 190 | return Boolean; 191 | 192 | function ">" 193 | (Left : in Tash_Integer; 194 | Right : in Tash_Integer_Range) 195 | return Boolean; 196 | 197 | function ">" 198 | (Left : in Tash_Integer_Range; 199 | Right : in Tash_Integer) 200 | return Boolean; 201 | 202 | function ">=" 203 | (Left : in Tash_Integer; 204 | Right : in Tash_Integer) 205 | return Boolean; 206 | 207 | function ">=" 208 | (Left : in Tash_Integer; 209 | Right : in Tash_Integer_Range) 210 | return Boolean; 211 | 212 | function ">=" 213 | (Left : in Tash_Integer_Range; 214 | Right : in Tash_Integer) 215 | return Boolean; 216 | 217 | -------------------------------------------------------- 218 | -- Tash integer arithmetic operations 219 | -------------------------------------------------------- 220 | 221 | function "abs" (Right : in Tash_Integer) return Tash_Integer; 222 | 223 | function "+" 224 | (Left : in Tash_Integer; 225 | Right : in Tash_Integer) 226 | return Tash_Integer; 227 | 228 | function "+" 229 | (Left : in Tash_Integer; 230 | Right : in Tash_Integer_Range) 231 | return Tash_Integer; 232 | 233 | function "+" 234 | (Left : in Tash_Integer_Range; 235 | Right : in Tash_Integer) 236 | return Tash_Integer; 237 | 238 | function "-" 239 | (Left : in Tash_Integer; 240 | Right : in Tash_Integer) 241 | return Tash_Integer; 242 | 243 | function "-" 244 | (Left : in Tash_Integer; 245 | Right : in Tash_Integer_Range) 246 | return Tash_Integer; 247 | 248 | function "-" 249 | (Left : in Tash_Integer_Range; 250 | Right : in Tash_Integer) 251 | return Tash_Integer; 252 | 253 | function "*" 254 | (Left : in Tash_Integer; 255 | Right : in Tash_Integer) 256 | return Tash_Integer; 257 | 258 | function "*" 259 | (Left : in Tash_Integer; 260 | Right : in Tash_Integer_Range) 261 | return Tash_Integer; 262 | 263 | function "*" 264 | (Left : in Tash_Integer_Range; 265 | Right : in Tash_Integer) 266 | return Tash_Integer; 267 | 268 | function "/" 269 | (Left : in Tash_Integer; 270 | Right : in Tash_Integer) 271 | return Tash_Integer; 272 | 273 | function "/" 274 | (Left : in Tash_Integer; 275 | Right : in Tash_Integer_Range) 276 | return Tash_Integer; 277 | 278 | function "/" 279 | (Left : in Tash_Integer_Range; 280 | Right : in Tash_Integer) 281 | return Tash_Integer; 282 | 283 | function "rem" 284 | (Left : in Tash_Integer; 285 | Right : in Tash_Integer) 286 | return Tash_Integer; 287 | 288 | function "rem" 289 | (Left : in Tash_Integer; 290 | Right : in Tash_Integer_Range) 291 | return Tash_Integer; 292 | 293 | function "rem" 294 | (Left : in Tash_Integer_Range; 295 | Right : in Tash_Integer) 296 | return Tash_Integer; 297 | 298 | function "mod" 299 | (Left : in Tash_Integer; 300 | Right : in Tash_Integer) 301 | return Tash_Integer; 302 | 303 | function "mod" 304 | (Left : in Tash_Integer; 305 | Right : in Tash_Integer_Range) 306 | return Tash_Integer; 307 | 308 | function "mod" 309 | (Left : in Tash_Integer_Range; 310 | Right : in Tash_Integer) 311 | return Tash_Integer; 312 | 313 | function "**" 314 | (Left : in Tash_Integer; 315 | Right : in Natural) 316 | return Tash_Integer; 317 | 318 | private 319 | 320 | Null_Tash_Integer : constant Tash_Integer := 321 | (Ada.Finalization.Controlled with 322 | Obj => null); 323 | 324 | Verbose : Boolean := False; 325 | 326 | end Tash.Integers; 327 | -------------------------------------------------------------------------------- /src/tash-platform.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.Platform body 4 | -- 5 | -- File Name: tash-platform.adb 6 | -- 7 | -- Purpose: Provides objects and subprograms that access Tash 8 | -- (really, Tcl) platform information. 9 | -- 10 | -- Copyright (c) 2000 Terry J. Westley 11 | -- 12 | -- Tash is free software; you can redistribute it and/or modify it under 13 | -- terms of the GNU General Public License as published by the Free 14 | -- Software Foundation; either version 2, or (at your option) any later 15 | -- version. Tash is distributed in the hope that it will be useful, but 16 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 18 | -- for more details. You should have received a copy of the GNU General 19 | -- Public License distributed with Tash; see file COPYING. If not, write to 20 | -- 21 | -- Free Software Foundation 22 | -- 59 Temple Place - Suite 330 23 | -- Boston, MA 02111-1307, USA 24 | -- 25 | -- As a special exception, if other files instantiate generics from this 26 | -- unit, or you link this unit with other files to produce an executable, 27 | -- this unit does not by itself cause the resulting executable to be 28 | -- covered by the GNU General Public License. This exception does not 29 | -- however invalidate any other reasons why the executable file might be 30 | -- covered by the GNU Public License. 31 | -- 32 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 33 | -- 34 | -------------------------------------------------------------------- 35 | 36 | with Tcl.Ada; 37 | 38 | package body Tash.Platform is 39 | 40 | function Byte_Order return String is 41 | Interp : Tcl.Tcl_Interp; 42 | begin -- Byte_Order 43 | Tash_Interp.Get (Interp); 44 | declare 45 | Result : constant String := 46 | Tcl.Ada.Tcl_GetVar2 (Interp, "tcl_platform", "byteOrder"); 47 | begin 48 | Tash_Interp.Release (Interp); 49 | return Result; 50 | end; 51 | end Byte_Order; 52 | 53 | function Machine return String is 54 | Interp : Tcl.Tcl_Interp; 55 | begin -- Machine 56 | Tash_Interp.Get (Interp); 57 | declare 58 | Result : constant String := 59 | Tcl.Ada.Tcl_GetVar2 (Interp, "tcl_platform", "machine"); 60 | begin 61 | Tash_Interp.Release (Interp); 62 | return Result; 63 | end; 64 | end Machine; 65 | 66 | function OS return String is 67 | Interp : Tcl.Tcl_Interp; 68 | begin -- OS 69 | Tash_Interp.Get (Interp); 70 | declare 71 | Result : constant String := 72 | Tcl.Ada.Tcl_GetVar2 (Interp, "tcl_platform", "os"); 73 | begin 74 | Tash_Interp.Release (Interp); 75 | return Result; 76 | end; 77 | end OS; 78 | 79 | function OS_Version return String is 80 | Interp : Tcl.Tcl_Interp; 81 | begin -- OS_Version 82 | Tash_Interp.Get (Interp); 83 | declare 84 | Result : constant String := 85 | Tcl.Ada.Tcl_GetVar2 (Interp, "tcl_platform", "osVersion"); 86 | begin 87 | Tash_Interp.Release (Interp); 88 | return Result; 89 | end; 90 | end OS_Version; 91 | 92 | function Platform return String is 93 | Interp : Tcl.Tcl_Interp; 94 | begin -- Platform 95 | Tash_Interp.Get (Interp); 96 | declare 97 | Result : constant String := 98 | Tcl.Ada.Tcl_GetVar2 (Interp, "tcl_platform", "platform"); 99 | begin 100 | Tash_Interp.Release (Interp); 101 | return Result; 102 | end; 103 | end Platform; 104 | 105 | function User return String is 106 | Interp : Tcl.Tcl_Interp; 107 | begin -- User 108 | Tash_Interp.Get (Interp); 109 | declare 110 | Result : constant String := 111 | Tcl.Ada.Tcl_GetVar2 (Interp, "tcl_platform", "user"); 112 | begin 113 | Tash_Interp.Release (Interp); 114 | return Result; 115 | end; 116 | end User; 117 | 118 | end Tash.Platform; 119 | -------------------------------------------------------------------------------- /src/tash-platform.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.Platform spec 4 | -- 5 | -- File Name: tash-platform.ads 6 | -- 7 | -- Purpose: Provides objects and subprograms that access Tash 8 | -- (really, Tcl) platform information. 9 | -- 10 | -- Copyright (c) 2000 Terry J. Westley 11 | -- 12 | -- Tash is free software; you can redistribute it and/or modify it under 13 | -- terms of the GNU General Public License as published by the Free 14 | -- Software Foundation; either version 2, or (at your option) any later 15 | -- version. Tash is distributed in the hope that it will be useful, but 16 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 18 | -- for more details. You should have received a copy of the GNU General 19 | -- Public License distributed with Tash; see file COPYING. If not, write to 20 | -- 21 | -- Free Software Foundation 22 | -- 59 Temple Place - Suite 330 23 | -- Boston, MA 02111-1307, USA 24 | -- 25 | -- As a special exception, if other files instantiate generics from this 26 | -- unit, or you link this unit with other files to produce an executable, 27 | -- this unit does not by itself cause the resulting executable to be 28 | -- covered by the GNU General Public License. This exception does not 29 | -- however invalidate any other reasons why the executable file might be 30 | -- covered by the GNU Public License. 31 | -- 32 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 33 | -- 34 | -------------------------------------------------------------------- 35 | 36 | package Tash.Platform is 37 | 38 | function Byte_Order return String; 39 | function Machine return String; 40 | function OS return String; 41 | function OS_Version return String; 42 | function Platform return String; 43 | function User return String; 44 | 45 | end Tash.Platform; 46 | -------------------------------------------------------------------------------- /src/tash-system.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.System body 4 | -- 5 | -- File Name: tash-system.adb 6 | -- 7 | -- Purpose: Provides objects and subprograms that access Tash 8 | -- (really, Tcl) system information: 9 | -- 10 | -- - process id of the current process 11 | -- - platform information 12 | -- 13 | -- Copyright (c) 2000 Terry J. Westley 14 | -- 15 | -- Tash is free software; you can redistribute it and/or modify it under 16 | -- terms of the GNU General Public License as published by the Free 17 | -- Software Foundation; either version 2, or (at your option) any later 18 | -- version. Tash is distributed in the hope that it will be useful, but 19 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 20 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 21 | -- for more details. You should have received a copy of the GNU General 22 | -- Public License distributed with Tash; see file COPYING. If not, write to 23 | -- 24 | -- Free Software Foundation 25 | -- 59 Temple Place - Suite 330 26 | -- Boston, MA 02111-1307, USA 27 | -- 28 | -- As a special exception, if other files instantiate generics from this 29 | -- unit, or you link this unit with other files to produce an executable, 30 | -- this unit does not by itself cause the resulting executable to be 31 | -- covered by the GNU General Public License. This exception does not 32 | -- however invalidate any other reasons why the executable file might be 33 | -- covered by the GNU Public License. 34 | -- 35 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 36 | -- 37 | -------------------------------------------------------------------- 38 | 39 | with CHelper; 40 | with System; 41 | 42 | package body Tash.System is 43 | 44 | use type Interfaces.C.int; 45 | 46 | function Tcl_PidObjCmd 47 | (dummy : in Tcl.ClientData; 48 | interp : in Tcl.Tcl_Interp; 49 | objc : in Interfaces.C.int; 50 | objv : in Tcl.Tcl_Obj_Array) 51 | return Interfaces.C.int; 52 | pragma Import (C, Tcl_PidObjCmd, "Tcl_PidObjCmd"); 53 | 54 | function Pid return Process_ID is 55 | Objc : constant Interfaces.C.int := 1; 56 | Objv : Tcl.Tcl_Obj_Array (1 .. Objc); 57 | Result : Interfaces.C.int; 58 | Interp : Tcl.Tcl_Interp; 59 | 60 | begin -- Pid 61 | 62 | -- Use Tcl_PidObjCmd to get the process id of the current process 63 | ----------------------------------------------------------------- 64 | Objv (1) := Tash.To_Tcl_Obj ("pid"); 65 | Tash_Interp.Get (Interp); 66 | Tcl.Tcl_ResetResult (Interp); 67 | Result := 68 | Tcl_PidObjCmd 69 | (dummy => Standard.System.Null_Address, 70 | interp => Interp, 71 | objc => Objc, 72 | objv => Objv); 73 | for I in Objv'Range loop 74 | Tcl.Tcl_DecrRefCount (Objv (I)); 75 | end loop; 76 | 77 | -- Check for errors, get result from 78 | -- interpreter, and convert to an integer. 79 | ------------------------------------------ 80 | declare 81 | Result_String : constant String := 82 | CHelper.Value (Tcl.Tcl_GetStringResult (Interp)); 83 | begin 84 | if Result = Tcl.TCL_ERROR then 85 | Tash_Interp.Raise_Exception 86 | (Interp, 87 | Tash.Tcl_Error'Identity, 88 | Result_String); 89 | end if; 90 | Tcl.Tcl_ResetResult (Interp); 91 | Tash_Interp.Release (Interp); 92 | return Process_ID'Value (Result_String); 93 | end; 94 | 95 | end Pid; 96 | 97 | end Tash.System; 98 | -------------------------------------------------------------------------------- /src/tash-system.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash.System spec 4 | -- 5 | -- File Name: tash-system.ads 6 | -- 7 | -- Purpose: Provides objects and subprograms that access Tash 8 | -- (really, Tcl) system information: 9 | -- 10 | -- - process id of the current process 11 | -- 12 | -- Copyright (c) 2000 Terry J. Westley 13 | -- 14 | -- Tash is free software; you can redistribute it and/or modify it under 15 | -- terms of the GNU General Public License as published by the Free 16 | -- Software Foundation; either version 2, or (at your option) any later 17 | -- version. Tash is distributed in the hope that it will be useful, but 18 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 19 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 20 | -- for more details. You should have received a copy of the GNU General 21 | -- Public License distributed with Tash; see file COPYING. If not, write to 22 | -- 23 | -- Free Software Foundation 24 | -- 59 Temple Place - Suite 330 25 | -- Boston, MA 02111-1307, USA 26 | -- 27 | -- As a special exception, if other files instantiate generics from this 28 | -- unit, or you link this unit with other files to produce an executable, 29 | -- this unit does not by itself cause the resulting executable to be 30 | -- covered by the GNU General Public License. This exception does not 31 | -- however invalidate any other reasons why the executable file might be 32 | -- covered by the GNU Public License. 33 | -- 34 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 35 | -- 36 | -------------------------------------------------------------------- 37 | 38 | package Tash.System is 39 | 40 | type Process_ID is range -1 .. 2 ** 32 - 1; 41 | 42 | function Pid return Process_ID; 43 | -- Returns the process identifier of the current process. 44 | 45 | end Tash.System; 46 | -------------------------------------------------------------------------------- /src/tash.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash body 4 | -- 5 | -- File Name: tash.adb 6 | -- 7 | -- Purpose: This package is the root of a family of packages 8 | -- which implement a binding to Tcl. 9 | -- 10 | -- Copyright (c) 1999-2000 Terry J. Westley 11 | -- 12 | -- Tash is free software; you can redistribute it and/or modify it under 13 | -- terms of the GNU General Public License as published by the Free 14 | -- Software Foundation; either version 2, or (at your option) any later 15 | -- version. Tash is distributed in the hope that it will be useful, but 16 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 18 | -- for more details. You should have received a copy of the GNU General 19 | -- Public License distributed with Tash; see file COPYING. If not, write to 20 | -- 21 | -- Free Software Foundation 22 | -- 59 Temple Place - Suite 330 23 | -- Boston, MA 02111-1307, USA 24 | -- 25 | -- As a special exception, if other files instantiate generics from this 26 | -- unit, or you link this unit with other files to produce an executable, 27 | -- this unit does not by itself cause the resulting executable to be 28 | -- covered by the GNU General Public License. This exception does not 29 | -- however invalidate any other reasons why the executable file might be 30 | -- covered by the GNU Public License. 31 | -- 32 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 33 | -- 34 | -------------------------------------------------------------------- 35 | 36 | with Ada.Command_Line; 37 | with Ada.Tags; 38 | with Ada.Text_IO; 39 | with Ada.Strings.Fixed; 40 | with CHelper; 41 | with Interfaces.C.Strings; 42 | 43 | package body Tash is 44 | 45 | use type Interfaces.C.int; 46 | 47 | function Image (Num : in Integer) return String; 48 | function Image (Num : in Interfaces.C.int) return String; 49 | 50 | function Is_Null (TObject : in Tash_Object) return Boolean is 51 | use type Tcl.Tcl_Obj; 52 | begin -- Is_Null 53 | return TObject.Obj = null; 54 | end Is_Null; 55 | pragma Inline (Is_Null); 56 | 57 | procedure Finalize (Obj : in out Tcl.Tcl_Obj) is 58 | pragma Warnings (Off, Obj); -- logically in out 59 | use type Tcl.Tcl_Obj; 60 | begin -- Finalize 61 | if Obj /= null then 62 | if Tcl.Tcl_GetRefCount (Obj) > 0 then 63 | Tcl.Tcl_DecrRefCount (Obj); 64 | if Tash.Verbose then 65 | Ada.Text_IO.Put_Line ("Finalize: " & Internal_Rep (Obj)); 66 | end if; 67 | end if; 68 | end if; 69 | end Finalize; 70 | 71 | procedure Finalize (TObject : in out Tash_Object) is 72 | begin -- Finalize 73 | Finalize (TObject.Obj); 74 | end Finalize; 75 | 76 | procedure Adjust (TObject : in out Tash_Object) is 77 | use type Tcl.Tcl_Obj; 78 | begin -- Adjust 79 | if TObject.Obj /= null then 80 | Tcl.Tcl_IncrRefCount (TObject.Obj); 81 | if Tash.Verbose then 82 | Ada.Text_IO.Put_Line ("Adjust: " & Internal_Rep (TObject)); 83 | end if; 84 | end if; 85 | end Adjust; 86 | 87 | protected body Tash_Interp is 88 | 89 | entry Get (Interp : out Tcl.Tcl_Interp) when not Seized is 90 | begin -- Get 91 | -- Ada.Text_IO.Put_Line ("T.TI.Get"); 92 | Seized := True; 93 | Interp := Tcl_Interp; 94 | end Get; 95 | 96 | procedure Release (Interp : in Tcl.Tcl_Interp) is 97 | begin -- Release 98 | -- Ada.Text_IO.Put_Line ("T.TI.Release"); 99 | Seized := False; 100 | Tcl_Interp := Interp; 101 | end Release; 102 | 103 | procedure Assert 104 | (Interp : in Tcl.Tcl_Interp; 105 | Return_Code : in Interfaces.C.int; 106 | E : in Ada.Exceptions.Exception_Id) 107 | is 108 | begin -- Assert 109 | if Return_Code = Tcl.TCL_ERROR then 110 | Raise_Exception (Interp, E); 111 | end if; 112 | end Assert; 113 | 114 | procedure Raise_Exception 115 | (Interp : in Tcl.Tcl_Interp; 116 | E : in Ada.Exceptions.Exception_Id) 117 | is 118 | -- 119 | Result : constant String := 120 | CHelper.Value (Tcl.Tcl_GetStringResult (Interp)); 121 | begin -- Raise_Exception 122 | Seized := False; 123 | Tcl_Interp := Interp; 124 | Ada.Exceptions.Raise_Exception (E => E, Message => Result); 125 | end Raise_Exception; 126 | 127 | procedure Raise_Exception 128 | (Interp : in Tcl.Tcl_Interp; 129 | E : in Ada.Exceptions.Exception_Id; 130 | Message : in String) 131 | is 132 | begin -- Raise_Exception 133 | Seized := False; 134 | Tcl_Interp := Interp; 135 | Ada.Exceptions.Raise_Exception (E => E, Message => Message); 136 | end Raise_Exception; 137 | 138 | end Tash_Interp; 139 | 140 | function Type_Of (TObject : in Tash_Object'Class) return String is 141 | begin -- Type_Of 142 | return CHelper.Value (Tcl.Tcl_GetObjTypeName (TObject.Obj)); 143 | end Type_Of; 144 | pragma Inline (Type_Of); 145 | 146 | function Ref_Count (TObject : in Tash_Object'Class) return Natural is 147 | begin -- Ref_Count 148 | return Natural (Tcl.Tcl_GetRefCount (TObject.Obj)); 149 | end Ref_Count; 150 | pragma Inline (Ref_Count); 151 | 152 | procedure PrintObj (TObject : in Tash_Object'Class) is 153 | begin -- PrintObj 154 | Tcl.Tcl_PrintObj (TObject.Obj); 155 | end PrintObj; 156 | 157 | function Image (TObject : in Tcl.Tcl_Obj) return String is 158 | -- 159 | Length : aliased Interfaces.C.int; 160 | use type Tcl.Tcl_Obj; 161 | begin -- Image 162 | if TObject = null then 163 | return "NULL"; 164 | elsif Tcl.Tcl_GetRefCount (TObject) = 0 then 165 | return "FINALIZED"; 166 | else 167 | return CHelper.Value 168 | (Tcl.Tcl_GetStringFromObj (TObject, Length'Access)); 169 | end if; 170 | exception 171 | when Id : others => 172 | return Ada.Exceptions.Exception_Name (Id); 173 | end Image; 174 | 175 | function Image (Num : in Integer) return String is 176 | begin -- Image 177 | return Ada.Strings.Fixed.Trim 178 | (Source => Integer'Image (Num), 179 | Side => Ada.Strings.Left); 180 | end Image; 181 | 182 | function Image (Num : in Interfaces.C.int) return String is 183 | begin -- Image 184 | return Ada.Strings.Fixed.Trim 185 | (Source => Interfaces.C.int'Image (Num), 186 | Side => Ada.Strings.Left); 187 | end Image; 188 | pragma Inline (Image); 189 | 190 | function Internal_Rep (TObject : in Tash_Object) return String is 191 | begin -- Internal_Rep 192 | return "(s=""" & 193 | Image (TObject.Obj) & 194 | """ t=" & 195 | Type_Of (TObject) & 196 | " tag=" & 197 | Ada.Tags.External_Tag (Tash_Object'Tag) & 198 | " c=" & 199 | Image (Ref_Count (TObject)) & 200 | ")"; 201 | end Internal_Rep; 202 | 203 | function Internal_Rep (TObj : in Tcl.Tcl_Obj) return String is 204 | begin -- Internal_Rep 205 | return "(s=""" & 206 | Image (TObj) & 207 | """ t=" & 208 | CHelper.Value (Tcl.Tcl_GetObjTypeName (TObj)) & 209 | " c=" & 210 | Image (Tcl.Tcl_GetRefCount (TObj)) & 211 | ")"; 212 | end Internal_Rep; 213 | 214 | function To_Tcl_Obj (Str : in String) return Tcl.Tcl_Obj is 215 | C_Str : aliased Interfaces.C.char_array := Interfaces.C.To_C (Str); 216 | New_Obj : Tcl.Tcl_Obj; 217 | begin -- To_Tcl_Obj 218 | New_Obj := 219 | Tcl.Tcl_NewStringObj 220 | (Interfaces.C.Strings.To_Chars_Ptr (C_Str'Unchecked_Access), 221 | Interfaces.C.int (Str'Length)); 222 | Tcl.Tcl_IncrRefCount (New_Obj); 223 | return New_Obj; 224 | end To_Tcl_Obj; 225 | 226 | function To_Tcl_Obj (Num : in Integer) return Tcl.Tcl_Obj is 227 | begin -- To_Tcl_Obj 228 | return To_Tcl_Obj 229 | (Ada.Strings.Fixed.Trim 230 | (Source => Integer'Image (Num), 231 | Side => Ada.Strings.Left)); 232 | end To_Tcl_Obj; 233 | 234 | begin -- Tash 235 | 236 | -- Create and initialize the Tcl interpreter 237 | -------------------------------------------- 238 | declare 239 | Command_Name : constant String := 240 | Ada.Command_Line.Command_Name; 241 | Executable : aliased Interfaces.C.char_array := 242 | Interfaces.C.To_C (Command_Name); 243 | Local_Interp : Tcl.Tcl_Interp; 244 | begin 245 | 246 | -- Tcl needs to know the path name of the executable 247 | -- otherwise Tcl.Tcl_Init below will fail. 248 | ---------------------------------------------------- 249 | Tcl.Tcl_FindExecutable 250 | (Interfaces.C.Strings.To_Chars_Ptr (Executable'Unchecked_Access)); 251 | 252 | -- Create one Tcl interpreter 253 | ----------------------------- 254 | Tash_Interp.Get (Local_Interp); 255 | Local_Interp := Tcl.Tcl_CreateInterp; 256 | 257 | -- Initialize Tcl 258 | ----------------- 259 | if Tcl.Tcl_Init (Local_Interp) = Tcl.TCL_ERROR then 260 | Ada.Text_IO.Put_Line 261 | (Command_Name & 262 | ": Tcl_Init failed: " & 263 | CHelper.Value (Tcl.Tcl_GetStringResult (Local_Interp))); 264 | Tash_Interp.Release (Local_Interp); 265 | Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); 266 | end if; 267 | 268 | Tash_Interp.Release (Local_Interp); 269 | 270 | end; 271 | 272 | end Tash; 273 | -------------------------------------------------------------------------------- /src/tash.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- Unit Name: Tash spec 4 | -- 5 | -- File Name: tash.ads 6 | -- 7 | -- Purpose: This package is the root of a family of packages 8 | -- which implement a binding to Tcl. Specifically, 9 | -- this package contains the parent Tash data type, 10 | -- Tash_Object. 11 | -- 12 | -- Copyright (c) 1999-2000 Terry J. Westley 13 | -- 14 | -- Tash is free software; you can redistribute it and/or modify it under 15 | -- terms of the GNU General Public License as published by the Free 16 | -- Software Foundation; either version 2, or (at your option) any later 17 | -- version. Tash is distributed in the hope that it will be useful, but 18 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 19 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 20 | -- for more details. You should have received a copy of the GNU General 21 | -- Public License distributed with Tash; see file COPYING. If not, write to 22 | -- 23 | -- Free Software Foundation 24 | -- 59 Temple Place - Suite 330 25 | -- Boston, MA 02111-1307, USA 26 | -- 27 | -- As a special exception, if other files instantiate generics from this 28 | -- unit, or you link this unit with other files to produce an executable, 29 | -- this unit does not by itself cause the resulting executable to be 30 | -- covered by the GNU General Public License. This exception does not 31 | -- however invalidate any other reasons why the executable file might be 32 | -- covered by the GNU Public License. 33 | -- 34 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 35 | -- 36 | -------------------------------------------------------------------- 37 | -- 38 | -- TASH is organized into the following packages: 39 | -- 40 | -- Package Name Purpose 41 | -- ------------ ------- 42 | -- Tash.Strings Defines the Tash string type and provides 43 | -- operations supporting string manipulation 44 | -- in the style of Ada.Strings packages. 45 | -- 46 | -- Tash.Integers Defines the Tash integer type. 47 | -- 48 | -- Tash.Floats Defines the Tash float type. 49 | -- 50 | -- Tash.Lists Defines the Tash list type which may 51 | -- contain any Tash object, including lists. 52 | -- 53 | -- Tash.Regexp Provides regular expression pattern matching 54 | -- for Tash and Ada strings. 55 | -- 56 | -- Tash.Format Provides C printf-style output formatting. 57 | -- 58 | -------------------------------------------------------------------- 59 | 60 | with Ada.Exceptions; 61 | with Ada.Finalization; 62 | with Interfaces.C; 63 | with Tcl; 64 | 65 | package Tash is 66 | 67 | Tcl_Error : exception; 68 | 69 | -------------------------------------------------------- 70 | -- Tash_Object is the base type of all Tash types. It is 71 | -- a tagged type and is controlled. The underlying Tcl 72 | -- object is reference counted. 73 | -------------------------------------------------------- 74 | 75 | type Tash_Object is abstract tagged private; 76 | 77 | -------------------------------------------------- 78 | -- Is_Null returns true if TObject has not yet been 79 | -- initialized (or has been set to a null Tash 80 | -- object such as Tash.Strings.Null_Tash_String). 81 | -- 82 | -- In other words, Is_Null is short-hand for 83 | -- Is_Uninitialized. 84 | -------------------------------------------------- 85 | 86 | function Is_Null (TObject : in Tash_Object) return Boolean; 87 | 88 | -------------------------------------------------------- 89 | -- All Tash objects (including integers, floats, and lists) 90 | -- have a string representation. To_String fetches the 91 | -- string representation of a Tash object. 92 | -- 93 | -- String representations are updated lazily, that is, only 94 | -- when needed. For example, as long as the string 95 | -- representation of a float is not fetched, it will not be 96 | -- maintained although many float operations may be performed 97 | -- and the value of the float changes many times. When the 98 | -- value of the float is changed, the internal string 99 | -- representation is marked as out of date. On the next call 100 | -- to fetch the string representation, it will be computed. 101 | -------------------------------------------------------- 102 | 103 | function To_String (TObject : in Tash_Object) return String is abstract; 104 | 105 | -------------------------------------------------------- 106 | -- Following are several subprograms for examining the 107 | -- internal representation of a Tash object. They are 108 | -- primarily used in verification of the Tash interface. 109 | -------------------------------------------------------- 110 | 111 | function Internal_Rep (TObject : in Tash_Object) return String; 112 | -- Returns an image of the internal representation, 113 | -- including the string representation, tag, and 114 | -- reference count. 115 | 116 | function Type_Of (TObject : in Tash_Object'Class) return String; 117 | -- Returns the underlying Tcl type of TObject. 118 | 119 | function Ref_Count (TObject : in Tash_Object'Class) return Natural; 120 | -- Returns the Tcl_Obj reference count. Returns 0 if TObject 121 | -- is not initialized (see Is_Null above). 122 | 123 | procedure PrintObj (TObject : in Tash_Object'Class); 124 | -- Calls Tcl.Tcl_PrintObj 125 | 126 | private 127 | 128 | type Tash_Object is abstract new Ada.Finalization.Controlled with record 129 | Obj : Tcl.Tcl_Obj; 130 | end record; 131 | 132 | procedure Finalize (Obj : in out Tcl.Tcl_Obj); 133 | procedure Finalize (TObject : in out Tash_Object); 134 | procedure Adjust (TObject : in out Tash_Object); 135 | 136 | protected Tash_Interp is 137 | 138 | entry Get (Interp : out Tcl.Tcl_Interp); 139 | -- Gets the Tcl interpreter reference and seizes 140 | -- a semaphore to guarantee sequentialized access. 141 | 142 | procedure Release (Interp : in Tcl.Tcl_Interp); 143 | -- Releases the interpreter semaphore. 144 | 145 | procedure Assert 146 | (Interp : in Tcl.Tcl_Interp; 147 | Return_Code : in Interfaces.C.int; 148 | E : in Ada.Exceptions.Exception_Id); 149 | -- Raises indicated exception if Return_Code = Tcl.TCL_ERROR. 150 | -- Uses the string result of Interp as the message. 151 | -- Releases the semaphore only if exception is raised. 152 | 153 | procedure Raise_Exception 154 | (Interp : in Tcl.Tcl_Interp; 155 | E : in Ada.Exceptions.Exception_Id); 156 | -- Raises indicated exception. 157 | -- Uses the string result of Interp as the message. 158 | -- Releases the semaphore only if exception is raised. 159 | 160 | procedure Raise_Exception 161 | (Interp : in Tcl.Tcl_Interp; 162 | E : in Ada.Exceptions.Exception_Id; 163 | Message : in String); 164 | -- Raises indicated exception. 165 | -- Releases the semaphore only if exception is raised. 166 | 167 | private 168 | 169 | Tcl_Interp : Tcl.Tcl_Interp; 170 | Seized : Boolean := False; 171 | 172 | pragma Inline (Release, Assert, Raise_Exception); 173 | 174 | end Tash_Interp; 175 | 176 | Verbose : Boolean := False; 177 | 178 | function Image (TObject : in Tcl.Tcl_Obj) return String; 179 | 180 | function Internal_Rep (TObj : in Tcl.Tcl_Obj) return String; 181 | 182 | function To_Tcl_Obj (Str : in String) return Tcl.Tcl_Obj; 183 | 184 | function To_Tcl_Obj (Num : in Integer) return Tcl.Tcl_Obj; 185 | 186 | end Tash; 187 | -------------------------------------------------------------------------------- /src/tcl-async.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- tcl-async.adb -- This package supports asynchronous setting of Tcl 4 | -- variables or array elements from Ada. 5 | -- 6 | -- Copyright (c) Simon Wright 7 | -- 8 | -- Tash is free software; you can redistribute it and/or modify it under 9 | -- terms of the GNU General Public License as published by the Free 10 | -- Software Foundation; either version 2, or (at your option) any later 11 | -- version. Tash is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 13 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 14 | -- for more details. You should have received a copy of the GNU General 15 | -- Public License distributed with Tash; see file COPYING. If not, write to 16 | -- 17 | -- Free Software Foundation 18 | -- 59 Temple Place - Suite 330 19 | -- Boston, MA 02111-1307, USA 20 | -- 21 | -- As a special exception, if other files instantiate generics from this 22 | -- unit, or you link this unit with other files to produce an executable, 23 | -- this unit does not by itself cause the resulting executable to be 24 | -- covered by the GNU General Public License. This exception does not 25 | -- however invalidate any other reasons why the executable file might be 26 | -- covered by the GNU Public License. 27 | -- 28 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 29 | -- 30 | -------------------------------------------------------------------- 31 | 32 | with Ada.Containers.Vectors; 33 | with Ada.Strings.Unbounded; 34 | with GNAT.Threads; 35 | with Interfaces.C.Strings; 36 | with System; 37 | 38 | package body Tcl.Async is 39 | 40 | -- This record holds a proposed update until the Tcl event loop is 41 | -- ready for it to be processed. 42 | type Update is record 43 | Variable : Standard.Ada.Strings.Unbounded.Unbounded_String; 44 | Index : Standard.Ada.Strings.Unbounded.Unbounded_String; 45 | Value : Standard.Ada.Strings.Unbounded.Unbounded_String; 46 | end record; 47 | 48 | -- Proposed updates are held in a Vector. 49 | package Update_Vectors is new Standard.Ada.Containers.Vectors (Positive, 50 | Update); 51 | 52 | -- Updates are proposed by Ada code which may be running in a 53 | -- separate thread from that used by the Tcl event loop. 54 | protected Update_Manager is 55 | 56 | -- Propose an update. 57 | procedure Set (New_Update : Update); 58 | 59 | -- Retrieve an update; blocks if there are none waiting. 60 | entry Get (New_Update : out Update); 61 | 62 | private 63 | -- The queue of proposed updates. 64 | Updates : Update_Vectors.Vector; 65 | end Update_Manager; 66 | 67 | protected body Update_Manager is 68 | 69 | procedure Set (New_Update : Update) 70 | is 71 | begin 72 | Updates.Append (New_Update); 73 | end Set; 74 | 75 | entry Get (New_Update : out Update) when Integer (Updates.Length) /= 0 76 | is 77 | begin 78 | New_Update := Updates.First_Element; 79 | Updates.Delete_First; 80 | end Get; 81 | 82 | end Update_Manager; 83 | 84 | -- Stores a token indicating the registered handler (which will be 85 | -- called when the Tcl event loop has been informed, by 86 | -- Tcl_AsyncMark(), that there is data to be procssed). 87 | Async_Handler : Tcl_AsyncHandler; 88 | 89 | -- Stores the Tcl Interpreter to be used if the Async Handler 90 | -- isn't given one. 91 | Default_Interpreter : Tcl_Interp; 92 | 93 | -- The handler to be registered. 94 | function Async_Proc (Dummy : ClientData; 95 | Interp : Tcl_Interp; 96 | Code : Interfaces.C.int) 97 | return Interfaces.C.int; 98 | pragma Convention (C, Async_Proc); 99 | 100 | procedure Register (Interp : Tcl_Interp) 101 | is 102 | pragma Assert (Async_Handler = null); 103 | begin 104 | -- We don't use any client data. 105 | Async_Handler := Tcl_AsyncCreate (proc => Async_Proc'Access, 106 | data => Null_ClientData); 107 | Default_Interpreter := Interp; 108 | end Register; 109 | 110 | procedure Set (Tcl_Variable : String; Value : String) 111 | is 112 | pragma Assert (Async_Handler /= null); 113 | use Standard.Ada.Strings.Unbounded; 114 | begin 115 | Update_Manager.Set ((Variable => To_Unbounded_String (Tcl_Variable), 116 | Index => Null_Unbounded_String, 117 | Value => To_Unbounded_String (Value))); 118 | -- Tell Tcl there's work to be done. 119 | Tcl_AsyncMark (Async_Handler); 120 | end Set; 121 | 122 | procedure Set (Tcl_Array : String; Index : String; Value : String) 123 | is 124 | pragma Assert (Async_Handler /= null); 125 | use Standard.Ada.Strings.Unbounded; 126 | begin 127 | Update_Manager.Set ((Variable => To_Unbounded_String (Tcl_Array), 128 | Index => To_Unbounded_String (Index), 129 | Value => To_Unbounded_String (Value))); 130 | -- Tell Tcl there's work to be done. 131 | Tcl_AsyncMark (Async_Handler); 132 | end Set; 133 | 134 | -- Called in the Tcl event loop's context to action the proposed 135 | -- updates. 136 | function Async_Proc 137 | (Dummy : ClientData; 138 | Interp : Tcl_Interp; 139 | Code : Interfaces.C.int) 140 | return Interfaces.C.int 141 | is 142 | pragma Unreferenced (Dummy); 143 | Next_Update : Update; 144 | Interpreter : Tcl_Interp := Interp; 145 | use Standard.Ada.Strings.Unbounded; 146 | use Interfaces.C, Interfaces.C.Strings; 147 | begin 148 | -- We may not be in a thread already registered with the Ada 149 | -- RTS; make it so. 150 | declare 151 | Ada_Id : System.Address; 152 | pragma Unreferenced (Ada_Id); 153 | begin 154 | Ada_Id := GNAT.Threads.Register_Thread; 155 | end; 156 | 157 | if Interpreter = null then 158 | Interpreter := Default_Interpreter; 159 | end if; 160 | 161 | -- We don't want to rely on there being as many calls of this 162 | -- procedure as there were Sets. 163 | loop 164 | 165 | select 166 | Update_Manager.Get (Next_Update); 167 | else 168 | -- There were no outstanding updates. 169 | exit; 170 | end select; 171 | 172 | if Length (Next_Update.Index) = 0 then 173 | -- We're setting a variable. 174 | declare 175 | C_Variable : aliased Interfaces.C.char_array 176 | := To_C (To_String (Next_Update.Variable)); 177 | C_Value : aliased Interfaces.C.char_array 178 | := To_C (To_String (Next_Update.Value)); 179 | Result : Interfaces.C.Strings.chars_ptr; 180 | pragma Unreferenced (Result); 181 | begin 182 | Result := 183 | Tcl_SetVar 184 | (Interpreter, 185 | To_Chars_Ptr (C_Variable'Unchecked_Access, 186 | Nul_Check => True), 187 | To_Chars_Ptr (C_Value'Unchecked_Access, 188 | Nul_Check => True), 189 | Tcl.TCL_GLOBAL_ONLY); 190 | -- What to do if Result is null (it failed)? 191 | end; 192 | else 193 | -- We're setting an array element. 194 | declare 195 | C_Variable : aliased Interfaces.C.char_array 196 | := To_C (To_String (Next_Update.Variable)); 197 | C_Index : aliased Interfaces.C.char_array 198 | := To_C (To_String (Next_Update.Index)); 199 | C_Value : aliased Interfaces.C.char_array 200 | := To_C (To_String (Next_Update.Value)); 201 | Result : Interfaces.C.Strings.chars_ptr; 202 | pragma Unreferenced (Result); 203 | begin 204 | Result := 205 | Tcl_SetVar2 206 | (Interpreter, 207 | To_Chars_Ptr (C_Variable'Unchecked_Access, 208 | Nul_Check => True), 209 | To_Chars_Ptr (C_Index'Unchecked_Access, 210 | Nul_Check => True), 211 | To_Chars_Ptr (C_Value'Unchecked_Access, 212 | Nul_Check => True), 213 | Tcl.TCL_GLOBAL_ONLY); 214 | -- What to do if Result is null (it failed)? 215 | end; 216 | end if; 217 | end loop; 218 | 219 | -- From the man page, "It is almost always a bad idea for an 220 | -- asynchronous event handler to modify interp->result or 221 | -- return a code different from its code argument." 222 | return Code; 223 | end Async_Proc; 224 | 225 | end Tcl.Async; 226 | -------------------------------------------------------------------------------- /src/tcl-async.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- tcl-async.ads -- This package supports asynchronous setting of Tcl 4 | -- variables or array elements from Ada. 5 | -- 6 | -- Copyright (c) Simon Wright 7 | -- 8 | -- Tash is free software; you can redistribute it and/or modify it under 9 | -- terms of the GNU General Public License as published by the Free 10 | -- Software Foundation; either version 2, or (at your option) any later 11 | -- version. Tash is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 13 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 14 | -- for more details. You should have received a copy of the GNU General 15 | -- Public License distributed with Tash; see file COPYING. If not, write to 16 | -- 17 | -- Free Software Foundation 18 | -- 59 Temple Place - Suite 330 19 | -- Boston, MA 02111-1307, USA 20 | -- 21 | -- As a special exception, if other files instantiate generics from this 22 | -- unit, or you link this unit with other files to produce an executable, 23 | -- this unit does not by itself cause the resulting executable to be 24 | -- covered by the GNU General Public License. This exception does not 25 | -- however invalidate any other reasons why the executable file might be 26 | -- covered by the GNU Public License. 27 | -- 28 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 29 | -- 30 | -------------------------------------------------------------------- 31 | 32 | package Tcl.Async is 33 | 34 | -- Must be called before any other subprogram in the package. 35 | procedure Register (Interp : Tcl_Interp); 36 | 37 | -- Called to set the named Tcl variable in the global scope to the 38 | -- given value. 39 | -- 40 | -- The variable will be created if necessary. 41 | procedure Set (Tcl_Variable : String; Value : String); 42 | 43 | -- Called to set the indexed element of the named Tcl array in 44 | -- the global scope to the given value. 45 | -- 46 | -- The array will be created if necessary. 47 | procedure Set (Tcl_Array : String; Index : String; Value : String); 48 | 49 | end Tcl.Async; 50 | -------------------------------------------------------------------------------- /src/tcl-tk.adb: -------------------------------------------------------------------------------- 1 | -- This package implements the "thin" binding to Tcl.Tk. 2 | -- 3 | -- Copyright (C) 2019 Simon Wright 4 | -- Tash is free software; you can redistribute it and/or modify it under 5 | -- terms of the GNU General Public License as published by the Free 6 | -- Software Foundation; either version 2, or (at your option) any later 7 | -- version. Tash is distributed in the hope that it will be useful, but 8 | -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 9 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 10 | -- for more details. You should have received a copy of the GNU General 11 | -- Public License distributed with Tash; see file COPYING. If not, write to 12 | -- 13 | -- Free Software Foundation 14 | -- 59 Temple Place - Suite 330 15 | -- Boston, MA 02111-1307, USA 16 | -- 17 | -- As a special exception, if other files instantiate generics from this 18 | -- unit, or you link this unit with other files to produce an executable, 19 | -- this unit does not by itself cause the resulting executable to be 20 | -- covered by the GNU General Public License. This exception does not 21 | -- however invalidate any other reasons why the executable file might be 22 | -- covered by the GNU Public License. 23 | -- 24 | -- Tash is maintained at http://tcladashell.sourceforge.net/. 25 | -- 26 | -------------------------------------------------------------------- 27 | 28 | package body Tcl.Tk is 29 | 30 | -- The subprograms here correspond to C macros. C functions are 31 | -- provided to invoke the macros. However, only Ada units can form 32 | -- part of the public interface of the library, and what where 33 | -- global symbols in the other units (including C units) are 34 | -- converted to local symbols and hence not visible to callers. 35 | -- 36 | -- So we have to call the C functions from Ada code, rather than 37 | -- having pragma Import in the package spec. 38 | 39 | function Tk_PathName 40 | (tkwin : not null Tk_Window) return C.Strings.chars_ptr is 41 | function Tk_CallPathName 42 | (tkwin : not null Tk_Window) return C.Strings.chars_ptr; 43 | pragma Import (C, Tk_CallPathName, "Tk_CallPathName"); 44 | begin 45 | return Tk_CallPathName (tkwin); 46 | end Tk_PathName; 47 | 48 | procedure Tk_Main 49 | (argc : C.int; 50 | argv : CArgv.Chars_Ptr_Ptr; 51 | proc : not null Tcl_AppInitProc) is 52 | procedure Tk_CallMain 53 | (argc : C.int; 54 | argv : CArgv.Chars_Ptr_Ptr; 55 | proc : not null Tcl_AppInitProc); 56 | pragma Import (C, Tk_CallMain, "Tk_CallMain"); 57 | begin 58 | Tk_CallMain (argc, argv, proc); 59 | end Tk_Main; 60 | 61 | end Tcl.Tk; 62 | -------------------------------------------------------------------------------- /src/tcl_backward_compatibility_glue.c: -------------------------------------------------------------------------------- 1 | /* 2 | * tcl_backward_compatibility_glue.c -- 3 | * 4 | * This file furnishes functions required for Tcl-8.4 that emulate 5 | * the functions of newer Tcl versions. 6 | * 7 | * Copyright (c) 2008 Oliver Kellogg 8 | * 9 | * Tash is free software; you can redistribute it and/or modify it 10 | * under terms of the GNU General Public License as published by the 11 | * Free Software Foundation; either version 2, or (at your option) 12 | * any later version. Tash is distributed in the hope that it will be 13 | * useful, but WITHOUT ANY WARRANTY; without even the implied 14 | * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 15 | * PURPOSE. See the GNU General Public License for more details. You 16 | * should have received a copy of the GNU General Public License 17 | * distributed with Tash; see file COPYING. If not, write to 18 | * 19 | * Free Software Foundation 20 | * 59 Temple Place - Suite 330 21 | * Boston, MA 02111-1307, USA 22 | * 23 | * As a special exception, if other files instantiate generics from 24 | * this unit, or you link this unit with other files to produce an 25 | * executable, this unit does not by itself cause the resulting 26 | * executable to be covered by the GNU General Public License. This 27 | * exception does not however invalidate any other reasons why the 28 | * executable file might be covered by the GNU Public License. 29 | */ 30 | 31 | #include 32 | #include 33 | 34 | #if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 5) 35 | 36 | int 37 | TclInfoExistsCmd 38 | (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) 39 | { 40 | Tcl_Obj *inner_objv[3]; 41 | inner_objv[0] = Tcl_NewStringObj("info", -1); 42 | inner_objv[1] = objv[0]; 43 | inner_objv[2] = objv[1]; 44 | return Tcl_InfoObjCmd(dummy, interp, 3, inner_objv); 45 | } 46 | 47 | #endif 48 | 49 | -------------------------------------------------------------------------------- /src/tcl_record_sizes.gpr: -------------------------------------------------------------------------------- 1 | -- This project generates an executable which, when run, will create 2 | -- the Ada spec tcl_record_sizes.ads, using the sizes determined by 3 | -- the C program tcl_record_sizes.c when built against the system 4 | -- Tcl/Tk libraries. 5 | -- tcl_record_sizes.c is built by the script tcl_record_sizes.tcl. 6 | 7 | with "../tcl_tk_options.gpr"; 8 | 9 | project Tcl_Record_Sizes is 10 | 11 | for Languages use ("c"); 12 | 13 | for Main use ("tcl_record_sizes.c"); 14 | 15 | for Source_Files use ("tcl_record_sizes.c"); 16 | for Object_Dir use ".build"; 17 | for Create_Missing_Dirs use "true"; 18 | for Exec_Dir use "."; 19 | 20 | package Compiler is 21 | for Default_Switches ("c") use Tcl_Tk_Options.C_Compiler_Switches; 22 | end Compiler; 23 | 24 | package Linker is 25 | for Linker_Options use Tcl_Tk_Options.Platform_Linker_Options; 26 | end Linker; 27 | 28 | end Tcl_Record_Sizes; 29 | -------------------------------------------------------------------------------- /src/tcl_record_sizes.tcl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #\ 3 | exec tclsh $0 $@ 4 | 5 | # Copyright (C) Simon Wright 6 | 7 | # $Id$ 8 | # 9 | # Tash is free software; you can redistribute it and/or modify it 10 | # under terms of the GNU General Public License as published by the 11 | # Free Software Foundation; either version 2, or (at your option) any 12 | # later version. Tash is distributed in the hope that it will be 13 | # useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | # of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | # General Public License for more details. You should have received a 16 | # copy of the GNU General Public License distributed with Tash; see 17 | # file COPYING. If not, write to 18 | # 19 | # Free Software Foundation 20 | # 59 Temple Place - Suite 330 21 | # Boston, MA 02111-1307, USA 22 | 23 | # Used during configuration to determine sizes of various structs 24 | # whose contents are "private" (or would be, if C supported it!) 25 | 26 | puts -nonewline {/* 27 | * Tash is free software; you can redistribute it and/or modify it 28 | * under terms of the GNU General Public License as published by the 29 | * Free Software Foundation; either version 2, or (at your option) 30 | * any later version. Tash is distributed in the hope that it will be 31 | * useful, but WITHOUT ANY WARRANTY; without even the implied 32 | * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 33 | * PURPOSE. See the GNU General Public License for more details. You 34 | * should have received a copy of the GNU General Public License 35 | * distributed with Tash; see file COPYING. If not, write to 36 | * 37 | * Free Software Foundation 38 | * 59 Temple Place - Suite 330 39 | * Boston, MA 02111-1307, USA 40 | */ 41 | 42 | /* 43 | * Created during configuration. Determines sizes of various structs whose 44 | * contents are "private" (or would be, if C supported it!) 45 | */ 46 | 47 | #include 48 | #include 49 | #include 50 | 51 | #define TYPE_ALIGNMENT(t) offsetof(struct { char x; t test; }, test) 52 | 53 | int main() 54 | } 55 | 56 | puts -nonewline "{" 57 | 58 | # front matter 59 | puts -nonewline { 60 | printf("-- Tash is free software; you can redistribute it and/or modify it\n"); 61 | printf("-- under terms of the GNU General Public License as published by the\n"); 62 | printf("-- Free Software Foundation; either version 2, or (at your option)\n"); 63 | printf("-- any later version. Tash is distributed in the hope that it will be\n"); 64 | printf("-- useful, but WITHOUT ANY WARRANTY; without even the implied\n"); 65 | printf("-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\n"); 66 | printf("-- PURPOSE. See the GNU General Public License for more details. You\n"); 67 | printf("-- should have received a copy of the GNU General Public License\n"); 68 | printf("-- distributed with Tash; see file COPYING. If not, write to\n"); 69 | printf("--\n"); 70 | printf("-- Free Software Foundation\n"); 71 | printf("-- 59 Temple Place - Suite 330\n"); 72 | printf("-- Boston, MA 02111-1307, USA\n"); 73 | printf("--\n"); 74 | printf("-- As a special exception, if other files instantiate generics from this\n"); 75 | printf("-- unit, or you link this unit with other files to produce an executable,\n"); 76 | printf("-- this unit does not by itself cause the resulting executable to be\n"); 77 | printf("-- covered by the GNU General Public License. This exception does not\n"); 78 | printf("-- however invalidate any other reasons why the executable file might be\n"); 79 | printf("-- covered by the GNU Public License.\n"); 80 | printf("\n"); 81 | printf("package Tcl_Record_Sizes is\n"); 82 | } 83 | 84 | # Macros defined in tcl.h 85 | 86 | puts -nonewline { 87 | printf("\n"); 88 | printf(" -- Size macros defined in tcl.h.\n"); 89 | } 90 | 91 | foreach {m} { 92 | NUM_STATIC_TOKENS 93 | TCL_DSTRING_STATIC_SIZE 94 | } { 95 | puts -nonewline " 96 | printf(\"\\n\"); 97 | printf(\" ${m} : constant := %d;\\n\", 98 | ${m});" 99 | } 100 | 101 | # Sizes, alignments of structs 102 | 103 | puts -nonewline { 104 | printf("\n"); 105 | printf(" -- Sizes of structs defined in tcl.h.\n"); 106 | } 107 | 108 | foreach {s} { 109 | Tcl_CallFrame 110 | Tcl_HashTable 111 | Tcl_HashSearch 112 | Tcl_Interp 113 | Tcl_SavedResult 114 | } { 115 | puts -nonewline " 116 | printf(\"\\n\"); 117 | printf(\" ${s}_Size : constant := %d;\\n\", 118 | sizeof(struct ${s})); 119 | printf(\" ${s}_Alignment : constant := %d;\\n\", 120 | TYPE_ALIGNMENT(struct ${s})); 121 | " 122 | } 123 | 124 | # Closing 125 | 126 | puts -nonewline { 127 | printf("\n"); 128 | printf("end Tcl_Record_Sizes;\n"); 129 | return 0; 130 | } 131 | 132 | puts "}" 133 | -------------------------------------------------------------------------------- /src/tclmacro.c: -------------------------------------------------------------------------------- 1 | /* 2 | * tclmacro.c -- 3 | * 4 | * This file encapsulates calls to all tcl.h macro functions into C 5 | * function calls. These can then be called from Ada. This avoids 6 | * having to translate the macro. 7 | * 8 | * Copyright (c) 1999-2000 Terry J. Westley 9 | * 10 | * Tash is free software; you can redistribute it and/or modify it 11 | * under terms of the GNU General Public License as published by the 12 | * Free Software Foundation; either version 2, or (at your option) 13 | * any later version. Tash is distributed in the hope that it will be 14 | * useful, but WITHOUT ANY WARRANTY; without even the implied 15 | * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 16 | * PURPOSE. See the GNU General Public License for more details. You 17 | * should have received a copy of the GNU General Public License 18 | * distributed with Tash; see file COPYING. If not, write to 19 | * 20 | * Free Software Foundation 21 | * 59 Temple Place - Suite 330 22 | * Boston, MA 02111-1307, USA 23 | * 24 | * As a special exception, if other files instantiate generics from 25 | * this unit, or you link this unit with other files to produce an 26 | * executable, this unit does not by itself cause the resulting 27 | * executable to be covered by the GNU General Public License. This 28 | * exception does not however invalidate any other reasons why the 29 | * executable file might be covered by the GNU Public License. 30 | */ 31 | 32 | #if 0 33 | #define __CYGWIN__ 34 | #endif 35 | 36 | #include 37 | #include 38 | 39 | int Tcl_CallIncrRefCount (struct Tcl_Obj *objPtr) 40 | { 41 | return Tcl_IncrRefCount (objPtr); 42 | } 43 | 44 | void Tcl_CallDecrRefCount (struct Tcl_Obj *objPtr) 45 | { 46 | Tcl_DecrRefCount (objPtr); 47 | } 48 | 49 | int Tcl_CallIsShared (struct Tcl_Obj *objPtr) 50 | { 51 | return Tcl_IsShared (objPtr); 52 | } 53 | 54 | ClientData Tcl_CallGetHashValue (Tcl_HashEntry *h) 55 | { 56 | return Tcl_GetHashValue (h); 57 | } 58 | 59 | void Tcl_CallSetHashValue (Tcl_HashEntry *h, ClientData value) 60 | { 61 | Tcl_SetHashValue (h, value); 62 | } 63 | 64 | char *Tcl_CallGetHashKey (Tcl_HashTable *tablePtr, Tcl_HashEntry *h) 65 | { 66 | return Tcl_GetHashKey (tablePtr, h); 67 | } 68 | 69 | Tcl_HashEntry *Tcl_CallFindHashEntry (Tcl_HashTable *tablePtr, char *key) 70 | { 71 | return Tcl_FindHashEntry (tablePtr, key); 72 | } 73 | 74 | Tcl_HashEntry *Tcl_CallCreateHashEntry 75 | (Tcl_HashTable *tablePtr, char *key, int *newPtr) 76 | { 77 | return Tcl_CreateHashEntry (tablePtr, key, newPtr); 78 | } 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /src/tkmacro.c: -------------------------------------------------------------------------------- 1 | /* 2 | * tkmacro.c -- 3 | * 4 | * This file encapsulates calls to all tk.h macro functions into C 5 | * function calls. These can then be called from Ada. This avoids 6 | * having to translate the macro. 7 | * 8 | * Copyright (c) 1999-2000 Terry J. Westley 9 | * 10 | * Tash is free software; you can redistribute it and/or modify it 11 | * under terms of the GNU General Public License as published by the 12 | * Free Software Foundation; either version 2, or (at your option) 13 | * any later version. Tash is distributed in the hope that it will be 14 | * useful, but WITHOUT ANY WARRANTY; without even the implied 15 | * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 16 | * PURPOSE. See the GNU General Public License for more details. You 17 | * should have received a copy of the GNU General Public License 18 | * distributed with Tash; see file COPYING. If not, write to 19 | * 20 | * Free Software Foundation 21 | * 59 Temple Place - Suite 330 22 | * Boston, MA 02111-1307, USA 23 | * 24 | * As a special exception, if other files instantiate generics from 25 | * this unit, or you link this unit with other files to produce an 26 | * executable, this unit does not by itself cause the resulting 27 | * executable to be covered by the GNU General Public License. This 28 | * exception does not however invalidate any other reasons why the 29 | * executable file might be covered by the GNU Public License. 30 | */ 31 | 32 | #if 0 33 | #define __CYGWIN__ 34 | #endif 35 | 36 | #include 37 | 38 | char * Tk_CallPathName (Tk_Window tkwin) 39 | { 40 | return Tk_PathName (tkwin); 41 | } 42 | 43 | void Tk_CallMain (int argc, char **argv, Tcl_AppInitProc *proc) 44 | { 45 | Tk_MainEx (argc, argv, proc, Tcl_CreateInterp()); 46 | } 47 | -------------------------------------------------------------------------------- /tash.gpr: -------------------------------------------------------------------------------- 1 | -- Copyright (C) Simon Wright 2 | 3 | -- This package is free software; you can redistribute it and/or 4 | -- modify it under terms of the GNU General Public License as 5 | -- published by the Free Software Foundation; either version 2, or 6 | -- (at your option) any later version. This package is distributed in 7 | -- the hope that it will be useful, but WITHOUT ANY WARRANTY; without 8 | -- even the implied warranty of MERCHANTABILITY or FITNESS FOR A 9 | -- PARTICULAR PURPOSE. See the GNU General Public License for more 10 | -- details. You should have received a copy of the GNU General Public 11 | -- License distributed with this package; see file COPYING. If not, 12 | -- write to the Free Software Foundation, 59 Temple Place - Suite 13 | -- 330, Boston, MA 02111-1307, USA. 14 | 15 | with "tcl_tk_options.gpr"; 16 | with "config/tash_config.gpr"; 17 | 18 | project Tash is 19 | 20 | type Library_T is ("static", "relocatable"); 21 | Library_Type : Library_T := 22 | external ("TASH_LIBRARY_TYPE", external ("LIBRARY_TYPE", "static")); 23 | 24 | for Library_Name use "tash"; 25 | 26 | for Languages use ("ada", "c"); 27 | 28 | -- type Answer is ("no", "yes"); 29 | -- Supports_Tash : Answer := "no"; 30 | 31 | for Source_Dirs use ("src"); 32 | 33 | Ada_Source_Files := 34 | ( 35 | "cargv.adb", 36 | "cargv.ads", 37 | "chelper.adb", 38 | "chelper.ads", 39 | "tcl-ada.adb", 40 | "tcl-ada.ads", 41 | "tcl-async.adb", 42 | "tcl-async.ads", 43 | "tcl-tk-ada.adb", 44 | "tcl-tk-ada.ads", 45 | "tcl-tk.adb", 46 | "tcl-tk.ads", 47 | "tcl.adb", 48 | "tcl.ads", 49 | "tcl_record_sizes.ads" 50 | ); 51 | 52 | Source_Units := 53 | ( 54 | "Cargv", 55 | "Chelper", 56 | "Tcl.Ada", 57 | "Tcl.Async", 58 | "Tcl.Tk.Ada", 59 | "Tcl.Tk", 60 | "Tcl", 61 | "Tcl_Record_Sizes" 62 | ); 63 | 64 | C_Source_Files := 65 | ( 66 | "tclmacro.c", 67 | "tkmacro.c" 68 | ); 69 | 70 | for Source_Files use 71 | Ada_Source_Files & C_Source_Files; 72 | 73 | for Object_Dir use ".build_lib-" & Library_Type; 74 | for Library_Kind use Library_Type; 75 | for Library_Dir use "lib-" & Library_Type; 76 | for Library_Src_Dir use "include-" & Library_Type; 77 | 78 | case Library_Type is 79 | when "relocatable" => 80 | for Library_Interface use Source_Units; 81 | for Library_Options use Tcl_Tk_Options.Platform_Linker_Options; 82 | when "static" => 83 | null; 84 | end case; 85 | 86 | package Compiler is 87 | for Default_Switches ("ada") use Tash_Config.Ada_Compiler_Switches; 88 | for Default_Switches ("c") use Tcl_Tk_Options.C_Compiler_Switches; 89 | end Compiler; 90 | 91 | package Linker is 92 | for Linker_Options use Tcl_Tk_Options.Platform_Linker_Options; 93 | end Linker; 94 | 95 | -- Pretty printer (useful with GPS while reformatting the code to 96 | -- avoid style & other warnings). 97 | package Pretty_Printer is 98 | for Default_Switches ("ada") use ("-l2", "-c3"); 99 | end Pretty_Printer; 100 | 101 | end Tash; 102 | -------------------------------------------------------------------------------- /tcl_tk_options.gpr: -------------------------------------------------------------------------------- 1 | -- Copyright (C) Simon Wright 2 | 3 | -- This package is free software; you can redistribute it and/or 4 | -- modify it under terms of the GNU General Public License as 5 | -- published by the Free Software Foundation; either version 2, or 6 | -- (at your option) any later version. This package is distributed in 7 | -- the hope that it will be useful, but WITHOUT ANY WARRANTY; without 8 | -- even the implied warranty of MERCHANTABILITY or FITNESS FOR A 9 | -- PARTICULAR PURPOSE. See the GNU General Public License for more 10 | -- details. You should have received a copy of the GNU General Public 11 | -- License distributed with this package; see file COPYING. If not, 12 | -- write to the Free Software Foundation, 59 Temple Place - Suite 13 | -- 330, Boston, MA 02111-1307, USA. 14 | 15 | -- This file is used to define the architecture-dependent compilation 16 | -- and linking options for building src/tcl_record_sizes.ads and for 17 | -- the tash library itself (the first has to be built before the 18 | -- second). 19 | 20 | abstract project Tcl_Tk_Options is 21 | 22 | type Platform_Type is ("linux", "macos", "windows"); 23 | Platform : Platform_Type := external ("TASH_PLATFORM", "linux"); 24 | 25 | C_Compiler_Switches := (); 26 | Include_Prefix := ""; 27 | 28 | case Platform is 29 | when "linux" => 30 | -- I'd prefer to get CFLAGS from `pkg-config --cflags 31 | -- tk8.6`, but can't work out how. 32 | C_Compiler_Switches := C_Compiler_Switches 33 | & ("-I/usr/include/tcl8.6"); 34 | -- & external_as_list ("CFLAGS", " "); 35 | 36 | when "macos" => 37 | -- Prior to https://github.com/Homebrew/homebrew-core/pull/124056, 38 | -- tcl-tk was "keg-only" which meant it couldn't be found on the 39 | -- standard include path ($HOMEBREW_PREFIX/include); however, you 40 | -- can always find an installed package in $HOMEBREW_PREFIX/opt. 41 | -- The change above moves the tcl-tk includes down a level, so 42 | -- here we include both; one of them should work! 43 | Include_Prefix := external ("HOMEBREW_PREFIX", "") 44 | & "/opt/tcl-tk/include"; 45 | C_Compiler_Switches := C_Compiler_Switches & 46 | ( 47 | "-I" & Include_Prefix, 48 | "-I" & Include_Prefix & "/tcl-tk" 49 | ); 50 | 51 | when "windows" => 52 | null; 53 | end case; 54 | 55 | Platform_Linker_Options := (); 56 | case Platform is 57 | when "linux" => 58 | -- I'd prefer to get LDFLAGS from `pkg-config --libs 59 | -- tk8.6`, but can't work out how. 60 | Platform_Linker_Options := Platform_Linker_Options & 61 | ("-ltk8.6", "-ltkstub8.6", "-ltcl8.6", "-ltclstub8.6"); 62 | 63 | when "macos" => 64 | Platform_Linker_Options := Platform_Linker_Options & 65 | ( 66 | "-L" & external ("HOMEBREW_PREFIX", "") & "/opt/tcl-tk/lib", 67 | "-L/usr/local/include", -- Github CI 68 | "-ltk8.6", 69 | "-ltcl8.6" 70 | ); 71 | 72 | when "windows" => 73 | Platform_Linker_Options := Platform_Linker_Options & 74 | ( 75 | "-ltk", 76 | "-ltcl" 77 | ); 78 | end case; 79 | 80 | end Tcl_Tk_Options; 81 | -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | compare 2 | tashtest 3 | test_compare.ada 4 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | # Copyright (C) 1997-2000 Terry J. Westley 2 | # Copyright (C) Simon Wright 3 | 4 | # This package is free software; you can redistribute it and/or 5 | # modify it under terms of the GNU General Public License as 6 | # published by the Free Software Foundation; either version 2, or 7 | # (at your option) any later version. This package is distributed in 8 | # the hope that it will be useful, but WITHOUT ANY WARRANTY; without 9 | # even the implied warranty of MERCHANTABILITY or FITNESS FOR A 10 | # PARTICULAR PURPOSE. See the GNU General Public License for more 11 | # details. You should have received a copy of the GNU General Public 12 | # License distributed with this package; see file COPYING. If not, 13 | # write to the Free Software Foundation, 59 Temple Place - Suite 14 | # 330, Boston, MA 02111-1307, USA. 15 | 16 | all:: build test 17 | 18 | build: 19 | alr build 20 | 21 | test:: compare 22 | cp compare.adb test_compare.ada 23 | @(./compare compare.adb test_compare.ada || \ 24 | echo "FAILED: comparison of file and copy failed." \ 25 | true) 26 | @echo "./compare compare.adb tashtest.adb" 27 | @(./compare compare.adb tashtest.adb && \ 28 | echo "FAILED: comparison didn't fail!"; \ 29 | true) 30 | 31 | test:: tashtest 32 | ./tashtest tashtest.tcl 33 | -------------------------------------------------------------------------------- /tests/alire.toml: -------------------------------------------------------------------------------- 1 | description = "Tcl Ada Shell tests" 2 | name = "tash_tests" 3 | licenses = "GPL-2.0-or-later WITH GCC-exception-2.0" 4 | version = "8" 5 | 6 | authors = ["Simon Wright"] 7 | maintainers = ["Simon Wright "] 8 | maintainers-logins = ["simonjwright"] 9 | 10 | project-files = ["tash_tests.gpr"] 11 | executables = ["compare", "tashtest"] 12 | 13 | [[depends-on]] 14 | tash = "*" 15 | 16 | [[pins]] 17 | tash = { path='..' } 18 | -------------------------------------------------------------------------------- /tests/compare.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- compare.adb -- This program compares two files. If they are the 4 | -- same, it has no output. If they are different, it 5 | -- reports the line number of the first difference, 6 | -- then terminates. 7 | -- 8 | -- Copyright (c) 1998 Terry J. Westley 9 | -- 10 | -- See the file "license.htm" for information on usage and 11 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 | -- 13 | -------------------------------------------------------------------- 14 | 15 | with Ada.Command_Line; use Ada.Command_Line; 16 | with Text_IO; 17 | 18 | procedure Compare is 19 | 20 | File1 : Text_IO.File_Type; 21 | Char1 : Character; 22 | File1_Is_Stdin : Boolean := False; 23 | 24 | File2 : Text_IO.File_Type; 25 | Char2 : Character; 26 | File2_Is_Stdin : Boolean := False; 27 | 28 | function "&" (Left : String; Right : Text_IO.Count) return String; 29 | function "&" (Left : String; Right : Text_IO.Count) return String is 30 | begin -- "&" 31 | return Left & Text_IO.Count'Image (Right); 32 | end "&"; 33 | 34 | begin -- Compare 35 | 36 | -- Check that we have correct number of command line arguments 37 | --------------------------------------------------------------- 38 | if Argument_Count < 2 then 39 | Text_IO.Put_Line ("usage: compare file1 file2"); 40 | Set_Exit_Status (Failure); 41 | return; 42 | end if; 43 | 44 | -- Get names of two files to be compared 45 | -- from the command line and open them. 46 | ----------------------------------------- 47 | declare 48 | Name : constant String := Argument (1); 49 | begin 50 | if Name = "-" then 51 | File1_Is_Stdin := True; 52 | else 53 | Text_IO.Open (File1, Text_IO.In_File, Name); 54 | end if; 55 | exception 56 | when others => 57 | Text_IO.Put_Line ("can't find or read file " & Name); 58 | Set_Exit_Status (Failure); 59 | return; 60 | end; 61 | 62 | declare 63 | Name : constant String := Argument (2); 64 | begin 65 | if Name = "-" then 66 | File2_Is_Stdin := True; 67 | else 68 | Text_IO.Open (File2, Text_IO.In_File, Name); 69 | end if; 70 | exception 71 | when others => 72 | Text_IO.Put_Line ("can't find or read file " & Name); 73 | Set_Exit_Status (Failure); 74 | return; 75 | end; 76 | 77 | loop 78 | if File1_Is_Stdin then 79 | exit when Text_IO.End_Of_File; 80 | Text_IO.Get (Char1); 81 | else 82 | exit when Text_IO.End_Of_File (File1); 83 | Text_IO.Get (File1, Char1); 84 | end if; 85 | if File2_Is_Stdin then 86 | exit when Text_IO.End_Of_File; 87 | Text_IO.Get (Char2); 88 | else 89 | exit when Text_IO.End_Of_File (File2); 90 | Text_IO.Get (File2, Char2); 91 | end if; 92 | if Char1 /= Char2 then 93 | Text_IO.Put_Line 94 | (Text_IO.Name (File1) & 95 | " " & 96 | Text_IO.Name (File2) & 97 | " differ: char" & 98 | Text_IO.Col (File1) & 99 | ", line" & 100 | Text_IO.Line (File1)); 101 | Set_Exit_Status (Failure); 102 | return; 103 | end if; 104 | end loop; 105 | 106 | Set_Exit_Status (Success); 107 | 108 | end Compare; 109 | -------------------------------------------------------------------------------- /tests/tash_tests.gpr: -------------------------------------------------------------------------------- 1 | -- Copyright (C) Simon Wright 2 | 3 | -- This package is free software; you can redistribute it and/or 4 | -- modify it under terms of the GNU General Public License as 5 | -- published by the Free Software Foundation; either version 2, or 6 | -- (at your option) any later version. This package is distributed in 7 | -- the hope that it will be useful, but WITHOUT ANY WARRANTY; without 8 | -- even the implied warranty of MERCHANTABILITY or FITNESS FOR A 9 | -- PARTICULAR PURPOSE. See the GNU General Public License for more 10 | -- details. You should have received a copy of the GNU General Public 11 | -- License distributed with this package; see file COPYING. If not, 12 | -- write to the Free Software Foundation, 59 Temple Place - Suite 13 | -- 330, Boston, MA 02111-1307, USA. 14 | 15 | -- This file provides the compilation options for building the Tash 16 | -- tests. 17 | 18 | with "tash"; 19 | with "config/tash_tests_config"; 20 | 21 | project Tash_Tests is 22 | 23 | Tcl_Mains := 24 | ( 25 | "compare.adb", 26 | "tashtest.adb" 27 | ); 28 | 29 | for Main use Tcl_Mains; 30 | 31 | for Exec_Dir use "."; 32 | 33 | -- The source locations for the project. 34 | for Source_Dirs use ("."); 35 | 36 | -- Each Project that contains source must have its own build 37 | -- directory. 38 | for Object_Dir use ".build"; 39 | 40 | -- GCC configuration options. 41 | package Compiler renames Tash.Compiler; 42 | 43 | -- GNATBIND configuration options. 44 | package Binder is 45 | for Default_Switches ("ada") use ("-E"); 46 | end Binder; 47 | 48 | package Linker renames Tash.Linker; 49 | 50 | end Tash_Tests; 51 | -------------------------------------------------------------------------------- /tests/tashtest.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- tashtest.adb -- This program is an alternate version of tash which 4 | -- includes several new Tcl commands used to test the 5 | -- TASH Ada/Tcl interface. 6 | -- 7 | -- Copyright (c) 1995-1997 Terry J. Westley 8 | -- Copyright (c) 2006-2022 Simon Wright 9 | -- 10 | -- See the file "license.htm" for information on usage and 11 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 | -- 13 | -------------------------------------------------------------------- 14 | 15 | with CArgv; 16 | with Tcl; use Tcl; 17 | with TestApp; 18 | 19 | procedure TaShTest is -- Tcl Ada SHell Test 20 | 21 | -- Argc and Argv include the command name 22 | Argc : C.int; 23 | Argv : CArgv.Chars_Ptr_Ptr; 24 | 25 | begin -- TaShTest 26 | 27 | -- Get command-line arguments and put them into C-style "argv," 28 | -- as required by Tcl_Main. 29 | CArgv.Create (Argc, Argv); 30 | 31 | -- Start Tcl (and never return!) 32 | Tcl_Main (Argc, Argv, TestApp.Init'Access); 33 | 34 | end TaShTest; 35 | -------------------------------------------------------------------------------- /tests/tashtest.tcl: -------------------------------------------------------------------------------- 1 | set case_number 0 2 | set failed 0 3 | 4 | proc cequal {s1 s2} { 5 | return [expr [string compare $s1 $s2] == 0] 6 | } 7 | 8 | proc test_case {command expected_result} { 9 | global case_number failed 10 | incr case_number 11 | catch {uplevel $command} actual_result 12 | if ![cequal $expected_result $actual_result] { 13 | incr failed 14 | puts stdout [format \ 15 | "Test Case %2d failed: %s: got '%s', expected: '%s'" \ 16 | $case_number $command $actual_result $expected_result] 17 | } 18 | } 19 | 20 | 21 | #| check argc and argv 22 | test_case {set argc} 0 23 | test_case {set argv} {} 24 | 25 | #| test eq command 26 | if {[info commands eq] == "eq"} { 27 | test_case {eq abc def} 0 28 | test_case {eq 1 1} 1 29 | set w1 .dlg 30 | set w2 .dlg.ok 31 | test_case {eq $w1.ok $w2} 1 32 | } 33 | 34 | #| test concat command 35 | test_case {concat} {} 36 | test_case {concat abc {def}} {abc def} 37 | test_case {concat {a b c} d {e f} g h} {a b c d e f g h} 38 | 39 | #| test list command 40 | test_case {list} {} 41 | test_case {list abc {x y} \}} {abc {x y} \}} 42 | 43 | #| test object-oriented counter 44 | test_case {counter} ctr0 45 | test_case {counter} ctr1 46 | 47 | ctr0 next; ctr0 next; 48 | test_case {ctr0 get} { 2} 49 | test_case {ctr1 get} { 0} 50 | test_case {ctr0 clear} {bad counter command "clear": should be get or next} 51 | 52 | rename ctr0 {}; 53 | test_case {ctr0 get} {invalid command name "ctr0"} 54 | 55 | test_case {sum 2 3} { 5} 56 | test_case {sum 011 0x14} { 31} 57 | test_case {sum 8#011# 16#14#} { 29} 58 | test_case {sum 2#011# 2#1_000#} { 11} 59 | test_case {sum 3 6z} {expected integer but got "6z"} 60 | test_case {sum a3 6} {expected integer but got "a3"} 61 | 62 | #| simple expr command 63 | set x 1 64 | test_case {simple_expr $x+1} 2 65 | test_case {simple_expr $x + 1} {wrong # args} 66 | test_case {simple_expr} {wrong # args} 67 | 68 | #| check if passed or failed 69 | if $failed { 70 | puts stdout "Test FAILED" 71 | exit 1 72 | } else { 73 | puts stdout "Test PASSED" 74 | exit 0 75 | } 76 | 77 | -------------------------------------------------------------------------------- /tests/testapp.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- 3 | -- testapp.ads -- This package provides the Init function required 4 | -- in the call to Tcl_Main. It creates several new 5 | -- Tcl commands which are used to test the TASH 6 | -- Ada/Tcl interface. 7 | -- 8 | -- Copyright (c) 1995-1997 Terry J. Westley 9 | -- 10 | -- See the file "license.htm" for information on usage and 11 | -- redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 | -- 13 | -------------------------------------------------------------------- 14 | 15 | with Interfaces.C; 16 | with Tcl; use Tcl; 17 | 18 | package TestApp is 19 | 20 | package C renames Interfaces.C; 21 | 22 | function Init (Interp : Tcl_Interp) return C.int; 23 | pragma Convention (C, Init); 24 | 25 | end TestApp; 26 | --------------------------------------------------------------------------------