├── INSTALL.md ├── README.md ├── doc ├── beamerthemeVAXMAN.sty ├── introductory_slides.pdf ├── introductory_slides.tex └── lang5_programming.pdf ├── examples ├── apple.5 ├── bargraph.5 ├── cantor.5 ├── cosine.5 ├── fibr.5 ├── fibr_apply.5 ├── fibr_unary.5 ├── gauss_factorial.5 ├── gauss_factorial_unary.5 ├── gol.5 ├── matrix_vector.5 ├── perfect.5 ├── prime.5 ├── prime_2.5 ├── sine_curve.5 ├── sort.5 ├── sort.data ├── sum_of_cubes.5 ├── throw_dice.5 └── ulam.5 ├── lang5 ├── lang5.vim ├── lang5.zip ├── lib ├── mathlib.5 └── stdlib.5 ├── make_dist_kit.bash ├── perl_modules ├── Array │ └── DeepUtils.pm ├── Lang5.pm ├── Lang5 │ └── String.pm └── Term │ └── ReadLine │ ├── Perl.pm │ └── readline.pm └── tests ├── 000_adu_tests.pl ├── 001_basic.pl └── 001_health_check.5 /INSTALL.md: -------------------------------------------------------------------------------- 1 | HOW TO INSTALL LANG5 2 | ==================== 3 | 4 | Installing lang5 on your system is quite simple and straightforward: 5 | 6 | Prerequisites: 7 | -------------- 8 | All you need prior to installing lang5 is a Perl interpreter. Anything from 9 | Perl 5.8.0 will be sufficient (and most probably older Perl interpreters, too, 10 | as long as it is a version 5.x). 11 | 12 | UNIX-installation: 13 | ------------- 14 | 15 | - First you have to decide where to install lang5. There is no need to install 16 | lang5 into /usr/local or somewhere like that - it can happily live in any 17 | user directory, too. Change your working directory to the location you 18 | chose: 19 | 20 | cd 21 | 22 | - Unpack the distribution kit: 23 | 24 | unzip lang5.zip 25 | 26 | - This creates a subdirectory named "lang5" under your current working 27 | directory. 28 | 29 | - Make the lang5-interpreter executable: 30 | 31 | chmod 755 lang5/lang5 32 | 33 | - Make sure that the lang5-directory is in your PATH-environment variable 34 | (otherwise you have to call the interpreter explicitly with an absolute 35 | path). Therefore you might want to extend the .profile in your homedirectory 36 | by a line like this: 37 | 38 | export PATH=$PATH: 39 | 40 | Windows-installation: 41 | --------------------- 42 | 43 | - Chose a location where you want to UNZIP the distribution package and 44 | perform the UNZIP. 45 | 46 | - To start the lang5-interpreter, open a command window (cmd.exe) and type 47 | 48 | perl /lang5 49 | 50 | OpenVMS-installation: 51 | --------------------- 52 | 53 | - Chose a location where you want to UNZIP the distribution package and 54 | perform the UNZIP. For the following example it is assumed that you 55 | UNZIPped the lang5-distribution package to the location 56 | 57 | DISK$SOFTWARE:[LANG5] 58 | 59 | - Make the directory and its subdirectories read- and executable for world: 60 | 61 | $ SET PROT=W:RE DISK$SOFTWARE:[000000]LANG5.DIR 62 | $ SET PROT=W:RE DISK$SOFTWARE:[LANG5...]*.* 63 | 64 | - Create a foreign command to call LANG5. Therefore you might want to include 65 | a line like the following in your user's LOGIN.COM or the system wide 66 | SYS$MANAGER:LOGIN.COM: 67 | 68 | $ LANG5 :== PERL DISK$SOFTWARE:[LANG5]LANG5 69 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Lang5 - a stack oriented APL-like language 2 | ========================================== 3 | 4 | What is Lang5? 5 | -------------- 6 | 7 | Lang5 is a stack oriented programming language (if you are familiar with 8 | Forth, you will feel instantly at home in Lang5) with many APL-like 9 | features. Lang5 supports n-dimensional datastructures which can be easily 10 | manipulated on the stack following the APL programming paradigm. 11 | 12 | Platforms 13 | --------- 14 | 15 | Lang5 has been written in Perl by Bernd Ulmann and Thomas Kratz and runs on 16 | all platforms with a decent Perl interpreter installed. 17 | 18 | If you want to use the array processing features of Lang5 directly within 19 | Perl programs, you might want to have a closer look at the Perl module 20 | [Array::APX](https://metacpan.org/pod/Array::APX). 21 | 22 | First steps: 23 | ------------ 24 | 25 | Lang5 can be installed by unpacking lang5.zip which contains all required 26 | modules etc. It is recommended to add the path to your local Lang5 installation 27 | to your PATH-variable so that Lang5 can be invoked without the necessity 28 | to specify an absolute or relative path. It can then be started by executing 29 | `lang5`: 30 | ``` 31 | lang5 32 | loading mathlib.5: Const..Basics..Set..Stat..Cplx..P..LA..Graph..Trig..NT.. 33 | loading stdlib.5: Const..Misc..Stk..Struct.. 34 | lang5> 35 | ``` 36 | 37 | On startup the interpreter loads the modules found in the directory lib. As 38 | of now there are two modules, the mathematical library `mathlib.5` and the 39 | standard library `stdlib.5`. 40 | 41 | For a simple introductory example (a detailed description of the language etc. 42 | can be found in [lang5_programming](doc/lang5_programming.pdf)) assume that 43 | we want to simulate the outcome of throwing a six sided dice 10 times. 44 | 45 | We first create a vector containing 10 times the value 6 - the command `.` 46 | prints the top element of the stack (removing it): 47 | ``` 48 | lang5> 6 10 reshape . 49 | [ 6 6 6 6 6 6 6 6 6 6 ] 50 | ``` 51 | 52 | Applying the `?` operator to this vector replaces each vector element by a 53 | pseudorandom number between 0 and 6 (excluding 6): 54 | ``` 55 | lang5> 6 10 reshape ? . 56 | [ 4.57888823093347 5.66943497823814 3.9537789693539 3.31383259974398 1.5666493855665 4.68637339529224 5.47878973919982 3.36891441444324 2.78258906253037 2.19838374189976 ] 57 | ``` 58 | 59 | Applying `int` will reduce each of these values to the nearest smaller integer 60 | yielding a vector of 10 elements, each in the interval [0,5]. Adding 1 yields 61 | a vector of pseudorandom numbers in the interval [1,6]: 62 | ``` 63 | lang5> 6 10 reshape ? int 1 + . 64 | [ 5 6 2 5 5 5 1 5 4 6 ] 65 | ``` 66 | 67 | We now have to sum these values and divide the result by 10 to get the average 68 | of this random experiment. Summing the values of a vector is done by means of 69 | the reduce operator which expects a vector and a binary operator, effectively 70 | applying the operator to each pair of successive vector elements: 71 | ``` 72 | lang5> 6 10 reshape ? int 1 + '+ reduce 10 / . 73 | 3.3 74 | ``` 75 | 76 | We can now simplify things by defining a new word `throw_dice` which expects 77 | a scalar on the top of the stack which defined how often the dice should be 78 | rolled: 79 | ``` 80 | : throw_dice 6 over reshape ? int 1 + '+ reduce swap / ; 81 | ``` 82 | 83 | This new word can now be used to simulate 1000 runs of throwing the dice as 84 | follows: 85 | ``` 86 | lang5> 1000 throw_dice . 87 | 3.496 88 | ``` 89 | 90 | A slighty more complicated example 91 | ---------------------------------- 92 | 93 | A slightly more complicated example would be the generation of a list of 94 | primes. The basic idea is to use clever array manipulations instead of 95 | loops and conditionals (this solution is pretty beautiful but not efficient 96 | at all! :-) ). Let us assume we want to generate a list of primes in the 97 | interval [2,10]. First we will create a vector containing the values 2 to 10 98 | in one's increments. The operator `iota` generates an arithmetic progression 99 | in a vector with as many elements as specified by the element on the top of 100 | the stack: 101 | ``` 102 | 9 iota 2 + . 103 | [ 2 3 4 5 6 7 8 9 10 ] 104 | ``` 105 | 106 | `9 iota` generates a vector `[0 1 2 3 4 5 6 7 8]` to which 2 is added in an 107 | element wise fashion yielding the desired result. Duplicating this vector 108 | and computing an outer product yields basically a multiplication table: 109 | ``` 110 | lang5> 9 iota 2 + dup '* outer . 111 | [ 112 | [ 4 6 8 10 12 14 16 18 20 ] 113 | [ 6 9 12 15 18 21 24 27 30 ] 114 | [ 8 12 16 20 24 28 32 36 40 ] 115 | [ 10 15 20 25 30 35 40 45 50 ] 116 | [ 12 18 24 30 36 42 48 54 60 ] 117 | [ 14 21 28 35 42 49 56 63 70 ] 118 | [ 16 24 32 40 48 56 64 72 80 ] 119 | [ 18 27 36 45 54 63 72 81 90 ] 120 | [ 20 30 40 50 60 70 80 90 100 ] 121 | ] 122 | ``` 123 | 124 | This table contains all multiples of the values in the interval [2,10], 125 | excluding the multiplier 1, i.e. this table only contains non-prime numbers 126 | (as every number is the product of at least two smaller integer numbers). 127 | So we now have to check which values of the original vector are not contained 128 | in this matrix (note the additional `dup` in the example!): 129 | ``` 130 | lang5> 9 iota 2 + dup dup '* outer swap in . 131 | [ 0 0 1 0 1 0 1 1 1 ] 132 | ``` 133 | 134 | The resulting vector shows that the values 2, 3, 5, and 7 are not (!) elements 135 | of the matrix we just created, so these elements must be prime. We can thus 136 | invert this vector and use it to select all values from the original vector 137 | (which is duplicated a third time for this) thus generating a vector containing 138 | all primes in the interval specified: 139 | ``` 140 | lang5> 9 iota 2 + dup dup dup '* outer swap in not select . 141 | [ 2 3 5 7 ] 142 | ``` 143 | 144 | Starting with 99 instead of 9 yields a list of all primes in the interval 145 | [2,100] (note that this requires a matrix of roughly 100 times 100 = 10000 146 | elements to be created temporarily, so this approach is by no means efficient, 147 | it is just charmingly elegant :-) ): 148 | ``` 149 | lang5> 99 iota 2 + dup dup dup '* outer swap in not select . 150 | [ 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 ] 151 | ``` 152 | 153 | Change history 154 | ============== 155 | 156 | 26-SEP-2020: 157 | ------------ 158 | / The directory structure has been cleaned up, several small errors in the 159 | test programs were resolved. The documentation has been updated and cleaned 160 | up, the make_dist_kit.bash script has been revised. 161 | 162 | 26-MAY-2013: 163 | ------------ 164 | / The introductory booklet has been revised, some (minor) faults have been 165 | corrected and user input is now printed in red to distinguish it clearly from 166 | various system outputs. 167 | 168 | 04-MAY-2013: 169 | ------------ 170 | + Part of the distribution kit is now a free book about the design and 171 | implementation of Lang5. It is named design_and_implementation.pdf and 172 | can be found in the directory named "doc". This book is intended to be 173 | used for self-study as well as an introductory text into the implementation 174 | of small interpreters. 175 | - Removed the old introductory text. 176 | / Fixed some nasty bugs in handling arrays and variables. (In fact, always 177 | pushing references onto the central stack resulted in some hard to debug 178 | phenomena - such data is now cloned using dclone from Array::DeepUtils 179 | before pushing a reference onto the stack.) 180 | 181 | 04-APR-2013: 182 | / Corrected a rather nasty bug that made it impossible to push the string '; 183 | onto the stack (which caused the sort example to fail, among other programs). 184 | / Corrected some examples which did not work any longer due to some subtle 185 | changed in the interpreter. The matrix-vector-multiplication example even 186 | got simpler. :-) 187 | + There is now a tangens word in mathlib.5 188 | 189 | 20-OCT-2011: 190 | ------------ 191 | + There are two new operators available: === and eql. Both work similar to the 192 | traditional comparison operators == and eq with the distinction that 0, "" and 193 | undef are handled as different values, so "0 undef ===" will yield 0 and not 194 | 1. 195 | / CTRL-C is now handled correctly. A lang5-program containing an endless loop 196 | etc. can now interactively interrupted by pressing CTRL-C. If the interpreter 197 | was running in interactive mode this signal will return to the input prompt. 198 | / Update of the documentation. 199 | 200 | 30-AUG-2011: 201 | ------------ 202 | / According to our doodle poll the language has been renamed to lang5. This 203 | was mainly due to the following facts: 1) lang5 had the most votes, 204 | 2) SOLVO has been already used for consulting companies, data extraction 205 | software etc. and 3) lang5 already yields a number 1 hit in google. 206 | / The documentation has been extended a bit. 207 | + The '*-operator has been overloaded to perform matrix-matrix-multiplications, 208 | too. 209 | 210 | 06-AUG-2011: 211 | ------------ 212 | * 5 is now at version 1.0!!! :-) 213 | + Added new function "transpose" to perform a generalized matrix transposition. 214 | / Updated the documentation (transpose + a more detailed description of the 215 | Game-of-Life example). 216 | 217 | 01-AUG-2011: 218 | ------------ 219 | + New generic function "rotate" added - this replaces the 5-implemented rmx and 220 | rmy functions in a general way. rmx and rmy have been remove from stdlib.5 221 | + Documentation reflects these changes. 222 | / The Game-of-Life-example has been adapted to the rotate function (and runs now 223 | approximately 5 times faster :-) ). 224 | 225 | 26-JUL-2011: 226 | ------------ 227 | + Two new words for matrix rotation along their x- and y-axis have been 228 | added to stdlib.5 (rmx and rmy). 229 | + A new example has been added: Conway's game of life. 230 | ! Lots of bugfixes and cleanups. 231 | 232 | 06-JUL-2011: 233 | ------------ 234 | + execute can now work on arrays of strings containing 5 program sequences. 235 | This is very useful to avoid explicit loops by unrolling loops into such 236 | arrays and processing them with execute. 237 | + exit did not end a program, instead it caused the next instruction(s) to 238 | be read but then the interpreter collapsed. This has been fixed, too, exit 239 | does now what one would expect from it. :-) 240 | + A new example (the most complicated until now) has been added. It shows the 241 | calculation of a Mandelbrot set without any explicit loops (execution time 242 | is rather high - expect a run time of about 1 minute!). 243 | + The documentation has been updated and expanded. 244 | + Some additional operators have been overloaded to work on complex numbers. 245 | 246 | 29-JUN-2011: 247 | ------------ 248 | + The documentation is now up to date and has been enhanced a lot! :-) 249 | + A minor bug in explain was fixed that prevented the interpreter from loading 250 | workspace files that had been created using the word save. 251 | + Two support words were made local in stdlib.5 and mathlib.5. 252 | 253 | 24-MAY-2011: 254 | ------------ 255 | + 5 is now able to work with overloaded operators. Therefore types were 256 | introduced in the form of "dressed structures". The following example 257 | will show the basic idea (the documentation is still a bit behind - 258 | sorry!): 259 | 260 | [[1 2 3][4 5 6][7 8 9]](m) [10 11 12](v) 261 | 262 | This will create a matrix with "dress" (m) and a vector, dressed as (v). 263 | Performing a matrix-vector-multiplication can now be performed by typing 264 | 265 | * . 266 | 267 | This works since * has been overloaded in lib/mathlib.5 (have a look). 268 | + The interpreter has undergone major changes. 269 | 270 | 29-JAN-2011: 271 | ------------ 272 | + A lot of major changes has happened - mostly due to Thomas' great work. The 273 | most important aspect is that most of the basic array functions have now 274 | found their way into an own module that will some day published on CPAN. 275 | + Fixed some minor problems in the mathlib. 276 | 277 | 20-SEP-2010: 278 | ------------ 279 | + Added a new word, dreduce, to stdlib.5. 280 | + Modified ".s" in stdlib.5 to yield more readable output. 281 | + Added a new example for calculating perfect numbers. 282 | + Updated the documentation. 283 | 284 | 06-AUG-2010: 285 | ------------ 286 | + The interpreter can now handle things like 1 [1 2 3] - . 287 | + We sped up the interpreter by a factor of about 3 yesterday using the 288 | NYTProf profiler Tim Bunce demonstrated on the YAPC::Europe 2010. :-) 289 | 290 | 21-JUN-2010: 291 | ------------ 292 | + Added readline functionality to 5, so it is now possible to use command 293 | line editing functions. Unfortunately this currently works not on Windows 294 | and VMS systems. 295 | 296 | 05-JUN-2010: 297 | ------------ 298 | ! "rho" and "dim" have been renamed "reshape" and "shape" to be more 299 | compatible with APL and even Fortran 2003. :-) The documentation and 300 | examples etc. have been adapted accordingly. 301 | + Added an additional sanity check for "copy" which detects non-uniform 302 | coordinate vectors. 303 | + "reshape" can now handle scalar values as well, 1 10 reshape will 304 | yield a ten element vector [1 1 1 1 1 1 1 1 1 1]. 305 | + The dice example has been changed to make use of "reshape". 306 | + An additional example has been included which computes all numbers 307 | between 1 and 999 which equal the sum of the cubes of their individual 308 | digits. 309 | 310 | 31-MAY-2010: 311 | ------------ 312 | + subscript can now handle even complex coordinate vectors and is not restricted 313 | to selecting elements along the first dimension only, as the following 314 | example shows: 315 | 316 | 64 iota [4 4 4] rho [1 [1 2] [1 2 3]] subscript . 317 | 318 | + Added a function "copy" which copies successive elements from a deeply 319 | nested structure, controlled by a two element coordinate vector which 320 | contains the coordinates of the upper left and lower right corner of an 321 | n-dimensional sub-cube of the basic nested structure. The following example 322 | shows the behaviour of copy quite well: 323 | 324 | 64 iota [4 4 4] rho [[1 1 1] [2 2 2]] copy . 325 | 326 | + Added a function "help" which prints the description of builtin functions 327 | and operators. Try 328 | 329 | '+ help 330 | 331 | + The output generated by specifying the statistics option -s now contains 332 | the maximum stack depth encountered during a program run (this value is 333 | surprisingly small). 334 | + Quite some comments have been added to the interpreter code to make it more 335 | readable and extensible. 336 | + Made some minor changed to stdlib.5 (extract had to be adapted to the new 337 | implementation of subscript) and mathlib.5. 338 | 339 | 04-MAY-2010: 340 | ------------ 341 | + Fixed a problem with local stacks (thanks, Thomas! :-) ) 342 | + Adapted the health_check to the fact that "deptbh" is now a function 343 | + Adapted the documentation and included an additional example concerning 344 | Fibonacci numbers 345 | 346 | 02-MAY-2010: 347 | ------------ 348 | 5 is now available in version 0.1! :-) 349 | 350 | The documentation is up to date by now and reflects the current interpreter 351 | version. 352 | 353 | More examples have been written. 354 | -------------------------------------------------------------------------------- /doc/beamerthemeVAXMAN.sty: -------------------------------------------------------------------------------- 1 | % 2 | % OCT-2009 by Bernd Ulmann 3 | % 4 | \usepackage{ifthen} 5 | \usepackage{ragged2e} 6 | \usepackage{array} 7 | 8 | \DeclareOptionBeamer{headheight}{\beamer@boxheadheight=#1} 9 | \DeclareOptionBeamer{footheight}{\beamer@boxfootheight=#1} 10 | 11 | \newdimen\beamer@boxheadheight 12 | \newdimen\beamer@boxfootheight 13 | \beamer@boxheadheight=10pt 14 | \beamer@boxfootheight=10pt 15 | 16 | \ProcessOptionsBeamer 17 | 18 | \mode 19 | 20 | \newcount\beamer@headboxes 21 | \newdimen\beamer@headboxsizes 22 | \newcount\beamer@currentbox 23 | \def\addheadboxtemplate#1#2{} 24 | 25 | \def\addheadbox#1#2{\addheadboxtemplate{\usebeamercolor[bg]{#1}}{\usebeamercolor[fg]{#1}\usebeamerfont{#1}#2}} 26 | 27 | \def\titlepage{ 28 | \vspace*{-1.2cm} 29 | \hspace*{.2cm} 30 | \\ 31 | \vspace*{-.3cm} 32 | \rule{\textwidth}{.3mm} 33 | \usebeamertemplate*{title page} 34 | } 35 | 36 | \defbeamertemplate*{headline}{VAXMAN theme} 37 | {% 38 | \leavevmode 39 | \beamer@currentbox=0\relax% 40 | \loop% 41 | \ifnum\beamer@currentbox<\beamer@headboxes% 42 | \hbox to\beamer@headboxsizes{% 43 | % Background 44 | {% 45 | \csname beamer@headbg\the\beamer@currentbox\endcsname% 46 | \vrule width\beamer@headboxsizes height\beamer@boxheadheight% 47 | \hskip-\beamer@headboxsizes% 48 | }% 49 | % Box 50 | {% 51 | \setbox\beamer@tempbox=\hbox to\beamer@headboxsizes{% 52 | \csname beamer@headbox\the\beamer@currentbox\endcsname\hfil}% 53 | \dp\beamer@tempbox=0pt% 54 | \setbox\beamer@tempbox=\hbox{\vbox{\box\beamer@tempbox\vskip3pt}}% 55 | \ht\beamer@tempbox=\beamer@boxheadheight% 56 | \dp\beamer@tempbox=0pt% 57 | \box\beamer@tempbox% 58 | }}% 59 | \advance\beamer@currentbox by 1% 60 | \repeat% 61 | }% 62 | 63 | \newcount\beamer@footboxes 64 | \newdimen\beamer@footboxsizes 65 | \def\addfootboxtemplate#1#2{ 66 | \expandafter\def\csname beamer@footbox\the\beamer@footboxes\endcsname{#2} 67 | \expandafter\def\csname beamer@footbg\the\beamer@footboxes\endcsname{#1} 68 | \advance\beamer@footboxes by 1\relax 69 | \beamer@footboxsizes=\paperwidth 70 | \divide\beamer@footboxsizes by\beamer@footboxes 71 | } 72 | 73 | %\xdefinecolor{slidecolor}{rgb}{0,.68,.62} 74 | \xdefinecolor{slidecolor}{rgb}{0,0,.5} 75 | \usecolortheme[named=slidecolor]{structure} 76 | 77 | \newcolumntype{L}[1]{>{\hspace{0pt}\RaggedRight\arraybackslash}p{#1}} 78 | \newcolumntype{C}[1]{>{\hspace{0pt}\Centering\arraybackslash}p{#1}} 79 | \newcolumntype{R}[1]{>{\hspace{0pt}\RaggedLeft\arraybackslash}p{#1}} 80 | 81 | \setbeamertemplate{frametitle} 82 | { 83 | % \scalebox{.35}{\includegraphics{FomLogo.pdf}}% 84 | \begin{tabular}{@{}C{5.1cm}R{3cm}@{}} 85 | \color{slidecolor}\small\bf\insertframetitle& 86 | \ifthenelse{\value{section}=0} 87 | {\relax} % No section at all 88 | { 89 | \ifthenelse{\value{subsection}=0}% 90 | {\color{slidecolor}\tiny\thesection.\ \insertsection}% 91 | {\color{slidecolor}\tiny\thesection.\thesubsection\ \insertsubsection} 92 | } 93 | \end{tabular}\\ 94 | \relax\vspace*{-.35cm} 95 | \color{slidecolor}\rule{\textwidth}{.3mm} 96 | } 97 | 98 | \defbeamertemplate*{footline}{VAXMAN theme} 99 | { 100 | \begin{beamercolorbox}[wd=\paperwidth,ht=2.25ex,dp=1ex]{date in head/foot}% 101 | \begin{tabular}{L{1cm}C{8cm}R{2.1cm}} 102 | \insertframenumber{}/\inserttotalframenumber& 103 | \insertauthor& 104 | % \inserttitle{ }--{ }\insertauthor& 105 | \insertdate\\ 106 | \end{tabular} 107 | \end{beamercolorbox} 108 | } 109 | 110 | \beamertemplatenavigationsymbolsempty 111 | \useinnertheme{rectangles} 112 | \mode 113 | 114 | 115 | -------------------------------------------------------------------------------- /doc/introductory_slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bernd-ulmann/lang5/f0da7279bba222fb18cb0d6b0caa45f7cfd6f661/doc/introductory_slides.pdf -------------------------------------------------------------------------------- /doc/introductory_slides.tex: -------------------------------------------------------------------------------- 1 | % APL: Powerful vocabulary 2 | % 4th: Extensible language, simplest possible syntax :-) 3 | \documentclass{beamer} 4 | \usepackage{beamerthemesplit, eso-pic, graphics, german} 5 | \usetheme{VAXMAN} 6 | % 7 | \newcommand*{\NIX}{\vspace*{.3cm}\\} 8 | \newcommand*{\F}{{\tt\bf lang5}} 9 | % 10 | \title{\F} 11 | \author{Dr. Bernd Ulmann} 12 | \date{26-SEP-2020} 13 | % 14 | \begin{document} 15 | \begin{frame}[containsverbatim] 16 | \titlepage 17 | \end{frame} 18 | % 19 | \section{Introduction} 20 | \begin{frame} 21 | \frametitle{Introduction} 22 | The following talk is about a new (rather eclectic) interpretive programming 23 | language called \F{ } which is, in essence, the result of combining the 24 | basic ideas and aspects of Forth and of APL. 25 | \NIX 26 | The idea of extending Forth is not new to say the least -- the most 27 | prominent example being HP's well known programming language RPL which 28 | was for many years the work horse of their top-of-the-line pocket 29 | calculators like the HP-28, the HP-48 etc. 30 | \NIX 31 | While RPL, short for \emph{Reverse Polish LISP},{~} combines Forth's stack 32 | approach to programming with typical list processing operations normally 33 | to be found in the language LISP, the language described briefly in the 34 | following is also based on Forth but extends it with the programming 35 | paradigm of APL, Ken Iverson's brain child which is still unmatched when 36 | it comes to elegance and compactness of code. 37 | \end{frame} 38 | % 39 | \begin{frame} 40 | \frametitle{Why \F} 41 | Why would one create yet another programming language? Aren't there 42 | more than enough already? The main reasons for the development described 43 | in the following are these: 44 | \begin{itemize} 45 | \item Writing compilers and interpreters is really interesting and gives 46 | an insight into the design of programming languages which is hard to 47 | achieve otherwise. 48 | \item Both Forth and APL have features making them more or less unique 49 | in the programming languages zoo, so both languages are definitely 50 | worth to be at least taken into account as the basis for new developments. 51 | \item On the other hand, both languages have their deficiencies like 52 | the need for special characters in APL, the non-overloading of basic 53 | arithmetic operators in Forth etc. 54 | \item Languages based on array operations like APL might be an ideal tool 55 | to phrase algorithms for vector processors and GPUs. It should be 56 | worthwhile to think about a compiler generating CUDA-code from \F-programs. 57 | \end{itemize} 58 | \end{frame} 59 | % 60 | \section{\F{ } at a glance} 61 | \begin{frame} 62 | \frametitle{\F{ } at a glance} 63 | What are the main characteristics of \F? 64 | \begin{itemize} 65 | \item \F{ } is completely stack based, its builtin operations are called 66 | \emph{built in words}{ } while user defined operations are 67 | just called \emph{words}. 68 | \item The stack can hold entities of arbitrary structure as long as these 69 | may be represented as nested arrays. 70 | \item All built in words as well as user defined words operate on 71 | those arbitrary structures which can be placed on the stack. Thus 72 | {\tt 2 3 + .} yields {\tt 5}{ } while 73 | {\tt [1 2] [3 4]{ } + .} yields {\tt [4 6]}. 74 | \item During startup the \F-interpreter looks for a file named 75 | {\tt stdlib.5} -- if one is present it will be loaded prior to loading 76 | the program to be executed. This standard library contains \F-extensions 77 | written in \F{ } (for example the words {\tt grot} and {\tt ggrot}). 78 | \end{itemize} 79 | \end{frame} 80 | % 81 | \section{\F{ } implementation} 82 | \begin{frame}[containsverbatim] 83 | \frametitle{The implementation of \F} 84 | The following slides give a short overview of the current implementation 85 | of \F. 86 | \NIX 87 | This implementation is neither complete nor stable enough to be called 88 | production grade -- its main purpose is to serve as a proof of concept 89 | of the language itself and its basic implementation concepts. 90 | \NIX 91 | The current \F-implementation is based on Perl which led to a very 92 | rapid development of the interpreter which took, until now, only about two 93 | man weeks. 94 | \NIX 95 | A typical \F-program could look like this: 96 | \begin{verbatim} 97 | 4 iota dup '* outer 98 | dup 2 compress . 99 | \end{verbatim} 100 | \end{frame} 101 | % 102 | \begin{frame} 103 | \frametitle{Executing \F} 104 | Such a \F-program is rather simple to scan, parse and execute: 105 | \begin{itemize} 106 | \item A \F-program is parsed by basically splitting its source on 107 | whitespace with some special provision for arrays. The basic entities of 108 | a \F-program are called \emph{tokens}. 109 | \item Word definitions start with {\tt :}{ } and end with {\tt ;}. 110 | The start of a word definition has highest priority for the interpreter. 111 | \item If no word is to be defined, \F{ } tries to execute a built in 112 | word of the name found in the current token. 113 | \item If no matching word can be found \F{ } tries to execute a user 114 | defined word named like the token read. 115 | \item If no word is found, \F{ } checks if there is a variable with a 116 | matching name -- if it succeeds the contents of that variable will just be 117 | pushed onto the stack. 118 | \item If even this did not work the element just read will be pushed onto 119 | the stack. 120 | \end{itemize} 121 | \end{frame} 122 | % 123 | \begin{frame} 124 | \frametitle{Scanning and parsing} 125 | If there were no nested structures to be pushed onto the stack and no 126 | {\tt if}-{\tt else}-constructions or loops, scanning and parsing 127 | \F{ } would be really trivial. 128 | \NIX 129 | To handle nested data structures like {\tt [1 [2 3]{ } 4]} special treatment 130 | of the tokens generated by splitting the source code at whitespaces 131 | is needed since these tokens would look like 132 | {\tt [1}, {\tt [2}, {\tt 3]}{ } and {\tt 4]}{ } 133 | which does not represent what the programmer intended. 134 | \NIX 135 | Therefore the raw program representation is subjected to a special step 136 | which gathers data of nested data structures and transforms 137 | the example given above back to {\tt [1 [2 3] 4]} from the token stream. 138 | \NIX 139 | The same holds true for nested program structures like 140 | {\tt if}--{\tt else}--{\tt then}- and 141 | {\tt do}--{\tt loop}-structures 142 | which are processed similarly and yield a nested program structure for 143 | every controlled block. 144 | \end{frame} 145 | % 146 | \begin{frame} 147 | \frametitle{Data structures} 148 | Thus a \F-program is represented within the interpreter as a nested array 149 | containing 150 | \begin{itemize} 151 | \item an entry for every word to be executed, 152 | \item an entry for each scalar used in the program, 153 | \item an entry containing a reference to a nested array structure for 154 | every such structure found in the \F{ } source code, 155 | \item an entry containing a reference to a nested structure for every 156 | {\tt if-else-then} or {\tt do-loop} controlled block. 157 | \end{itemize} 158 | 159 | The following example shows a simple \F-program consisting of two nested 160 | loops and its internal representation in the interpreter. 161 | \end{frame} 162 | % 163 | \begin{frame}[containsverbatim] 164 | \frametitle{Example structure} 165 | {\small 166 | \begin{verbatim} 167 | 0 do 168 | 100 do 169 | dup . 170 | 1 + 171 | dup 105 > if 172 | break 173 | then 174 | loop 175 | drop 176 | # 177 | dup . 178 | 1 + 179 | dup 5 > if 180 | break 181 | then 182 | loop 183 | drop 184 | \end{verbatim} 185 | } 186 | \end{frame} 187 | % 188 | \begin{frame}[containsverbatim] 189 | \frametitle{Example structure} 190 | The preceding program is then represented internally like this: 191 | {\small 192 | \begin{verbatim} 193 | [ '0', 'do', 194 | [ '100', 'do', 195 | [ 'dup', '.', '1', '+', 'dup', '105', '>', 'if', 196 | [ 'break' ] 197 | ], 198 | 'drop', 'dup', '.', '1', '+', 'dup', '5', '>', 'if', 199 | [ 'break' ] 200 | ], 201 | 'drop' 202 | ] 203 | \end{verbatim} 204 | } 205 | \end{frame} 206 | % 207 | \section{Language elements} 208 | \begin{frame}[containsverbatim] 209 | \frametitle{Language elements} 210 | Currently the following words are implemented: 211 | \NIX 212 | \begin{description} 213 | \item [Binary built in words:] 214 | \begin{verbatim} 215 | + - * / & | ^ > < == >= <= != <=> 216 | % ** eq ne gt lt ge le 217 | \end{verbatim} 218 | \item [Unary built in words:] 219 | \begin{verbatim} 220 | not neg ! sin cos ? int 221 | \end{verbatim} 222 | \item [Stack operations:] 223 | \begin{verbatim} 224 | dup drop swap over rot depth 225 | \end{verbatim} 226 | \item [Array operations:] 227 | \begin{verbatim} 228 | iota reduce remove outer in select 229 | expand compress reverse 230 | \end{verbatim} 231 | \item [IO-operations:] 232 | \begin{verbatim} 233 | . .s .v read 234 | \end{verbatim} 235 | \item [Variable operations:] 236 | \begin{verbatim} 237 | set del 238 | \end{verbatim} 239 | \item [Control operations:] 240 | \begin{verbatim} 241 | if else then do loop break exit 242 | \end{verbatim} 243 | \end{description} 244 | \end{frame} 245 | % 246 | \section{Examples} 247 | \begin{frame} 248 | \frametitle{Examples} 249 | Although the \F-interpreter is far from being complete, some more or less 250 | simple and actually working examples can already be shown: 251 | \NIX 252 | These examples include 253 | \begin{itemize} 254 | \item Some introductory programs, 255 | \item cosine approximation using MacLaurin series and 256 | \item the sieve of Eratosthenes. 257 | \end{itemize} 258 | \end{frame} 259 | % 260 | \begin{frame} 261 | \frametitle{Fibonacci numbers} 262 | Recursion is such a powerful tool that not only the \F-interpreter itself 263 | is highly recursive internally but the language \F{ } itself allows 264 | recursion as well. 265 | \NIX 266 | The following program computes the well known Fibonacci number sequence 267 | implementing the recursive definition 268 | \begin{eqnarray} 269 | f(0)&=&1\nonumber\\ 270 | f(1)&=&1\nonumber\\ 271 | f(n)&=&f(n-1)+f(n-2).\nonumber 272 | \end{eqnarray} 273 | \end{frame} 274 | % 275 | \begin{frame}[containsverbatim] 276 | \frametitle{Fibonacci numbers} 277 | \begin{verbatim} 278 | : fib 279 | dup 2 < 280 | if 281 | drop 1 282 | else 283 | dup 284 | 1 - fib 285 | swap 2 - fib 286 | + 287 | then 288 | ; 289 | 290 | 0 do 291 | dup fib . 1 + 292 | dup 10 > if break then 293 | loop 294 | \end{verbatim} 295 | \end{frame} 296 | % 297 | \begin{frame}[containsverbatim] 298 | \frametitle{Throwing dice} 299 | Throw a dice 100 times and calculate the arithmetic mean of the results: 300 | \begin{verbatim} 301 | : throw_dice 302 | 100 dup iota undef ne 6 * 303 | ? int 1 + 304 | '+ reduce swap / . 305 | ; 306 | \end{verbatim} 307 | \end{frame} 308 | % 309 | \begin{frame} 310 | \frametitle{Cosine approximation} 311 | The following word computes the cosine of a value given in radians using 312 | the MacLaurin expansion 313 | \begin{displaymath} 314 | \cos x\approx\sum\limits_{i=0}^n (-1)^i \frac{x^{2i}}{(2i)!} 315 | \end{displaymath} 316 | with 9 terms. 317 | \NIX 318 | To accomplish this without an explicit loop three basic vectors representing 319 | $(-1)^i$, $x^{2i}$ and $(2i)!$ are generated. Multiplying the first two and 320 | dividing the result by the third one yields a vector which is then processed 321 | by summing all of its elements using the {\tt reduce} operation. 322 | \NIX 323 | The following slide shows the complete word definition of {\tt mc\_cos}: 324 | \end{frame} 325 | % 326 | \begin{frame}[containsverbatim] 327 | \frametitle{Cosine approximation} 328 | {\small 329 | \begin{verbatim} 330 | : mc_cos 331 | # Save x and the number of terms for future use 332 | 'x set 9 'terms set 333 | 334 | # Generate a vector containing x ** (2 * i) 335 | terms iota dup undef ne x * swap 2 * dup v2i set ** 336 | 337 | # Generate the (2 * i)! vector and 338 | # divide the previous vector by this 339 | v2i ! / 340 | 341 | # Generate a vector of the form [1 -1 1 -1 1 ...] 342 | terms iota 1 + 2 % 2 * 1 - 343 | 344 | # Multiply both vectors and reduce the result by '+' 345 | * '+ reduce 346 | ; 347 | \end{verbatim} 348 | } 349 | \end{frame} 350 | % 351 | \begin{frame} 352 | \frametitle{List of primes} 353 | The following program implements a form of the sieve of Eratosthenes 354 | which is quite popular in the APL community. The basic ideas for 355 | generating a list of primes between 2 and a given value {\tt n} are these: 356 | \begin{itemize} 357 | \item Generate a vector {\tt [1, 2, 3, ..., n]}. 358 | \item Drop the first vector element yielding {\tt [2, 3, 4, ..., n]}. 359 | \item Compute the outer product of two such vectors yielding a matrix 360 | like this: 361 | \begin{displaymath} 362 | \begin{pmatrix} 363 | 4&6&8&10&\dots\\ 364 | 6&9&12&15&\dots\\ 365 | 8&12&16&20&\dots\\ 366 | 10&15&20&25&\dots\\ 367 | \vdots&\vdots&\vdots&\vdots&\ddots 368 | \end{pmatrix} 369 | \end{displaymath} 370 | \end{itemize} 371 | \end{frame} 372 | % 373 | \begin{frame} 374 | \frametitle{List of primes} 375 | \begin{itemize} 376 | \item Obviously this matrix contains everything but prime numbers, so 377 | the next step is to determine which number contained in the original 378 | vector {\tt [2, 3, ..., n]} is \emph{not} contained in this matrix which 379 | can be done using the set operation {\tt in}. 380 | \item The result of {\tt in}{~} is a vector with {\tt n-1} elements 381 | each being {\tt 0} (its corresponding vector element was not found in 382 | matrix and is thus not prime) or {\tt 1}. 383 | \item After inverting this binary vector it can be used to select 384 | all prime numbers from the initial vector {\tt [2, 3, ..., n]}. 385 | \end{itemize} 386 | 387 | This is accomplished by the following \F-program: 388 | \end{frame} 389 | % 390 | \begin{frame}[containsverbatim] 391 | \frametitle{List of primes} 392 | \begin{verbatim} 393 | : prime_list 394 | iota 1 + 395 | 0 remove 396 | dup dup dup 397 | '* outer 398 | swap in not 399 | select 400 | ; 401 | 402 | 100 prime_list . 403 | \end{verbatim} 404 | 405 | This program yields the following output: 406 | \begin{verbatim} 407 | [2 3 5 7 11 13 17 19 23 29 31 37 41 408 | 43 47 53 59 61 67 71 73 79 83 89 97 ] 409 | \end{verbatim} 410 | \end{frame} 411 | % 412 | \section{Style} 413 | \begin{frame}[containsverbatim] 414 | \frametitle{Style} 415 | Combining the power of Forth and APL, \F{ } requires a consistent 416 | programming style and rational factoring of words to ensure code 417 | maintainability. 418 | \NIX 419 | The cosine example from above could have been written also like this: 420 | \begin{verbatim} 421 | : mc_cos 422 | 'x set 9 'terms set 423 | terms iota dup undef ne x * swap 2 * dup v2i set 424 | ** v2i ! / terms iota 1 + 2 % 2 * 1 - * '+ reduce 425 | ; 426 | \end{verbatim} 427 | 428 | This code is not really what one would call maintainable compared with the 429 | far better formatting and commenting shown in the original example. 430 | \end{frame} 431 | % 432 | \begin{frame} 433 | \frametitle{Style} 434 | All in all the following topics should be taken into account when programming 435 | in \F: 436 | \begin{itemize} 437 | \item Use short word definitions. 438 | \item Words should do only one thing. 439 | \item Words should have no side effects. 440 | \item Indentation of control and data structures is vital for readability. 441 | \item Resist the temptation of using really clever programming trickery! 442 | :-) (It is hard, but\dots) 443 | \end{itemize} 444 | \end{frame} 445 | % 446 | \section{Miscellaneous} 447 | \begin{frame} 448 | \frametitle{Miscellaneous} 449 | \begin{itemize} 450 | \item Next steps: Add more (complex) words like rho etc. 451 | \item The source code of the \F-interpreter is available upon request 452 | and it is planned to setup a Source Forge project for \F. 453 | \item The power of Perl for implementing interpreters and the like is 454 | remarkable -- the complete \F-interpreter currently consists of 455 | only about 700 lines of code. 456 | \item I would like to thank Mr. Thomas Kratz for the many hours of peer 457 | programming during the implementation of the current \F-interpreter. 458 | \item The author can be reached at 459 | \begin{center} 460 | {\tt\bf ulmann@analogparadigm.com} 461 | \end{center} 462 | \end{itemize} 463 | \end{frame} 464 | \end{document} 465 | -------------------------------------------------------------------------------- /doc/lang5_programming.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bernd-ulmann/lang5/f0da7279bba222fb18cb0d6b0caa45f7cfd6f661/doc/lang5_programming.pdf -------------------------------------------------------------------------------- /examples/apple.5: -------------------------------------------------------------------------------- 1 | : d2c(*,*) 2 compress 'c dress ; # Make a complex number. 2 | 3 | : iterate(c) [0 0](c) "dup * over +" steps reshape execute ; 4 | 5 | : print_line(*) "#*+-. " "" split swap subscript "" join . "\n" . ; 6 | 7 | 75 iota 45 - 20 / # x coordinates 8 | 29 iota 14 - 10 / # y cordinates 9 | 'd2c outer # Make complex matrix. 10 | 11 | 10 'steps set # How many iterations? 12 | 13 | iterate abs int 5 min 'print_line apply # Compute & print 14 | -------------------------------------------------------------------------------- /examples/bargraph.5: -------------------------------------------------------------------------------- 1 | # Generate a string consisting of n (from TOS) "-" and terminated by CR/LF. 2 | : print_bar(*) "-" 1 compress swap reshape "\n" append "" join . ; 3 | 4 | # Create a vector containing the width of the bargraph to be printed 5 | 21 iota 10 / 3.14159265 * sin 20 * 25 + int 6 | 7 | print_bar # Apply the word print_bar elementwise to this vector. 8 | -------------------------------------------------------------------------------- /examples/cantor.5: -------------------------------------------------------------------------------- 1 | : cantor 2 | : iterate 3 | : r(*) " " over 3 compress "" join ; 4 | "" split r "" join 5 | ; 6 | 'iterate swap reshape '- swap execute 7 | ; 8 | 9 | 4 cantor . "\n" . 10 | -------------------------------------------------------------------------------- /examples/cosine.5: -------------------------------------------------------------------------------- 1 | # 2 | # Approximation of the cosine function using a MacLaurin 3 | # series of 11 terms. The argument is expected on the TOS. 4 | # 5 | : mc_cos 6 | # Save x and the number of MacLaurin terms for future use. 7 | 'x set 9 'terms set 8 | 9 | # Generate a vector containing x ** (2 * i). 10 | terms iota dup defined x * swap 2 * dup 'v2i set ** 11 | 12 | # Generate a vector containing (2 * i)! and divide the 13 | # previous vector. 14 | v2i ! / 15 | 16 | # Generate a vector of the form [1 -1 1 -1 1 ...]. 17 | terms iota 1 + 2 % 2 * 1 - 18 | 19 | # Multiply both vectors and compute the sum of the 20 | # result's elements. 21 | * '+ reduce 22 | ; 23 | 24 | 3.14159265 mc_cos . 25 | -------------------------------------------------------------------------------- /examples/fibr.5: -------------------------------------------------------------------------------- 1 | : fib # Define a word named fib 2 | dup 2 < # Handle first 3 | if # two sequence 4 | drop 1 # elements. 5 | else # All other 6 | dup # elements end 7 | 1 - fib # here. 8 | swap 2 - fib 9 | + 10 | then 11 | ; 12 | 13 | 0 do # Make a loop running from 0 to 10 14 | dup fib . 1 + 15 | dup 10 > if break then 16 | loop 17 | -------------------------------------------------------------------------------- /examples/fibr_apply.5: -------------------------------------------------------------------------------- 1 | : fib(*) 2 | dup 2 < if drop 1 break then 3 | dup 1 - fib swap 2 - fib + 4 | ; 5 | 6 | 10 iota fib . 7 | -------------------------------------------------------------------------------- /examples/fibr_unary.5: -------------------------------------------------------------------------------- 1 | : fib(*) 2 | dup 2 < if drop 1 break then 3 | dup 1 - fib swap 2 - fib + 4 | ; 5 | 6 | 10 iota fib . 7 | -------------------------------------------------------------------------------- /examples/gauss_factorial.5: -------------------------------------------------------------------------------- 1 | # Define some simple words 2 | : gauss iota 1 + '+ reduce ; 3 | : factorial iota 1 + '* reduce ; 4 | 5 | 100 dup gauss . factorial . 6 | 7 | -------------------------------------------------------------------------------- /examples/gauss_factorial_unary.5: -------------------------------------------------------------------------------- 1 | # Define two unary words: 2 | : gauss(*) iota 1 + '+ reduce ; 3 | : factorial(*) iota 1 + '* reduce ; 4 | 5 | 10 iota dup gauss . factorial . 6 | -------------------------------------------------------------------------------- /examples/gol.5: -------------------------------------------------------------------------------- 1 | # 2 | # This is a 5-implementation of Conway's Game-of-Life. 3 | # 4 | # The basic idea is to create eight matrices, based on the Game-of-Life matrix, 5 | # where a 1 denotes a living cell while a 0 denotes a dead cell. These eight 6 | # matrices are the result of eight matrix rotations (left, right, up, down, 7 | # upper left, upper right, lower left, lower right). These eight matrices are 8 | # then summed to determine the number of neighbours of each cell. After that 9 | # the standard Game-of-Life-rules are applied to the original matrix and the 10 | # neighbour sum matrix to determine the new population. 11 | # 12 | : print_field # Pretty print the field of cells with a frame. 13 | : print_line(*) [" " "*"] swap subscript "" join '! . . '! . "\n" . ; 14 | 15 | dup shape expand drop swap drop 2 + '- swap reshape "" join dup . "\n" . 16 | swap 'print_line apply drop . "\n" . 17 | ; 18 | 19 | : iterate # Perform one Game-of-Life-iteration 20 | : rule(*,*) swap if dup 2 >= swap 3 <= && else 3 == then ; 21 | 22 | # Rotate the matrix in all eight directions and sum these eight matrices: 23 | dup [1 0] rotate swap 24 | dup [-1 0] rotate swap 25 | dup [0 1] rotate swap 26 | dup [0 -1] rotate swap 27 | dup [1 1] rotate swap 28 | dup [-1 1] rotate swap 29 | dup [1 -1] rotate swap 30 | dup [-1 -1] rotate swap 31 | 32 | 9 -1 _roll + + + + + + + rule 33 | ; 34 | 35 | # Setup the start matrix - in this case it only contains a glider and we 36 | # generate it by some matrix operations: 37 | 100 iota dup [34 45 55 54 53] swap in [10 10] reshape 38 | 39 | # Perform 100 iterations: 40 | "cls print_field iterate" 100 reshape execute 41 | -------------------------------------------------------------------------------- /examples/matrix_vector.5: -------------------------------------------------------------------------------- 1 | # Calculate the inner sum of a vector: 2 | : inner+(*) '+ reduce ; 3 | 4 | # Multiplication word: 5 | : mv* 6 | # Enclose the vector in another vector for apply: 7 | 1 compress 8 | 9 | * 10 | 'inner+ apply 11 | ; 12 | 13 | # Create a 3-by-3 matrix containing the values 1 to 9: 14 | 9 iota 1 + [3 3] reshape 15 | 16 | # Create a three-element vector [10 11 12]: 17 | 3 iota 10 + 18 | 19 | # Multiply the matrix with the vector: 20 | mv* . 21 | -------------------------------------------------------------------------------- /examples/perfect.5: -------------------------------------------------------------------------------- 1 | : p(*) 2 | dup dup 1 - iota 1 + dup rot swap 3 | % not select '+ reduce == 4 | ; 5 | 500 iota 1 + dup p select . 6 | -------------------------------------------------------------------------------- /examples/prime.5: -------------------------------------------------------------------------------- 1 | : prime_list 2 | 1 - iota 2 + # Generate a vector [2 .. TOS] 3 | dup dup dup # Make sure there are four identical vectors. 4 | '* outer # Outer product of the top two vectors. 5 | swap in # Generate a selection vector based on vector 6 | # and matrix. 7 | not # Invert the elements of this vector 8 | select # Use this vector to select elements from 9 | # the vector [2 .. TOS]. 10 | ; 11 | 12 | do 13 | "Please enter a number between 2 and 100: " . 14 | read 15 | dup 2 < if 16 | "\tToo small!\n" . drop 17 | else 18 | dup 100 > if 19 | "\tToo large!\n" . drop 20 | else 21 | break 22 | then 23 | then 24 | loop 25 | 26 | prime_list . 27 | -------------------------------------------------------------------------------- /examples/prime_2.5: -------------------------------------------------------------------------------- 1 | : prime_list 2 | dup 1 - iota 2 + 3 | swap 2 / int 1 - iota 2 + dup '* outer 4 | over in not select 5 | ; 6 | 7 | do 8 | "Please enter a number between 2 and 100: " . read 9 | dup 2 < if 10 | "\tToo small!\n" . drop 11 | else 12 | dup 100 > if "\tToo large!\n" . drop else break then 13 | then 14 | loop 15 | 16 | prime_list "Output: " . . 17 | -------------------------------------------------------------------------------- /examples/sine_curve.5: -------------------------------------------------------------------------------- 1 | # Generate a string consisting of n (from TOS) "-" and terminated 2 | # by CR/LF. 3 | : print_dot(*) " " 1 compress swap reshape "*\n" append "" join . ; 4 | 5 | # Create a vector containing the width of the bargraph to be 6 | # printed. 7 | 21 iota 10 / 3.14159265 * sin 20 * 25 + int 8 | 9 | print_dot # Apply the word print_bar elementwise to this vector. 10 | -------------------------------------------------------------------------------- /examples/sort.5: -------------------------------------------------------------------------------- 1 | : get_upper(*) '; split expand drop swap drop ; 2 | : get_lower(*) '; split expand drop drop ; 3 | 4 | 'sort.data slurp dup 5 | get_lower swap get_upper 6 | grade swap drop subscript 7 | . 8 | -------------------------------------------------------------------------------- /examples/sort.data: -------------------------------------------------------------------------------- 1 | a ; 7 2 | b ; 1 3 | c ; 3 4 | -------------------------------------------------------------------------------- /examples/sum_of_cubes.5: -------------------------------------------------------------------------------- 1 | # Print all natural numbers < 1000 which are equal to the sum 2 | # of the cubes of their respective digits: 3 | 4 | : cube_sum(*) "" split 3 ** '+ reduce ; 5 | 999 iota 1 + dup dup cube_sum == select . 6 | -------------------------------------------------------------------------------- /examples/throw_dice.5: -------------------------------------------------------------------------------- 1 | : throw_dice 2 | # Make a vector of the form [6 6 6 ... 6]. 3 | 6 over reshape 4 | 5 | # Throw dice n times, retain integer part and make sure 6 | # the results are between 1 and 6. 7 | ? int 1 + 8 | 9 | # Sum over all results and divide by the number of values. 10 | '+ reduce swap / 11 | ; 12 | 13 | 100 throw_dice . 14 | -------------------------------------------------------------------------------- /examples/ulam.5: -------------------------------------------------------------------------------- 1 | : ulam_spiral 2 | : seq 3 | : zip(*,*) 2 compress " " join ; 4 | : subsubseq swap 2 2 compress reshape ; 5 | : subseq 6 | 0 pick [0 1] subsubseq 1 pick [1 0] subsubseq 7 | 2 pick 1 + [0 -1] subsubseq 3 pick 1 + [-1 0] subsubseq 8 | 5 roll drop append append append 9 | ; 10 | 11 | dup 2 reshape 1 compress 12 | over iota 2 * 1 + "subseq append" 3 pick reshape zip execute 13 | over 2 * [0 1] subsubseq append '+ spread 14 | ; 15 | 16 | : print_line(*) 17 | : rpl(*) dup not if drop "" then ; 18 | rpl "\t" join . "\n" . 19 | ; 20 | 21 | seq swap 2 * 1 + 2 ** iota 1 + dup prime swap and swap scatter 22 | 'print_line apply drop 23 | ; 24 | 25 | 4 ulam_spiral 26 | -------------------------------------------------------------------------------- /lang5: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use File::Spec::Functions; 7 | use FindBin qw/$Bin/; 8 | use lib catfile($Bin, 'perl_modules'); 9 | use Getopt::Long qw/:config require_order/; 10 | use Term::ReadLine; 11 | use Time::HiRes qw(gettimeofday tv_interval); 12 | 13 | use Data::Dumper; 14 | $Data::Dumper::Varname = undef; 15 | $Data::Dumper::Indent = 1; 16 | 17 | use Lang5; 18 | 19 | our $VERSION = $Lang5::VERSION; 20 | 21 | $| = 1; 22 | 23 | sub execute { 24 | my($fip, $lines, $out) = @_; 25 | 26 | $fip->add_source_line($_) 27 | for @$lines; 28 | 29 | $fip->execute(); 30 | 31 | if ( $fip->error() ) { 32 | print $out "Error: "; 33 | print $out $fip->{_last_error} if $fip->{_last_error}; 34 | print $out "\nHistory: "; 35 | print $out "$_ " for (@{$fip->{_exec_hist}}); 36 | print $out "\n"; 37 | } 38 | } 39 | 40 | my $term = ($^O eq 'MSWin32' or $^O eq 'VMS') 41 | ? Term::ReadLine::Stub->new('5') 42 | : Term::ReadLine->new('5'); 43 | 44 | #my $OUT = $term->OUT || \*STDOUT; 45 | my $OUT = \*STDOUT; 46 | 47 | my %opt = qw/debug_level ERROR width 80/; 48 | GetOptions( 49 | \%opt, 50 | 'debug_level=s', 51 | 'format=s', 52 | 'interactive', 53 | 'nolibs', 54 | 'statistics', 55 | 'benchmark', 56 | 'version', 57 | 'width=s', 58 | 'time', 59 | 'evaluate=s@', 60 | 'steps=s', 61 | ) or usage(1); 62 | 63 | $opt{interactive} = 1 unless @ARGV; 64 | 65 | my $line_count = 0; 66 | 67 | my $fip = Lang5->new( 68 | log_level => $opt{debug_level}, 69 | number_format => $opt{format}, 70 | steps => $opt{steps}, 71 | text_callback => sub { 72 | $line_count += tr/\n/\n/ for @_; 73 | print $OUT @_; 74 | }, 75 | libdir => "$Bin/lib", 76 | libautoload => !$opt{nolibs}, 77 | ); 78 | 79 | $SIG{INT} = sub { 80 | print $OUT "CTRL-C pressed.\n"; 81 | $fip->set_break(); 82 | }; 83 | 84 | print $OUT "lang5 version $Lang5::VERSION\n" if $opt{version}; 85 | 86 | my $start_time = [ gettimeofday() ]; 87 | 88 | execute($fip, [ join(' ', @{ $opt{evaluate} }) ], $OUT) 89 | if $opt{evaluate}; 90 | 91 | exit if $fip->exit_called(); 92 | 93 | if ( @ARGV ) { 94 | for my $fn ( @ARGV ) { 95 | 96 | print $OUT "loading $fn\n"; 97 | 98 | open(my $fh, '<', $fn) 99 | or die "could not read from $fn, $!"; 100 | my @lines = <$fh>; 101 | close($fh); 102 | 103 | execute($fip, \@lines, $OUT); 104 | 105 | last if $fip->error() or $fip->break_called(); 106 | } 107 | } 108 | 109 | if ( $opt{interactive} and !$opt{evaluate} ) { 110 | 111 | while ( defined (my $line = $term->readline('lang5> ')) ) { 112 | 113 | next unless $line =~ /\S/; 114 | 115 | $term->addhistory($line) if $line =~ /\S/; 116 | 117 | # keep track of number of output lines 118 | my $last_line_count = $line_count; 119 | 120 | # $line_count will eventually be incremented by the callback 121 | my $t0 = [ gettimeofday() ]; 122 | 123 | execute($fip, [$line], $OUT); 124 | 125 | # linefeed if needed 126 | print $OUT "\n" if $last_line_count == $line_count; 127 | 128 | printf $OUT "t: %.3fs\n", tv_interval($t0) if $opt{time}; 129 | print "\n" if $^O eq 'VMS'; 130 | 131 | last if $fip->exit_called(); 132 | } 133 | } 134 | 135 | if ( $opt{statistics} || $opt{benchmark}) { 136 | 137 | print $OUT '=' x 79, "\nStatistics:\n", '-' x 79, "\n"; 138 | 139 | my $counter = 0; 140 | my $stats = $fip->statistics(); 141 | 142 | for my $key ( sort{ $opt{benchmark} ? 143 | $stats->{$b} <=> $stats->{$a} : 144 | $a cmp $b } keys %$stats ) { 145 | printf $OUT "%-25s: %10d ! ", $key, $stats->{$key}; 146 | print $OUT "\n" if !(++$counter % 2); 147 | } 148 | print $OUT "\n" if $counter % 2; 149 | print $OUT '-' x 79, "\n"; 150 | } 151 | 152 | printf $OUT "Time consumed: %.3fs\n", tv_interval($start_time) if $opt{time}; 153 | 154 | sub usage { 155 | print <<"END"; 156 | usage: $0 [-b] [-d ] [-e ] [-f ] [-i] 157 | [-n] [-s] [-t] [-v] [-w ] [file1 [file2 ...]] 158 | 159 | params: 160 | -b (--benchmark) print statistics sorted by number of calls 161 | -d (--debug_level) set the debug level (default ERROR); valid values 162 | are TRACE, DEBUG, INFO, WARN, ERROR, FATAL 163 | -e (--evaluate) evaluate string as source code line; can occur 164 | multiple times 165 | -f (--format) default number format (sprintf format string) 166 | -i (--interactive) run in interactive mode; specified files will be 167 | run before entering interactive mode 168 | -n (--nolibs) skip autoloading 5's standard libraries 169 | -s (--statistics) print statistical information on program exit 170 | -t (--time) print time consumed after each execution 171 | -v (--version) display the version of the interpreter 172 | -w (--width) format output according to the terminal width 173 | END 174 | exit($_[0]); 175 | } 176 | -------------------------------------------------------------------------------- /lang5.vim: -------------------------------------------------------------------------------- 1 | " 5 syntax file 2 | " Language: 5 3 | " Maintainer: Bernd Ulmann 4 | " Last Change: 22-APR-2011 5 | " Filenames: *.5 6 | " URL: http://lang5.sourceforge.net 7 | 8 | " 9 | " To use this syntax highlighting file just add the following three lines to 10 | " your .vimrc: 11 | " 12 | " syntax on 13 | " au BufRead,BufNewFile *.5 set filetype=5 14 | " au! Syntax 5 source 15 | " 16 | " On Mac OS X it might be worthwhile to set the environment variable TERM 17 | " to xterm-color to get real colors displayed in vim. :-) 18 | " 19 | 20 | syn match Integer '\<-\=[0-9.]*[0-9.]\+\>' 21 | syn match Integer '\<&-\=[0-9.]*[0-9.]\+\>' 22 | syn match Float '\<-\=\d*[.]\=\d\+[DdEe]\d\+\>' 23 | syn match Float '\<-\=\d*[.]\=\d\+[DdEe][-+]\d\+\>' 24 | 25 | syn region CharacterString start=+\.*\"+ end=+"+ end=+$+ 26 | syn region CharacterString start=+s\"+ end=+"+ end=+$+ 27 | syn region CharacterString start=+c\"+ end=+"+ end=+$+ 28 | 29 | syn keyword Stack .. .s clear depth drop dup 2dup ndrop over pick _roll roll 30 | syn keyword Stack rot swap 31 | 32 | syn keyword Array append apply collapse compress dreduce dress dressed expand 33 | syn keyword Array strip 34 | syn keyword Array extract grade in iota join length outer reduce remove 35 | syn keyword Array reshape reverse select shape slice split subscript 36 | 37 | syn keyword IO . close eof fin fout open read unlink slurp 38 | 39 | syn keyword Operators <=> cmp "||" && ! ? 40 | syn keyword Operators + - * / % ** & | "^" == != > < >= <= 41 | syn keyword Operators abs amean and choose corr cmean cos defined eq ne gt lt ge le 42 | syn keyword Operators atan2 distinct gmean hmean hoelder inner+ int median neg 43 | syn keyword Operators not or prime qmean sin sqrt subset 44 | syn keyword Operators min max re im polar complex 45 | 46 | syn keyword Control break do loop if else then 47 | 48 | syn keyword Misc execute exit gplot help load panic save system type ver 49 | syn keyword Misc pi e eps 50 | 51 | syn keyword VarWord : ; .ofw .v del eval explain set vlist wlist 52 | 53 | syn region CommentString start="#" end=+$+ 54 | 55 | if version >= 508 || !exists("did_5_syn_inits") 56 | if version < 508 57 | let did_5_syn_inits = 1 58 | command -nargs=+ HiLink hi link 59 | else 60 | command -nargs=+ HiLink hi def link 61 | endif 62 | 63 | HiLink Integer Number 64 | HiLink Float Number 65 | HiLink CharacterString String 66 | HiLink Stack Special 67 | HiLink Array Function 68 | HiLink IO Statement 69 | HiLink Operators Operator 70 | HiLink Control Conditional 71 | HiLink Misc Define 72 | HiLink VarWord Debug 73 | HiLink CommentString Comment 74 | 75 | delcommand HiLink 76 | endif 77 | 78 | let b:current_syntax = "5" 79 | -------------------------------------------------------------------------------- /lang5.zip: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bernd-ulmann/lang5/f0da7279bba222fb18cb0d6b0caa45f7cfd6f661/lang5.zip -------------------------------------------------------------------------------- /lib/mathlib.5: -------------------------------------------------------------------------------- 1 | # 2 | # mathlib.5 contains various word definitions to deal with sets, 3 | # statistics or to plot data. 4 | # 5 | # This module makes use of the following dresses: 6 | # 7 | # (c) Complex numbers 8 | # (m) Matrix 9 | # (p) Polar coordinates 10 | # (s) Set 11 | # (v) Vector 12 | 13 | "loading mathlib.5: " . 14 | 15 | #========================================================================== 16 | "Const.." . 17 | 18 | # Useful constants: 19 | : pi 1 1 atan2 4 * ; 20 | : e 1 exp ; 21 | : eps 1.e-10 ; # This is used in comparison operators etc. 22 | 23 | #========================================================================== 24 | "Basics.." . 25 | 26 | # Calculate the factorial. 27 | : !(*) iota 1 + '* reduce ; 28 | 29 | # Absolute value. 30 | : abs(*) dup 0 < if neg then ; 31 | 32 | # Very straight-forward and non-clever implementation of the choose 33 | # operator -- it expects n k (TOS) on the stack: 34 | : choose(*,*) 35 | 2dup - 0 < if "choose: TOS must be <= TOS-1!\n" panic then 36 | 2dup - ! rot ! rot ! rot * / 37 | ; 38 | 39 | # Dual logarithm: 40 | : ld 41 | ln 2 ln / 42 | ; 43 | 44 | # Brigg's logarithm: 45 | : lg 46 | ln 10 ln / 47 | ; 48 | 49 | # Maximum of the two topmost stack elements: 50 | : max(*,*) 2dup - 0 < if swap then drop ; 51 | 52 | # Minimum of the two topmost stack elements: 53 | : min(*,*) 2dup - 0 > if swap then drop ; 54 | 55 | #========================================================================== 56 | "Set.." . 57 | 58 | # distinct removes all elements from a set which occur more than once. As a 59 | # side effect the resulting distinct set will be sorted. 60 | : distinct(s) 61 | strip 62 | length 2 < if 's dress break then # Nothing to do for an empty set. 63 | grade subscript # Sort the array representing the set. 64 | dup dup 65 | [-1] remove [undef] swap append # Right shift the sorted array. 66 | == not select # Determine the duplicates, negate the 67 | # resulting boolean vector and select 68 | 's dress # the unique elements. 69 | ; 70 | 71 | # Return the intersection of two sets. 72 | # The result is a set without duplicates. 73 | : intersect(s,s) 74 | distinct strip swap distinct strip over in select 's dress 75 | ; 76 | 77 | # subset expects two sets on the stack and tests if the one on the TOS is 78 | # a subset of the one below it. In this case a 1 is left on the TOS, 79 | # otherwise 0 is returned. 80 | : subset(s,s) strip swap strip swap in '&& reduce ; 81 | 82 | # Return the union of two sets without duplicates. 83 | : union(s,s) strip swap strip append 's dress distinct ; 84 | 85 | #========================================================================== 86 | "Stat.." . 87 | 88 | # Calculate arithmetic mean of the elements of a vector. 89 | : amean 90 | depth 1 < if "amean: Stack is empty!\n" panic then 91 | type 'A ne if "amean: TOS is not an array!\n" panic then 92 | length 0 == if drop 0 break then 93 | dup '+ reduce swap length swap drop / 94 | ; 95 | 96 | # Compute the cubic mean of the elements of a vector: 97 | # ((x ** 3 + x ** 3 + ... + x ** 3) / n) ** (1 / 3) 98 | # 0 1 n - 1 99 | : cmean 100 | depth 1 < if "cmean: Stack is empty!\n" panic then 101 | type 'A ne if "cmean: TOS is not an array!\n" panic then 102 | length 0 == if drop 0 break then 103 | 3 hoelder 104 | ; 105 | 106 | # Compute the Pearson correlation coefficient: 107 | : corr 108 | depth 2 < if "corr: Not enought elements on stack!\n" panic then 109 | type 'A ne if "corr: TOS is not an array!\n" panic then 110 | length '_x_len set 111 | swap 112 | type 'A ne if "corr: TOS-1 is not an array!\n" panic then 113 | length '_y_len set 114 | _x_len _y_len != if "corr: Array lengths differ!\n" panic then 115 | 116 | dup '+ reduce '_sy set 117 | dup dup * '+ reduce '_sy2 set 118 | swap 119 | dup '+ reduce '_sx set 120 | dup dup * '+ reduce '_sx2 set 121 | * '+ reduce '_sxy set 122 | _x_len _sxy * _sx _sy * - 123 | _x_len _sx2 * _sx dup * - sqrt 124 | _x_len _sy2 * _sy dup * - sqrt 125 | * / 126 | ; 127 | 128 | # Compute the geometric mean of the elements of a vector: 129 | # (x * x * ... * x ) ** (1 / n) 130 | # 0 1 n - 1 131 | : gmean 132 | depth 1 < if "gmean: Stack is empty!\n" panic then 133 | type 'A ne if "gmean: TOS is not an array!\n" panic then 134 | length 0 == if drop 0 break then 135 | length swap '* reduce swap 1 swap / ** 136 | ; 137 | 138 | # Compute the harmonic mean of the elements of a vector: 139 | # n / (1 / x + 1 / x + ... + 1 / x ) 140 | # 0 1 n - 1 141 | : hmean 142 | depth 1 < if "hmean: Stack is empty!\n" panic then 143 | type 'A ne if "hmean: TOS is not an array!\n" panic then 144 | length 0 == if drop 0 break then 145 | -1 hoelder 146 | ; 147 | 148 | # Compute the hoelder mean of the elements of a vector: 149 | # ((x ** k + x ** k + ... + x ** k) / n) ** (1 / k) 150 | # 0 1 n - 1 151 | : hoelder 152 | depth 2 < 153 | if "hoelder: This word needs two words on the stack!\n" panic then 154 | type 'S ne if "hoelder: TOS is no a scalar!\n" panic then 155 | swap type 'A ne if "hoelder: TOS-1 is not an array!\n" panic then swap 156 | over length swap drop 0 == if drop drop 0 break then 157 | swap length swap 2 pick ** '+ reduce swap / 1 rot / ** 158 | ; 159 | 160 | # Compute the median of the elements of a vector. The result is computed 161 | # like this for a sorted vector: 162 | # / x for an odd number of elements 163 | # ! (n + 1) / 2 164 | # x = < 165 | # median ! (x + x ) / 2 for an even number of elts 166 | # \ n / 2 n / 2 + 1 167 | # 168 | : median 169 | depth 1 < if "median: Stack is empty!\n" panic then 170 | type 'A ne if "median: TOS is not an array!\n" panic then 171 | length 0 == if drop 0 break then 172 | grade subscript # Sort the vector elements. 173 | length dup 2 % 174 | 0 == if # The vector has an even number of elements. 175 | 2 / 2dup 176 | 1 - 1 compress subscript expand drop 177 | rot rot 178 | 1 compress subscript expand drop 179 | + 2 / 180 | else # Odd number of vector elements. 181 | 1 + 2 / 1 - 1 compress subscript expand drop 182 | then 183 | ; 184 | 185 | # Compute the quadratic mean of the elements of a vector: 186 | # sqrt((x ** 2 + x ** 2 + ... + x ** 2) / n) 187 | # 0 1 n - 1 188 | : qmean 189 | depth 1 < if "qmean: Stack is empty!\n" panic then 190 | type 'A ne if "qmean: TOS is not an array!\n" panic then 191 | length 0 == if drop 0 break then 192 | 2 hoelder 193 | ; 194 | 195 | # Compute the standard deviation for the values of a vector: 196 | # 197 | : stddev 198 | length 1 - swap 199 | dup amean - 2 ** '+ reduce 200 | swap / 201 | sqrt 202 | ; 203 | 204 | #========================================================================== 205 | "Cplx.." . # Functionality for dealing with complex numbers. 206 | 207 | # Overload 'abs to return the absolute value of a complex number. 208 | : abs(c) 209 | strip 2 ** '+ reduce sqrt 210 | ; 211 | 212 | # Overload 'neg to perform the complement operation on a complex number. 213 | : neg(c) 214 | strip [1 -1] * 'c dress 215 | ; 216 | 217 | # Addition of two complex numbers. 218 | : +(c,c) 219 | strip swap strip + 'c dress 220 | ; 221 | 222 | # Subtraction of two complex numbers. 223 | : -(c,c) 224 | strip swap strip swap - 'c dress 225 | ; 226 | 227 | # Multiplication of two complex numbers. 228 | : *(c,c) 229 | strip swap strip swap 230 | [0 1 0 1] subscript swap [0 1 1 0] subscript 231 | * expand drop 232 | + rot rot - swap 233 | 2 compress 'c dress 234 | ; 235 | 236 | # Division of two complex numbers. 237 | : /(c,c) 238 | strip dup 2 ** '+ reduce 239 | rot strip rot 240 | [0 1 0 1] subscript swap [0 1 1 0] subscript 241 | * reverse expand drop 242 | + rot rot swap - 2 pick / rot rot swap / swap 243 | 2 compress 'c dress 244 | ; 245 | 246 | # Return the real part of a complex number. 247 | : re(c) 248 | strip expand drop drop 249 | ; 250 | 251 | # Return the imaginary part of a complex number. 252 | : im(c) 253 | strip expand drop swap drop 254 | ; 255 | 256 | # Convert a complex number to a polar coordinate tuple. 257 | : polar(c) 258 | strip dup 259 | 2 ** '+ reduce sqrt # This yields the radius. 260 | swap 261 | dup [0 0] == '&& reduce 262 | if "Can not convert zero cplx to polar!\n" panic then 263 | expand drop atan2 # This yields phi. 264 | 2 compress 'p dress # Make a polar coordinate tuple. 265 | ; 266 | 267 | # Convert a polar coordinate tuple to a complex number. 268 | : complex(p) 269 | strip expand drop 2dup 270 | cos * rot rot sin * 271 | 2 compress 'c dress 272 | ; 273 | 274 | # Overload == for comparing complex numbers. 275 | : ==(c,c) 276 | strip swap strip - abs eps < '&& reduce 277 | ; 278 | 279 | # Overload != for comparing complex numbers. 280 | : !=(c,c) 281 | strip swap strip - abs eps > '|| reduce 282 | ; 283 | 284 | #========================================================================== 285 | "P.." . 286 | 287 | # Overload == for polar tuples. 288 | : ==(p,p) 289 | strip swap strip - abs eps < '&& reduce 290 | ; 291 | 292 | # Overload != for polar tuples. 293 | : !=(p,p) 294 | strip swap strip - abs eps > '|| reduce 295 | ; 296 | 297 | #========================================================================== 298 | "LA.." . 299 | 300 | # Overload * for matrix-vector-multiplication. 301 | : *(m,v) 302 | # Calculate the inner sum of a vector: 303 | : inner+(*) '+ reduce ; 304 | 305 | swap strip shape rot strip swap reshape * 306 | 'inner+ apply 307 | 'v dress 308 | ; 309 | 310 | : *(m,m) # Overload '* for matrix-matrix-multiplication 311 | # If we multiply an n*m matrix (columns*rows) by an m*n matrix using the 312 | # already existing matrix-vector-multiplication, we will need m copies of 313 | # the first matrix. First of all, let us determine m (as a side effect, 314 | # this second matrix looses its matrix dress which will be useful soon): 315 | strip shape [1] subscript expand drop 316 | 317 | # Now we compress the first matrix into an array and reshape it so that 318 | # this array will contain m copies of the original matrix: 319 | rot 1 compress swap reshape 320 | 321 | # Now swap the two arrays 322 | swap 323 | 324 | # To apply the already existing matrix-vector-multiplication to these two 325 | # arrays we have to transpose the topmost two dimensional array and 326 | # transform it into a one dimensional array of vectors: 327 | : a2v(*) 'v dress ; 328 | strip 1 transpose 'a2v apply 329 | 330 | # Now let us apply the existing matrix-vector-multiplication: 331 | * 332 | 333 | # Since this yields a one dimensional array of vectors, we have to strip 334 | # the array elements and dress the array itself as being a matrix: 335 | : v2a(v) strip ; 336 | 'v2a apply 337 | 338 | # The result is still transposed, so perform another transposition and 339 | # dress it: 340 | 1 transpose 'm dress 341 | ; 342 | 343 | # Create a identity matrix 344 | : idmatrix(*) iota dup '== outer 'm dress ; 345 | 346 | # Perform the scalar product of two vectors 347 | : *(v,v) strip swap strip * '+ reduce ; 348 | 349 | # Perform a tensor multiplication 350 | : x(v,v) '* outer 1 transpose collapse ; 351 | #========================================================================== 352 | "Graph.." . 353 | 354 | # array (the name reflects the fact that only the y-coordinates are fed 355 | # into gnuplot). 356 | # gplot plots a graph based on the elements of a single, one dimensional 357 | : gplot 358 | # _gplot_write_data is a unary word to be used with apply to write the 359 | # data to be plotted to the gnuplot scratch data file. 360 | : _gplot_write_data(*) . ; 361 | 362 | depth 1 < if "gplot: Stack is empty!\n" panic then 363 | type 'A ne if "gplot: TOS is not an array!\n" panic then 364 | 365 | "_5_gplot.data" '__gplot_data_name set 366 | "_5_gplot.cmd" '__gplot_cmd_name set 367 | 368 | '> __gplot_data_name open '__gplot_fh set 369 | __gplot_fh fout 370 | '_gplot_write_data apply drop 371 | __gplot_fh close 372 | 373 | '> __gplot_cmd_name open '__gplot_fh set 374 | __gplot_fh fout 375 | "set key off\n" . 376 | "plot \"" __gplot_data_name "\" with lines\n" 3 compress "" join . 377 | __gplot_fh close 378 | 379 | STDOUT fout 380 | 381 | 'gnuplot __gplot_cmd_name 2 compress " " join system drop 382 | __gplot_data_name unlink 383 | __gplot_cmd_name unlink 384 | ; 385 | 386 | #========================================================================== 387 | "Trig.." . 388 | 389 | : tan dup sin swap cos / ; 390 | 391 | #========================================================================== 392 | "NT.." . 393 | 394 | # Places 1 on TOS if TOS was prime, 0 otherwise. 395 | : prime(*) 396 | type 'S ne if "prime: TOS is not scalar!\n" panic then 397 | dup 1 == if drop 0 then 398 | dup 4 < if break then 399 | dup sqrt 2 / int iota 1 + 2 * 1 + [2] swap append % '&& reduce 400 | ; 401 | 402 | # Return the gcd of two integers 403 | : gcd(*,*) 404 | do 405 | 2dup 0 > swap 0 > && not if break then 406 | 2dup <= if 407 | over - 408 | else 409 | swap over - swap 410 | then 411 | loop 412 | dup 0 == if drop else swap drop then 413 | ; 414 | 415 | # Convert a hexadecimal number to decimal. The hex-number is an 416 | # upper-case # string. 417 | : h2d 418 | uc "0123456789ABCDEF" "" split swap "" split length iota reverse 419 | 16 swap ** rot rot index collapse * '+ reduce 420 | ; 421 | 422 | "\n" . 423 | -------------------------------------------------------------------------------- /lib/stdlib.5: -------------------------------------------------------------------------------- 1 | ### 2 | ### stdlib.5, the standard library for 5. 3 | ### 4 | ### Internal variables are always prefixed by '_' to avoid collisions 5 | ### between different words. 6 | ### 7 | 8 | "loading stdlib.5: " . 9 | 10 | #========================================================================== 11 | "Const.." . 12 | : STDIN 0 ; 13 | : STDOUT 1 ; 14 | : STDERR 2 ; 15 | 16 | #========================================================================== 17 | "Misc.." . # Housekeeping words. 18 | 19 | # Stack pretty printer (non-desctructive). 20 | : .s 21 | depth 0 == if "Stack is empty!\n" . break then 22 | "vvvvvvvvvvvvvvvvvvvv Begin of stack listing vvvvvvvvvvvvvvvvvvvv\n" . 23 | "Stack contents (TOS at bottom):\n" . 24 | depth compress dup 25 | do 26 | length 0 == if break then 27 | 0 extract . 28 | loop 29 | drop expand drop 30 | "\n^^^^^^^^^^^^^^^^^^^^^ End of stack listing ^^^^^^^^^^^^^^^^^^^^^\n" . 31 | ; 32 | 33 | # Print a list of all variables known to the interpreter. 34 | : .v 35 | "Variables:\n" . 36 | vlist # Get list of all variable names. 37 | do # Process the list. 38 | length 0 == if break then # Anything left to print? 39 | 0 extract # Get name to be printed. 40 | dup "\t--->\t" # Prepare string to be printed. 41 | rot eval # Get value of variable. 42 | "\n" 4 compress "'" join . # Make string and print line. 43 | loop drop 44 | ; 45 | 46 | # CLear Screen (assuming a VT100 terminal): 47 | : cls 27 chr "[2J" 27 chr "[;H" 4 compress "" join . ; 48 | 49 | # explain a word. 50 | : explain dump . ; 51 | 52 | # Save the current workspace - expects destination filename on TOS. 53 | : save 54 | : uxplain(*) explain ; 55 | 56 | depth 1 < if "save: Not enough elements on stack!\n" panic then 57 | type 'S ne if "save: scalar as filename expected!\n" . break then 58 | "Saving workspace to " over ": " 3 compress "" join . 59 | '> swap open '_save_destination set 60 | _save_destination fout 61 | wlist vlist append uxplain drop 62 | STDOUT fout 63 | _save_destination close 64 | "done\n" . 65 | ; 66 | 67 | # Read a file (the filename is expected to be in TOS) and create an array 68 | # containing one record of this file per element. 69 | : slurp 70 | depth 1 < if "slurp: Not enough elements on stack!\n" panic then 71 | type 'S ne if "slurtp: Scalar as filename expected!\n" panic then 72 | '< swap open '__slurp_fh set __slurp_fh fin 73 | [] 74 | do 75 | eof if break then 76 | read append 77 | loop 78 | __slurp_fh close 79 | STDIN fin 80 | ; 81 | 82 | #========================================================================== 83 | "Stk.." . 84 | 85 | # Duplicate the two topmost elements on the stack. 86 | : 2dup 87 | depth 2 < if "2dup: Not enough elements on stack!\n" panic then 88 | over over 89 | ; 90 | 91 | # Remove all elements from stack. 92 | : clear 93 | depth 0 > if depth compress drop then 94 | ; 95 | 96 | # Generalized drop, TOS = depth. 97 | : ndrop 98 | depth 1 < if "ndrop: Not enough elements on stack!\n" panic then 99 | type 'S ne if "ndrop: TOS is not scalar!\n" panic then 100 | compress drop 101 | ; 102 | 103 | # Generalized over - it expects the position of the element to be picked 104 | # at the TOS. 105 | : pick 106 | depth 1 < if "pick: Not enough elements on stack!\n" panic then 107 | type 'S ne if "pick: TOS is not scalar!\n" panic then 108 | compress swap dup rot rot 1 compress append expand drop 109 | ; 110 | 111 | # Generalized rot, TOS = depth. 112 | : roll 1 _roll ; 113 | 114 | # rotate the topmost 3 elements 115 | : rot 3 1 _roll ; 116 | 117 | #========================================================================== 118 | "Struct.." . 119 | 120 | # Append a scalar or a vector to another vector. 121 | : append 122 | depth 2 < if "append: Not enough elements on stack!\n" panic then 123 | type 'S eq if 1 compress then 124 | type 'A ne if "append: Not an array!\n" panic then 125 | swap 126 | expand dup 2 + roll 127 | expand dup 2 + roll 128 | + compress 129 | ; 130 | 131 | # Deep reduce - this word will reduce a nested structure to a single scalar 132 | # regardless if its depth. 133 | : dreduce 134 | over type 'A ne if "dreduce: TOS-1 is not an array!\n" panic then drop 135 | swap collapse swap reduce 136 | ; 137 | 138 | # Extract an element from an array (subscript and remove combined) - TOS 139 | # contains the element's number while TOS-1 contains the array. 140 | : extract 141 | depth 2 < if "extract: Not enough elements on stack!\n" panic then 142 | type 'S ne if "extract: TOS is not scalar!\n" panic then 143 | over 144 | type 'A ne if "extract: TOS-1 is not an array!\n" panic then drop 145 | 2dup 1 compress subscript rot rot remove swap expand drop 146 | ; 147 | 148 | "\n" . 149 | -------------------------------------------------------------------------------- /make_dist_kit.bash: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | if [ -d /tmp/lang5 ]; then 3 | echo "Directory exists - delete and recreate it." 4 | rm -rf /tmp/lang5 5 | fi 6 | 7 | echo "Creating directory structure." 8 | mkdir -p /tmp/lang5/{doc,examples,lib,perl_modules} 9 | 10 | echo "Copying files." 11 | cp lang5 lang5.vim README.md INSTALL.md /tmp/lang5 12 | cp examples/* /tmp/lang5/examples 13 | cp lib/* /tmp/lang5/lib 14 | cp -r perl_modules/ /tmp/lang5/perl_modules 15 | cp doc/*.pdf /tmp/lang5/doc/ 16 | 17 | echo "Compressing distribution kit." 18 | cd /tmp 19 | zip -r lang5.zip lang5 > /dev/null 20 | cd - > /dev/null 21 | mv /tmp/lang5.zip . 22 | rm -rf /tmp/lang5 23 | -------------------------------------------------------------------------------- /perl_modules/Array/DeepUtils.pm: -------------------------------------------------------------------------------- 1 | package Array::DeepUtils; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp; 7 | use Storable qw/dclone/; 8 | 9 | require Exporter; 10 | our @ISA = qw(Exporter); 11 | our @EXPORT_OK = qw/ 12 | binary collapse dcopy idx 13 | purge remove reshape rotate scatter shape subscript 14 | transpose unary value_by_path vector_iterator 15 | /; 16 | our %EXPORT_TAGS = ( 17 | 'all' => [ @EXPORT_OK ], 18 | ); 19 | 20 | our $VERSION = 0.2; 21 | our $DEBUG = 0; 22 | our $LastError = ''; 23 | 24 | my $NaV = bless(\my $dummy, 'NaV'); 25 | 26 | 27 | =pod 28 | 29 | =head1 NAME 30 | 31 | Array::DeepUtils - utilities for the manipulation of nested arrays 32 | 33 | =head1 VERSION 34 | 35 | This document refers to version 0.2 of Array::DeepUtils 36 | 37 | =head1 SYNOPSIS 38 | 39 | 40 | use Array::DeepUtils qw/:all/; 41 | 42 | binary( 43 | [1,2,3,4,5,6,7,8], 44 | [[1,1][2,2][3,3][4,4]], 45 | sub { $_[0] + $_[1] } 46 | ); 47 | 48 | yields: 49 | 50 | [ 51 | [ 2, 3 ], 52 | [ 5, 6 ], 53 | [ 8, 9 ], 54 | [ 11, 12 ], 55 | ] 56 | 57 | A more complex example: 58 | 59 | my $x = [1..9]; 60 | 61 | my $y = reshape($x, [3,3,3,3], $x); 62 | 63 | $y is now: 64 | 65 | [ 66 | [ 67 | [[1,2,3],[4,5,6],[7,8,9]], 68 | [[1,2,3],[4,5,6],[7,8,9]], 69 | [[1,2,3],[4,5,6],[7,8,9]], 70 | ], 71 | [ 72 | [[1,2,3],[4,5,6],[7,8,9]], 73 | [[1,2,3],[4,5,6],[7,8,9]], 74 | [[1,2,3],[4,5,6],[7,8,9]], 75 | ], 76 | [ 77 | [[1,2,3],[4,5,6],[7,8,9]], 78 | [[1,2,3],[4,5,6],[7,8,9]], 79 | [[1,2,3],[4,5,6],[7,8,9]], 80 | ] 81 | ]; 82 | 83 | 84 | my $z = dcopy($y, [[1,1,1,1],[2,2,2,2]]); 85 | 86 | $z is now: 87 | 88 | [ 89 | [ 90 | [[5,6],[8,9]], 91 | [[5,6],[8,9]], 92 | ], 93 | [ 94 | [[5,6],[8,9]], 95 | [[5,6],[8,9]], 96 | ] 97 | ]; 98 | 99 | my $c = reshape([], [2,2], collapse($z)); 100 | 101 | resulting in $c being: 102 | 103 | [[5,6],[8,9]] 104 | 105 | 106 | =head1 DESCRIPTION 107 | 108 | This module is a collection of subroutines for the manipulation of 109 | deeply nested arrays. It provides routines for iterating along 110 | coordinates and for setting, retrieving and deleting values. 111 | The functions binary and unary are provided for applying arbitrary 112 | operators as code references to deeply nested arrays. With shape() and 113 | reshape() there are methods to determine and change the dimensions. 114 | 115 | By default nothing is exported. The subroutines can be imported all at 116 | once via the ':all' tag. 117 | 118 | =head2 Subroutine short description 119 | 120 | L - appply a binary operator between two nested arrays 121 | 122 | L - flatten a nested array to a one dimensional vector 123 | 124 | L - extract part of a nested array between two vectors 125 | 126 | L - build an index vector for values of another vector 127 | 128 | L - remove elements by value from a nested array 129 | 130 | L - remove elements by index 131 | 132 | L - transform nested array by dimension vector 133 | 134 | L - rotate a data structure along its axes 135 | 136 | L - build a new data structure with data and index vector. 137 | 138 | L - get nested array dimension vector 139 | 140 | L - extract nested array values by index vector 141 | 142 | L - transpose a nested array 143 | 144 | L - appply a unary operator to all values of a nested array 145 | 146 | L - extract nested array values by coordinate vector 147 | 148 | L - creates a subroutine for iterating between two coordinates 149 | 150 | =cut 151 | 152 | 153 | =pod 154 | 155 | =head1 SUBROUTINES 156 | 157 | =head2 binary() 158 | 159 | B 160 | 161 | Recursively apply a binary operator represented by a subroutine 162 | reference to all elements of two nested data structures given in $aref1 163 | and $aref2 and set the resulting values in $aref2. $aref2 will also be 164 | returned. 165 | 166 | If these structures differ in shape they will be reshaped according to 167 | the larger structure. The value of $neutral_element will be used if one 168 | of the operands is undefined or does not exist ($neutral_element can 169 | also be a subroutine reference; it will be called on value retrieval and 170 | given $aref1 respectively $aref2 as only parameter). To be able to use 171 | methods as subroutines $object will be passed to the subroutine as first 172 | parameter when specified. Since binary() calls reshape() a given 173 | $fill_aref will be passed as the third parameter to reshape(). 174 | 175 | A simple example, after: 176 | 177 | my $v1 = [1,2,3]; 178 | my $v2 = [9,8,7]; 179 | my $func = sub { $_[0] * $_[1] } 180 | binary($v1, $v2, $func); 181 | 182 | $v2 will have a value of 183 | 184 | [9, 16, 21] 185 | 186 | Making it a bit more complicated: 187 | 188 | my $v1 = [1,2,3,4,5,6]; 189 | my $v2 = [9,8,7]; 190 | my $func = sub { $_[0] * $_[1] } 191 | binary($v1, $v2, $func); 192 | 193 | results in: 194 | 195 | [9,16,21,36,40,42] 196 | 197 | because missing values will be filled with the flattened structure 198 | repeated as often as it is needed, so the above is exactly the same as: 199 | 200 | my $v1 = [1,2,3,4,5,6]; 201 | my $v2 = [9,8,7,9,8,7]; 202 | my $func = sub { $_[0] * $_[1] } 203 | binary($v1, $v2, $func); 204 | 205 | Using the fill parameter gives the opportunity to assign the values 206 | used for filling. It will also be repeated when necessary. 207 | 208 | my $v1 = [1,2,3,4,5,6]; 209 | my $v2 = [9,8,7]; 210 | my $fill = [1,2]; 211 | my $func = sub { $_[0] * $_[1] }; 212 | binary($v1, $v2, $func, 1, undef, $fill); 213 | 214 | results in: 215 | 216 | [9,16,21,4,10,6]; 217 | 218 | because $v2 will have been reshaped to [9,8,7,1,2,1] before the 219 | multiplication. 220 | 221 | This works for vectors of arbitrary depth, so that: 222 | 223 | my $v1 = [[1,2,3], [4,5,6], [7,8,9]]; 224 | my $v2 = [[11,12], [13,14]]; 225 | my $fill = [1, -1]; 226 | my $func = sub { $_[0] * $_[1] }; 227 | binary($v1, $v2, $func, 1, undef, $fill); 228 | 229 | yields: 230 | 231 | [[11,24,3], [52,70,-6], [7,-8,9]] 232 | 233 | =cut 234 | 235 | sub binary { 236 | my($func, $neutral, $obj, $fill) = @_[2..5]; 237 | 238 | # param checks 239 | croak $LastError = 'binary: not a code ref' 240 | unless ref($func) eq 'CODE'; 241 | croak $LastError = 'binary: not an object' 242 | if $obj and !ref($obj); 243 | 244 | # determine the "bigger" vector 245 | # (run 'shape '* reduce' and compare) 246 | my @dims; 247 | my @inner; 248 | for my $i ( 0 .. 1 ) { 249 | $dims[$i] = shape($_[$i]); 250 | $dims[$i] = [1] unless @{ $dims[$i] }; 251 | $inner[$i] = 1; 252 | $inner[$i] *= $_ for @{ $dims[$i] }; 253 | } 254 | 255 | my $reshape_dim = $inner[0] >= $inner[1] ? $dims[0] : $dims[1]; 256 | 257 | # reshape both with reshape_dim vector 258 | for my $i ( 0 .. 1 ) { 259 | $_[$i] = [$_[$i]] unless ref($_[$i]) eq 'ARRAY'; 260 | $_[$i] = reshape($_[$i], $reshape_dim, $fill ? $fill : ()); 261 | } 262 | 263 | # create start and end vector 264 | my $start = [ map { 0 } @$reshape_dim ]; 265 | my $end = [ map { $_ - 1 } @$reshape_dim ]; 266 | 267 | # shortcut for empty arrays 268 | if ( !@$start or !@$end ) { 269 | $_[1] = []; 270 | return $_[1]; 271 | } 272 | 273 | # iterate over the arrays, call function and store 274 | # the value in second array 275 | my $iterator = vector_iterator($start, $end); 276 | 277 | while ( my ($vec) = $iterator->() ) { 278 | 279 | # get values with value_by_path() 280 | my @vals; 281 | for my $i ( 0 .. 1 ) { 282 | $vals[$i] = value_by_path($_[$i], $vec); 283 | $vals[$i] = (ref($neutral) eq 'CODE' ? $neutral->($_[$i]) : $neutral) 284 | if !defined($vals[$i]) or ref($vals[$i]) eq 'NaV'; 285 | } 286 | 287 | # call fuction and set value 288 | value_by_path( 289 | $_[1], 290 | $vec, 291 | $func->($obj ? ($obj, @vals) : @vals), 292 | ); 293 | } 294 | 295 | return $_[1]; 296 | } 297 | 298 | 299 | =pod 300 | 301 | =head2 collapse() 302 | 303 | B 304 | 305 | Collapse the referenced array of arrays of arbitrary depth, i.e 306 | flatten it to a simple array and return a reference to it. 307 | 308 | Example: 309 | 310 | collapse([[1,2,3],4,[5,[6,7,8,[9,0]]]]); 311 | 312 | will return: 313 | 314 | [1,2,3,4,5,6,7,8,9,0] 315 | 316 | =cut 317 | 318 | sub collapse { 319 | my($struct) = @_; 320 | 321 | croak $LastError = 'collapse: not an array reference' 322 | unless ref($struct) eq 'ARRAY'; 323 | 324 | my @result; 325 | 326 | # simply travel the array iteratively and store 327 | # every value in @result 328 | 329 | # element and index stack 330 | my @estack = ( $struct ); 331 | my @istack = ( 0 ); 332 | 333 | while ( @estack ) { 334 | 335 | # always opereate on the top of the stacks 336 | my $e = $estack[-1]; 337 | my $i = $istack[-1]; 338 | 339 | if ( $i <= $#$e ) { 340 | 341 | # in currrent array, if value is array ref 342 | # push next reference and a new index onto stacks 343 | if ( ref($e->[$i]) eq 'ARRAY' ) { 344 | push @estack, $e->[$i]; 345 | push @istack, 0; 346 | next; 347 | } 348 | 349 | # push value into result array 350 | push @result, $e->[$i]; 351 | } 352 | 353 | # after last item, pop last item and last index from stacks 354 | if ( $i >= $#$e ) { 355 | pop @estack; 356 | pop @istack; 357 | } 358 | 359 | # increment index for next fetch 360 | $istack[-1]++ if @istack; 361 | } 362 | 363 | return \@result; 364 | } 365 | 366 | 367 | =pod 368 | 369 | =head2 dcopy() 370 | 371 | B 372 | 373 | Extract a part of an deeply nested array between two vectors given in 374 | the array referenced by $coord_ref. This is done via an iterator 375 | generated with vector_iterator() running from the first to the second 376 | coordinate given. 377 | 378 | Example: 379 | 380 | dcopy([[1,2,3], [4,5,6], [7,8,9]], [[1,0], [2,1]]); 381 | 382 | will return 383 | 384 | [ [4,5], [7,8] ] 385 | 386 | This will work in either direction, so: 387 | 388 | dcopy([[1,2,3], [4,5,6], [7,8,9]], [[2,1], [1,0]]); 389 | 390 | will give: 391 | 392 | [ [8,7], [5,4] ] 393 | 394 | as expected. 395 | 396 | =cut 397 | 398 | sub dcopy { 399 | my($struct, $coord) = @_; 400 | 401 | # param checks 402 | croak $LastError = 'dcopy: not an array ref' 403 | unless ref($struct) eq 'ARRAY' and ref($coord) eq 'ARRAY'; 404 | 405 | croak $LastError = 'dcopy: coordinate vector with element count != 2!' 406 | unless @$coord == 2; 407 | 408 | croak $LastError = 'dcopy: coordinate vector elements have different length!' 409 | unless @{$coord->[0]} == @{$coord->[1]}; 410 | 411 | # simply iterate and set values in $dest 412 | my $iterator = vector_iterator( 413 | ref($coord->[0]) eq 'ARRAY' ? $coord->[0] : [$coord->[0]], 414 | ref($coord->[1]) eq 'ARRAY' ? $coord->[1] : [$coord->[1]] 415 | ); 416 | my $dest = []; 417 | while ( my ($svec, $dvec) = $iterator->() ) { 418 | value_by_path( 419 | $dest, 420 | $dvec, 421 | value_by_path($struct, $svec) 422 | ); 423 | } 424 | 425 | return $dest; 426 | } 427 | 428 | 429 | =pod 430 | 431 | =head2 idx() 432 | 433 | B 434 | 435 | Return an index vector that contains the indices of the elements of the 436 | first argument vector with respect to the second index vector. 437 | 438 | Example: 439 | 440 | idx([[1,3],[4,5]], [[1,2,3], [4,5,6], [7,8,9]]); 441 | 442 | will return: 443 | 444 | [[[0,0],[0,2]],[[1,0],[1,1]]] 445 | 446 | =cut 447 | 448 | sub idx { 449 | my ($aref1, $aref2) = @_; 450 | 451 | # param checks 452 | croak $LastError = 'idx: not an array ref' 453 | unless ref($aref1) eq 'ARRAY' and ref($aref2) eq 'ARRAY'; 454 | 455 | my ($dim1, $dim2) = (shape($aref1), shape($aref2)); 456 | my ($start1, $end1) = ([ map { 0 } @$dim1 ], [ map { $_ - 1 } @$dim1 ]); 457 | my ($start2, $end2) = ([ map { 0 } @$dim2 ], [ map { $_ - 1 } @$dim2 ]); 458 | my ($iterator1, $iterator2) = (vector_iterator($start1, $end1), 459 | vector_iterator($start2, $end2)); 460 | 461 | return [] unless scalar @$aref1; 462 | 463 | # Create a hash with indices of the elements of $aref2, making sure 464 | # that multiple occurrences of an element don't destroy the first 465 | # index of this element: 466 | my %lookup; 467 | while ( my($index) = $iterator2->() ) { 468 | my $value = value_by_path($aref2, $index); 469 | $lookup{$value} = $index if $value and !$lookup{$value}; 470 | } 471 | 472 | # Now lookup every single element from $aref1 in the lookup hash: 473 | while ( my($index) = $iterator1->() ) { 474 | my $position = $lookup{value_by_path($aref1, $index)}; 475 | value_by_path($aref1, $index, $position ? $position : []); 476 | } 477 | 478 | return $aref1; 479 | } 480 | 481 | 482 | =pod 483 | 484 | =head2 purge() 485 | 486 | B 487 | 488 | Remove all values from the array referenced by $aref that equal $what in 489 | a string comparison. 490 | 491 | Example: 492 | 493 | $v = [1,0,1,0,1,0,1,0]; 494 | purge($v, '0'); 495 | 496 | will have $v reduced to: 497 | 498 | [1,1,1,1] 499 | 500 | =cut 501 | 502 | sub purge { 503 | my $what = pop; 504 | 505 | croak $LastError = 'purge: not an array ref' 506 | unless ref($_[0]) eq 'ARRAY'; 507 | 508 | my @estack = ($_[0]); 509 | my @istack = ( $#{ $estack[-1] } ); 510 | 511 | while ( @estack ) { 512 | 513 | my $e = $estack[-1]; 514 | my $i = $istack[-1]; 515 | 516 | if ( $i >= 0 ) { 517 | 518 | # push next reference and a new index onto stacks 519 | if ( ref($e->[$i]) eq 'ARRAY' ) { 520 | push @estack, $e->[$i]; 521 | push @istack, $#{ $e->[$i] }; 522 | next; 523 | } 524 | 525 | splice(@$e, $i, 1) if $e->[$i] eq $what; 526 | 527 | } else { 528 | 529 | pop @estack; 530 | pop @istack; 531 | 532 | } 533 | 534 | $istack[-1]-- if @istack; 535 | 536 | } 537 | } 538 | 539 | 540 | =pod 541 | 542 | =head2 remove() 543 | 544 | B 545 | 546 | Remove all values with indices or coordinates given by $index or by the 547 | array referenced by $coordinate_aref from an array referenced by $aref. 548 | 549 | Example: 550 | 551 | my $v = [1,2,3,4,5,6,7,8,9,0]; 552 | remove($v, [1,2,3]); 553 | 554 | will have $v reduced to: 555 | 556 | [1,5,6,7,8,9,0] 557 | 558 | and: 559 | 560 | my $aref = [[1,2,3],[4,5,6],[7,8,9]]; 561 | 562 | remove($aref, [[0,1], [1,2], 2]); 563 | 564 | will leave: 565 | 566 | [[1,3],[4,5]] 567 | 568 | in $aref. 569 | 570 | =cut 571 | 572 | sub remove { 573 | my $coords = pop; 574 | 575 | croak $LastError = 'remove: not an array ref' 576 | unless ref($_[0]) eq 'ARRAY'; 577 | 578 | $coords = [$coords] 579 | unless ref($coords) eq 'ARRAY'; 580 | 581 | for ( @$coords ) { 582 | $_ = [$_] unless ref($_) eq 'ARRAY'; 583 | value_by_path($_[0], $_, $NaV) 584 | unless ref(value_by_path($_[0], $_)) eq 'NaV'; 585 | } 586 | 587 | purge($_[0], $NaV); 588 | } 589 | 590 | 591 | =pod 592 | 593 | =head2 reshape() 594 | 595 | B 596 | 597 | Create an array with the dimension vector given in $dims_aref and take 598 | the values from $aref provided there is a value at the given position. 599 | Additional values will be taken from the array referenced by $fill_aref 600 | or - if it is not provided - from a flattened (call to collapse()) 601 | version of the original array referenced by $aref. If the fill source is 602 | exhausted, reshape will start from index 0 again. This will be repeated 603 | until the destination array is filled. 604 | 605 | Example: 606 | 607 | reshape([[1,2,3]], [3, 3]); 608 | 609 | will return: 610 | 611 | [ [1,2,3], [1,2,3], [1,2,3] ] 612 | 613 | and: 614 | 615 | reshape([[1,2,3]], [3, 3], ['x']); 616 | 617 | will return: 618 | 619 | [ [1,2,3], ['x','x','x'], ['x','x','x'] ] 620 | 621 | =cut 622 | 623 | sub reshape { 624 | my($struct, $dims, $fill) = @_; 625 | 626 | if ( 627 | ref($struct) ne 'ARRAY' or 628 | ref($dims) ne 'ARRAY' or 629 | ( $fill and ref($fill) ne 'ARRAY' ) 630 | ) { 631 | $LastError = "usage: reshape(AREF, AREF[, AREF])"; 632 | croak $LastError; 633 | } 634 | 635 | return undef unless @$dims; 636 | return [] if $dims->[0] == 0; 637 | 638 | # get a flattened copy of the source 639 | $fill = collapse(dclone($struct)) 640 | unless $fill; 641 | @$fill = ( undef ) unless @$fill; 642 | 643 | my $start = [ map { 0 } @$dims ]; 644 | my $end = [ map { $_ - 1 } @$dims ]; 645 | 646 | my $iterator = vector_iterator($start, $end); 647 | 648 | my $i = 0; 649 | my $dest = []; 650 | while ( my ($vec) = $iterator->() ) { 651 | my $val = value_by_path($struct, $vec); 652 | value_by_path( 653 | $dest, 654 | $vec, 655 | ( ($val and ref($val) eq 'NaV') or ref($val) eq 'ARRAY' ) 656 | ? $fill->[$i++ % @$fill] 657 | : $val, 658 | 1, 659 | ); 660 | } 661 | 662 | return $dest; 663 | } 664 | 665 | 666 | =pod 667 | 668 | =head2 rotate() 669 | 670 | B 671 | 672 | Rotate a data structure along its axes. It is possible to perform more 673 | than one rotation at once, so rotating a two dimensional matrix along 674 | its x- and y-axes by +1 and -1 positions is no problem. 675 | 676 | Example: 677 | 678 | rotate([[1, 2, 3], [4, 5, 6], [7, 8, 9]], [1, -1]); 679 | 680 | will return: 681 | 682 | [[8,9,7],[2,3,1],[5,6,4]] 683 | 684 | Using the optional third parameter it is possible to fill previously 685 | empty array elements with a given value via L. 686 | 687 | =cut 688 | 689 | sub rotate { 690 | my($struct, $rotvec, $fill) = @_; 691 | 692 | # param checks 693 | croak $LastError = 'rotate: not an array ref' 694 | unless ref($struct) eq 'ARRAY' and ref($rotvec) eq 'ARRAY'; 695 | 696 | my $dim = shape($struct); 697 | 698 | croak "rotate: rotation vector does not fit array dimensions" 699 | unless @$rotvec == @$dim; 700 | 701 | $struct = reshape($struct, $dim, $fill); 702 | 703 | my $start = [ map { 0 } @$dim ]; 704 | my $end = [ map { $_ - 1 } @$dim ]; 705 | 706 | my $iterator = vector_iterator($start, $end); 707 | 708 | my $dest = []; 709 | while ( my($svec) = $iterator->() ) { 710 | my $dvec = [ map { 711 | ( $svec->[$_] + $rotvec->[$_] ) % $dim->[$_] 712 | } 0 .. $#$svec ]; 713 | value_by_path($dest, $dvec, value_by_path($struct, $svec)); 714 | } 715 | 716 | return $dest; 717 | } 718 | 719 | 720 | =pod 721 | 722 | =head2 scatter() 723 | 724 | B 725 | 726 | This function behaves inverse to subscript. While subscript selects 727 | values from a nested data structure, controlled by an index vector, 728 | scatter will distribute elements into a new data structure, controlled 729 | by an index vector. 730 | 731 | Example: 732 | 733 | scatter([1, 2, 3, 4, 5, 6, 7], [[0,0], [0,1], [1,0], [1,1]]); 734 | 735 | will return: 736 | 737 | [[1, 2], [3, 4]] 738 | 739 | =cut 740 | 741 | sub scatter { 742 | my ($aref, $struct) = @_; 743 | 744 | # param checks 745 | croak $LastError = 'scatter: not an array ref' 746 | unless ref($aref) eq 'ARRAY' and ref($struct) eq 'ARRAY'; 747 | 748 | # Make sure that the raw data to be scattered will not be exhausted 749 | # by the indices contained in $struct: 750 | my $source = reshape($aref, [scalar @$struct], $aref); 751 | 752 | # Built new data structure (possibly containing empty elements): 753 | my $result = []; 754 | for my $position (@$struct) { 755 | $position = [$position] unless ref($position) eq 'ARRAY'; 756 | value_by_path($result, $position, shift(@$source)) 757 | if ref($position) eq 'ARRAY' and ref($position->[0]) ne 'NaV'; 758 | } 759 | 760 | return $result; 761 | } 762 | 763 | 764 | =pod 765 | 766 | =head2 shape() 767 | 768 | B 769 | 770 | Determine the dimensions of an array and return it as 771 | a vector (an array reference) 772 | 773 | Example: 774 | 775 | shape([[1,2,3], [4,5,6], [7,8,9]]); 776 | 777 | will return: 778 | 779 | [3,3] 780 | 781 | and: 782 | 783 | shape([[1,2,3],4,[5,[6,7,8,[9,0]]]]); 784 | 785 | will return: 786 | 787 | [3,3,4,2] 788 | 789 | A combination of shape() and reshape() will effectively turn an 790 | "irregular" array into a regular one. 791 | 792 | For example: 793 | 794 | $aref = [[1,2,3],4,[5,6],[7,8,9]]; 795 | 796 | reshape($aref, shape($aref), [0]); 797 | 798 | will return: 799 | 800 | [[1,2,3],[0,0,0],[5,6,0],[7,8,9]] 801 | 802 | =cut 803 | 804 | sub shape { 805 | my($struct) = @_; 806 | 807 | return [] unless ref($struct) eq 'ARRAY'; 808 | 809 | my @out = ( 0 ); 810 | my @idx = ( 0 ); 811 | my @vstack = ( $struct ); 812 | 813 | my $depth = 0; 814 | while ( $depth >= 0 ) { 815 | 816 | # get the top reference from the stack 817 | my $aref = $vstack[-1]; 818 | 819 | if ( ref($aref->[$idx[$depth]]) eq 'ARRAY') { 820 | 821 | # found a reference push it on the stack and increase depth 822 | push @vstack, $aref->[$idx[$depth++]]; 823 | # push a new index on the index stack 824 | push @idx, 0; 825 | # initialize the counter on the new level on first entry 826 | $out[$depth] = 0 unless defined $out[$depth]; 827 | 828 | } elsif ( $idx[$depth] <= $#$aref ) { 829 | 830 | # no reference and we still have elements in the array 831 | # --> increase index for the current level 832 | ++$idx[$depth]; 833 | 834 | } else { 835 | 836 | # reached the end of the array 837 | # --> remove it from the stack 838 | pop @vstack; 839 | 840 | # remove last index from the index stack 841 | pop @idx; 842 | 843 | # save the number of elements of the level 844 | # if it is bigger than before 845 | $out[$depth] = @$aref if @$aref > $out[$depth]; 846 | 847 | # decrease the current level 848 | $depth--; 849 | 850 | # increase the index for the current level 851 | ++$idx[$depth] if $depth >= 0; 852 | 853 | } 854 | } 855 | 856 | return \@out; 857 | } 858 | 859 | 860 | =pod 861 | 862 | =head2 subscript() 863 | 864 | B 865 | 866 | Retrieve and return values of a deeply nested array for a single index a 867 | list of indices or a list of coordinate vectors. 868 | 869 | Example: 870 | 871 | my $aref = [[1,2,3],[4,5,6],[7,8,9]]; 872 | 873 | subscript($aref, 1); 874 | 875 | returns: 876 | 877 | [[4,5,6]] 878 | 879 | whereas: 880 | 881 | subscript($aref, [[0,1], [1,2], 2]); 882 | 883 | returns: 884 | 885 | [2,6,[7,8,9]] 886 | 887 | =cut 888 | 889 | sub subscript { 890 | my($struct, $coords) = @_; 891 | 892 | croak $LastError = 'subscript: not an array ref' 893 | unless ref($_[0]) eq 'ARRAY'; 894 | 895 | $coords = [$coords] 896 | unless ref($coords) eq 'ARRAY'; 897 | 898 | for ( @$coords ) { 899 | $_ = [$_] unless ref($_) eq 'ARRAY'; 900 | } 901 | 902 | my @out; 903 | for my $position (@$coords) { 904 | push @out, value_by_path($struct, $position) 905 | if ref($position) eq 'ARRAY' and ref($position->[0]) ne 'NaV'; 906 | } 907 | 908 | return \@out; 909 | } 910 | 911 | 912 | =pod 913 | 914 | =head2 transpose() 915 | 916 | B 917 | 918 | Transpose a nested data structure. In the easiest two-dimensional case 919 | this is the traditional transposition operation. 920 | 921 | Example: 922 | 923 | transpose([[1,2,3], [4,5,6], [7,8,9]], 1); 924 | 925 | will return: 926 | 927 | [[1,4,7],[2,5,8],[3,6,9]] 928 | 929 | Using the optional third parameter, it is possible to fill previously 930 | empty array elements with a given value via L. 931 | 932 | =cut 933 | 934 | sub transpose { 935 | my($struct, $control, $fill) = @_; 936 | 937 | croak $LastError = 'transpose: not an array ref' 938 | unless ref($struct) eq 'ARRAY'; 939 | 940 | my $dim = shape($struct); 941 | 942 | $struct = reshape($struct, $dim, $fill); 943 | 944 | my $start = [ map { 0 } @$dim ]; 945 | my $end = [ map { $_ - 1 } @$dim ]; 946 | 947 | my $iterator = vector_iterator($start, $end); 948 | 949 | my $dest = []; 950 | while ( my($svec) = $iterator->() ) { 951 | my $dvec = [ 952 | map { 953 | $svec->[($_ + $control) % scalar(@$svec)] 954 | } 0 .. $#$svec 955 | ]; 956 | value_by_path($dest, $dvec, value_by_path($struct, $svec)); 957 | } 958 | 959 | return $dest; 960 | } 961 | 962 | 963 | =pod 964 | 965 | =head2 unary() 966 | 967 | B 968 | 969 | Recursively apply a unary operator represented by a subroutine 970 | reference to all elements of a nested data structure given in $aref 971 | and set the resulting values in the referenced array itself. 972 | The reference will also be returned. 973 | 974 | The value of $neutral_element will be used if the original is 975 | undefined or does not exist. To be able to use methods as subroutines 976 | $object will be passed to the subroutine as first parameter when 977 | specified. 978 | 979 | A simple example, after: 980 | 981 | my $v = [1,0,2,0,3,[1,0,3]]; 982 | my $func = sub { ! $_[0] + 0 }; 983 | 984 | unary($v, $func); 985 | 986 | will return: 987 | 988 | [1,0,2,0,3,[0,1,0]] 989 | 990 | =cut 991 | 992 | sub unary { 993 | my($func, $neutral, $obj) = @_[1..3]; 994 | 995 | # param checks 996 | croak $LastError = 'unary: not a code ref' 997 | unless ref($func) eq 'CODE'; 998 | croak $LastError = 'unary: not an object' 999 | if $obj and !ref($obj); 1000 | 1001 | return $_[0] 1002 | if ref($_[0]) eq 'ARRAY' and @{ $_[0] } == 0; 1003 | 1004 | my $dim = shape($_[0]); 1005 | 1006 | my $start = [ map { 0 } @$dim ]; 1007 | my $end = [ map { $_ - 1 } @$dim ]; 1008 | 1009 | my $iterator = vector_iterator($start, $end); 1010 | 1011 | while ( my ($vec) = $iterator->() ) { 1012 | my $val = value_by_path($_[0], $vec); 1013 | value_by_path( 1014 | $_[0], 1015 | $vec, 1016 | (!defined($val) or ref($val) eq 'NaV') 1017 | ? (ref($neutral) eq 'CODE' ? $neutral->($_[0]) : $neutral) 1018 | : $func->($obj ? ($obj, $val) : $val), 1019 | ); 1020 | } 1021 | 1022 | return($_[0]); 1023 | } 1024 | 1025 | 1026 | =pod 1027 | 1028 | =head2 value_by_path() 1029 | 1030 | B 1031 | 1032 | Get or set a value in a deeply nested array by a coordinate vector. 1033 | 1034 | Example: 1035 | 1036 | my $vec = [[1,2,3], [4,5,6], [7,8,9]]; 1037 | 1038 | value_by_path($vec, [1,1], 99); 1039 | 1040 | will give: 1041 | 1042 | [[1,2,3], [4,99,6], [7,8,9]]; 1043 | 1044 | in $vec. This is not spectacular since one could easily write: 1045 | 1046 | $vec->[1][1] = 99; 1047 | 1048 | but value_by_path() will be needed if the coordinate vector is created 1049 | dynamically and can be of arbitrary length. 1050 | If you explicitly want to set an undefined value, you have to set 1051 | $force to a true value. 1052 | 1053 | When retrieving values value_by_path() will return an object of class 1054 | "NaV" when there is no scalar at the given coordinate. The object is 1055 | just a blessed scalar with an undefined value. Beware: it will always be 1056 | the same object. 1057 | 1058 | =cut 1059 | 1060 | sub value_by_path { 1061 | my($aref, $coordinate, $value, $force) = @_; 1062 | 1063 | croak $LastError = 'value_by_path: not an array ref' 1064 | unless ref($aref) eq 'ARRAY'; 1065 | 1066 | my $vref = $aref; 1067 | my $vec = ref($coordinate) eq 'ARRAY' 1068 | ? $coordinate 1069 | : [$coordinate]; 1070 | 1071 | my $end = @$vec - 1; 1072 | 1073 | my $i = 0; 1074 | while ( $i < $end ) { 1075 | 1076 | if ( defined($value) ) { 1077 | $vref->[$vec->[$i]] = [] 1078 | unless defined($vref->[$vec->[$i]]) 1079 | and 1080 | ref($vref->[$vec->[$i]]) eq 'ARRAY'; 1081 | } else { 1082 | return $NaV unless ref($vref->[$vec->[$i]]) eq 'ARRAY'; 1083 | } 1084 | 1085 | $vref = $vref->[$vec->[$i++]]; 1086 | } 1087 | 1088 | if ( defined($value) or $force ) { 1089 | $vref->[$vec->[$i]] 1090 | = ref($value) eq 'ARRAY' 1091 | ? dclone($value) 1092 | : $value; 1093 | } else { 1094 | return $NaV 1095 | if $vec->[$i] > $#$vref; 1096 | return( 1097 | ref($vref->[$vec->[$i]]) eq 'ARRAY' 1098 | ? dclone($vref->[$vec->[$i]]) 1099 | : $vref->[$vec->[$i]] 1100 | ); 1101 | } 1102 | } 1103 | 1104 | 1105 | =pod 1106 | 1107 | =head2 vector_iterator() 1108 | 1109 | B 1110 | 1111 | This routine returns a subroutine reference to an iterator which 1112 | is used to generate successive coordinate vectors starting with the 1113 | coordinates in $from_aref to those in $to_aref. 1114 | 1115 | The resulting subroutine will return a pair of coordinate vectors on 1116 | each successive call or an empty list if the iterator has reached the 1117 | last coordinate. The first coordinate returned is related to the given 1118 | coordinate pair, the second one to a corresponding zero based array. 1119 | 1120 | Example: 1121 | 1122 | my $aref = [[1,2,3], [4,5,6], [7,8,9]]; 1123 | 1124 | my $iterator = vector_iterator([0,1], [1,2]); 1125 | 1126 | while ( my($svec, $dvec) = $iterator->() ) { 1127 | my $val = value_by_path($aref, $svec); 1128 | print "[$svec->[0] $svec->[1]] [$dvec->[0] $dvec->[1]] -> $val\n"; 1129 | } 1130 | 1131 | will print: 1132 | 1133 | [0 1] [0 0] -> 2 1134 | [0 2] [0 1] -> 3 1135 | [1 1] [1 0] -> 5 1136 | [1 2] [1 1] -> 6 1137 | 1138 | =cut 1139 | 1140 | sub vector_iterator { 1141 | my($from, $to) = @_; 1142 | 1143 | croak $LastError = 'value_by_path: not an array ref' 1144 | unless ref($from) eq 'ARRAY' and ref($to) eq 'ARRAY'; 1145 | 1146 | my @start = @$from; 1147 | my @current = @$from; 1148 | my @end = @$to; 1149 | my @dir = map { $end[$_] <=> $start[$_] } 0 .. $#end; 1150 | my @diff = map { abs($end[$_] - $start[$_]) + 1 } 0 .. $#end; 1151 | my @dvec = map { 0 } 0 .. $#end; 1152 | 1153 | my $end_reached = 0; 1154 | 1155 | return sub { 1156 | 1157 | return if $end_reached; 1158 | 1159 | $end_reached = 1; 1160 | for my $i ( 0 .. $#end ) { 1161 | $end_reached &&= $current[$i] == $end[$i]; 1162 | last unless $end_reached; 1163 | } 1164 | 1165 | my $sretvec = [ @current ]; 1166 | my $dretvec = [ @dvec ]; 1167 | 1168 | for my $i ( reverse 0 .. $#end ) { 1169 | 1170 | $current[$i] += $dir[$i]; 1171 | $dvec[$i]++; 1172 | if ( $current[$i] == $end[$i] + $dir[$i] ) { 1173 | $current[$i] = $start[$i]; 1174 | $dvec[$i] = 0; 1175 | } 1176 | 1177 | last if $current[$i] != $start[$i]; 1178 | } 1179 | 1180 | return($sretvec, $dretvec); 1181 | }; 1182 | } 1183 | 1184 | 1185 | =pod 1186 | 1187 | =head1 SEE ALSO 1188 | 1189 | Array::DeepUtils was developed during the implementation of lang5 a 1190 | stack based array language. The source will be maintained in the source 1191 | repository of lang5. 1192 | 1193 | =head2 Links 1194 | 1195 | =over 1196 | 1197 | =item * 1198 | 1199 | L. 1200 | 1201 | =item * 1202 | 1203 | L. 1204 | 1205 | =back 1206 | 1207 | =head2 Bug Reports and Feature Requests 1208 | 1209 | =over 1210 | 1211 | =item * 1212 | 1213 | L 1214 | 1215 | =item * 1216 | 1217 | L 1218 | 1219 | =back 1220 | 1221 | =head1 AUTHOR 1222 | 1223 | Thomas Kratz Etomk@cpan.orgE 1224 | 1225 | Bernd Ulmann Eulmann@vaxman.deE 1226 | 1227 | =head1 COPYRIGHT 1228 | 1229 | Copyright (C) 2011 by Thomas Kratz, Bernd Ulmann 1230 | 1231 | This library is free software; you can redistribute it and/or 1232 | modify it under the same terms as Perl itself, either Perl version 1233 | 5.8.8 or, at your option, any later version of Perl 5 you may 1234 | have available. 1235 | 1236 | =cut 1237 | 1238 | 1; 1239 | -------------------------------------------------------------------------------- /perl_modules/Lang5.pm: -------------------------------------------------------------------------------- 1 | package Lang5; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '1.0'; 7 | 8 | use constant { 9 | STATE_RUN => 0, 10 | STATE_START_WORD => 1, 11 | STATE_EXPAND_WORD => 2, 12 | STATE_SKIP_WORD_DEFINITION => 3, 13 | STATE_EXECUTE_IF => 4, 14 | STATE_EXECUTE_ELSE => 5, 15 | STATE_IF_COMPLETED => 6, 16 | STATE_EXECUTE_DO => 7, 17 | STATE_BREAK_EXECUTED => 8, 18 | }; 19 | 20 | use POSIX qw/strftime/; 21 | use Storable qw/dclone/; 22 | use Array::DeepUtils qw/:all/; 23 | use Lang5::String; 24 | use Data::Dumper; 25 | $Data::Dumper::Varname = undef; 26 | $Data::Dumper::Indent = 1; 27 | 28 | my %debug_level; 29 | my $db_level; 30 | 31 | # Simple logging. 32 | BEGIN { 33 | %debug_level = qw/TRACE 0 DEBUG 1 INFO 2 WARN 3 ERROR 4 FATAL 5/; 34 | 35 | for my $lev ( keys %debug_level ) { 36 | no strict 'refs'; 37 | *{$lev} = sub (@) {}; 38 | } 39 | } 40 | 41 | # This regular expression recognizes an integer or floating point number. 42 | # It is used to determine if an otherwise unrecognized element read from 43 | # stdin or a file has to be pushed onto the stack. 44 | my %re = ( 45 | float => qr/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/, 46 | whead => qr/\S+\{\[.+?\}/, 47 | strob => qr/\Qbless( do{\(my \E\$o = ('.*')\Q)}, 'Lang5::String' )/, 48 | ); 49 | 50 | # These so called published variables are used to control various things 51 | # within the interpreter and can be handled like any other user defined 52 | # variable with the exception that it is not possible to delete any of 53 | # these published variables. 54 | my %published_vars = map { $_ => 1 } qw/ 55 | log_level terminal_width number_format 56 | /; 57 | 58 | # Any language element must be of one of the types defined here: 59 | my %element_type = qw/niladic n unary u binary b function f variable v/; 60 | my %reverse_type = reverse %element_type; 61 | my %stack_type = ( n => [], u => ['X'], b => ['X', 'X'] ); 62 | my %op_count = qw/0 n 1 u 2 b/; 63 | 64 | # Parameter checks, $_[0] contains the interpreter object, $_[1] the parameter 65 | # to be checked. 66 | my %param_checks = ( 67 | A => { 68 | desc => 'array', 69 | code => sub { return eval { @{$_[1] } + 1} }, 70 | }, 71 | BO => { 72 | desc => 'binary operator', 73 | code => sub { 74 | exists $_[0]->{_words}{$_[1]} and $_[0]->{_words}{$_[1]}{type} eq 'binary' 75 | }, 76 | }, 77 | I => { 78 | desc => 'integer', 79 | code => sub { $_[1] =~ /^[+-]?\d+$/ }, 80 | }, 81 | F => { 82 | desc => 'float', 83 | code => sub { $_[1] =~ /^$re{float}$/ }, 84 | }, 85 | PI => { 86 | desc => 'positive integer', 87 | code => sub { $_[1] =~ /^[+]?\d+$/ }, 88 | }, 89 | V => { 90 | desc => 'valid variable name', 91 | code => sub { $_[1] =~ /^\w+$/ }, 92 | }, 93 | S => { 94 | desc => 'scalar value', 95 | code => sub { !ref($_[1]) or ref($_[1]) eq 'Lang5::String' }, 96 | }, 97 | X => { 98 | desc => 'any value', 99 | code => sub { 1 }, 100 | }, 101 | U => { 102 | desc => 'user defined word', 103 | code => sub { 104 | exists $_[0]->{_words}{$_[1]} 105 | and 106 | $_[0]->{_words}{$_[1]}{type} eq 'word' 107 | }, 108 | }, 109 | N => { 110 | desc => 'name (user defined word or variable)', 111 | code => sub { 112 | my $wroot = $_[0]->_find_word($_[1]); 113 | return unless $wroot; 114 | 115 | my %wkeys = map { $_ => 1 } grep { 116 | ref($wroot->{$_[1]}{$_}) eq 'HASH' 117 | } keys %{ $wroot->{$_[1]} }; 118 | 119 | $wroot->{$_[1]}{type} eq 'variable' 120 | or 121 | keys %wkeys; 122 | }, 123 | }, 124 | ); 125 | 126 | 127 | # Builtin operators and functions: 128 | my %builtin = ( 129 | 130 | ### niladic operators 131 | exit => { 132 | desc => 'Leave the interpreter immediately.', 133 | type => 'niladic', 134 | code => sub { $_[0]->{_exit_called} = 1; }, 135 | }, 136 | 137 | vlist => { 138 | desc => 'Generate a list of all variables.', 139 | type => 'niladic', 140 | push => [qw/A/], 141 | code => sub { 142 | 143 | my %names; 144 | 145 | for my $wr ( @{ $_[0]->{_word_exc_stack} } ) { 146 | $names{$_}++ for grep { 147 | $wr->{$_}{type} eq 'variable' 148 | } keys %$wr; 149 | } 150 | 151 | [ sort keys %names ]; 152 | }, 153 | }, 154 | 155 | ver => { 156 | desc => "Get the interpreter's version number.", 157 | type => 'niladic', 158 | push => [qw/F/], 159 | code => sub { $VERSION }, 160 | }, 161 | 162 | wlist => { 163 | desc => 'Generate a list of all user defined words.', 164 | type => 'niladic', 165 | push => [qw/A/], 166 | code => sub { 167 | [ 168 | sort grep { 169 | my @hkeys = grep { 170 | ref($_) eq 'HASH' 171 | } values %{ $_[0]->{_words}{$_} }; 172 | @hkeys > 0; 173 | } keys %{ $_[0]->{_words} } 174 | ] 175 | }, 176 | }, 177 | 178 | ### unary operators 179 | '?' => { 180 | desc => 'Generate a pseudo random number.', 181 | type => 'unary', 182 | pop => [qw/X/], 183 | push => [qw/I/], 184 | ntrl => 0, 185 | code => sub { rand($_[1]); }, 186 | }, 187 | 188 | 'chr' => { 189 | desc => 'Convert an integer to ASCII.', 190 | type => 'unary', 191 | pop => [qw/X/], 192 | push => [qw/S/], 193 | ntrl => 0, 194 | code => sub { chr($_[1]); }, 195 | }, 196 | 197 | defined => { 198 | desc => 'Check definedness of element.', 199 | type => 'unary', 200 | pop => [qw/X/], 201 | push => [qw/S/], 202 | ntrl => 0, 203 | code => sub { defined($_[1]) || 0; }, 204 | }, 205 | 206 | dump => { 207 | desc => 'Print a user defined word or variable definition.', 208 | type => 'unary', 209 | pop => [qw/S/], 210 | pop => [qw/S/], 211 | code => sub { 212 | $_[0]->_dump_word($_[1]); 213 | }, 214 | }, 215 | 216 | eval => { 217 | desc => 'Evaluate a variable.', 218 | type => 'unary', 219 | pop => [qw/S/], 220 | push => [qw/X/], 221 | ntrl => undef, 222 | code => sub { 223 | my $wroot = $_[0]->_find_word($_[1]); 224 | return unless $wroot and $wroot->{$_[1]}{type} eq 'variable'; 225 | return $wroot->{$_[1]}{value}; 226 | }, 227 | }, 228 | 229 | int => { 230 | desc => 'Get integer part of a value.', 231 | type => 'unary', 232 | pop => [qw/X/], 233 | push => [qw/I/], 234 | ntrl => undef, 235 | code => sub { int($_[1]) }, 236 | }, 237 | 238 | iota => { 239 | desc => 'Generate a vector with unit stride starting at 0 and ending with TOS value - 1.', 240 | type => 'unary', 241 | pop => [qw/PI/], 242 | push => [qw/A/], 243 | ntrl => [], 244 | code => sub { [ 0 .. $_[1] - 1 ] }, 245 | }, 246 | 247 | lc => { 248 | desc => 'Convert string to lower case.', 249 | type => 'unary', 250 | pop => [qw/S/], 251 | push => [qw/S/], 252 | ntrl => [], 253 | code => sub { 254 | lc($_[1]); 255 | } 256 | }, 257 | 258 | neg => { 259 | desc => 'negation', 260 | type => 'unary', 261 | pop => [qw/X/], 262 | push => [qw/I/], 263 | ntrl => undef, 264 | code => sub { -$_[1] }, 265 | }, 266 | 267 | not => { 268 | desc => 'logical not', 269 | type => 'unary', 270 | pop => [qw/X/], 271 | push => [qw/X/], 272 | ntrl => 1, 273 | code => sub { ! $_[1] + 0 }, 274 | }, 275 | 276 | system => { 277 | desc => 'Execute a system command.', 278 | type => 'unary', 279 | pop => [qw/S/], 280 | push => [qw/A/], 281 | ntrl => [], 282 | code => sub { 283 | unless ($_[0]->{steps}) # If steps is set, we are a CGI-script and system calls are forbidden 284 | { 285 | $_[1] =~ s/^\"//; 286 | $_[1] =~ s/\"$//; 287 | [ map { chomp; $_ } `$_[1]` ]; 288 | } 289 | else 290 | { 291 | 'Running in CGI mode, system calls are disabled!'; 292 | } 293 | }, 294 | }, 295 | 296 | uc => { 297 | desc => 'Convert string to upper case.', 298 | type => 'unary', 299 | pop => [qw/S/], 300 | push => [qw/S/], 301 | ntrl => [], 302 | code => sub { 303 | uc($_[1]); 304 | } 305 | }, 306 | 307 | # direct mapping to perl operators 308 | ( map { 309 | $_ => { 310 | desc => "Basic unary operator $_, no neutral element.", 311 | type => 'unary', 312 | pop => [qw/X/], 313 | push => [qw/S/], 314 | ntrl => undef, 315 | code => eval("sub { $_ \$_[1] }"), 316 | } 317 | } qw( 318 | sin cos sqrt exp 319 | )), 320 | 321 | # ln 322 | ln => { 323 | desc => 'Natural logarithm, no neutral element.', 324 | type => 'unary', 325 | pop => [qw/X/], 326 | push => [qw/S/], 327 | ntrl => undef, 328 | code => sub { log($_[1]) }, 329 | }, 330 | 331 | ### binary operators 332 | atan2 => { 333 | desc => 'arctan(TOS / TOS-1).', 334 | type => 'binary', 335 | pop => [qw/S S/], 336 | push => [qw/S/], 337 | ntrl => [], 338 | code => sub { atan2 $_[1], $_[2] }, 339 | }, 340 | 341 | split => { 342 | desc => 'Split a string and place its parts into a vector.', 343 | type => 'binary', 344 | pop => [qw/S S/], 345 | push => [qw/A/], 346 | ntrl => [], 347 | code => sub { [ split $_[1], $_[2] ] }, 348 | }, 349 | 350 | # direct mapping to perl operators 351 | # with 0 as neutral element 352 | ( map { 353 | $_ => { 354 | desc => "Basic binary operator $_, neutral element: 0.", 355 | type => 'binary', 356 | pop => [qw/X X/], 357 | push => [qw/S/], 358 | ntrl => 0, 359 | code => eval("sub { no warnings qw/numeric/; \$_[2] $_ \$_[1] }"), 360 | } 361 | } qw( 362 | + - 363 | )), 364 | 365 | # with 1 as neutral element 366 | ( map { 367 | $_ => { 368 | desc => "Basic binary operator $_, neutral element: 1.", 369 | type => 'binary', 370 | pop => [qw/X X/], 371 | push => [qw/S/], 372 | ntrl => 1, 373 | code => eval("sub { no warnings qw/numeric/; \$_[2] $_ \$_[1] }"), 374 | } 375 | } qw( 376 | * / % ** 377 | )), 378 | 379 | # without a neutral element 380 | ( map { 381 | $_ => { 382 | desc => "Basic binary operator $_, no neutral element.", 383 | type => 'binary', 384 | pop => [qw/X X/], 385 | push => [qw/S/], 386 | code => eval("sub { no warnings qw/numeric uninitialized/; ( \$_[2] $_ \$_[1] ) || 0 }"), 387 | } 388 | } qw( 389 | & | ^ 390 | > < == >= <= != <=> 391 | cmp eq ne gt lt ge le 392 | && || and or 393 | )), 394 | 395 | concat => { 396 | desc => 'Concatenates strings.', 397 | type => 'binary', 398 | pop => [qw/X X/], 399 | push => [qw/S/], 400 | code => sub { 401 | return $_[2] . $_[1]; 402 | }, 403 | }, 404 | 405 | eql => { 406 | desc => 'eql binary operator testing real string equality.', 407 | type => 'binary', 408 | pop => [qw/X X/], 409 | push => [qw/S/], 410 | ntrl => [], 411 | code => sub { 412 | if ( defined($_[1]) and defined($_[2]) ) { 413 | return ($_[1] eq $_[2]) ? 1 : 0; 414 | } 415 | if ( !defined($_[1]) and !defined($_[2]) ) { 416 | return 1; 417 | } 418 | return 0; 419 | }, 420 | }, 421 | 422 | '===' => { 423 | desc => '=== binary operator testing real numerical equality.', 424 | type => 'binary', 425 | pop => [qw/X X/], 426 | push => [qw/S/], 427 | ntrl => [], 428 | code => sub { 429 | if ( defined($_[1]) and defined($_[2]) ) { 430 | return ($_[1] == $_[2]) ? 1 : 0; 431 | } 432 | if ( !defined($_[1]) and !defined($_[2]) ) { 433 | return 1; 434 | } 435 | return 0; 436 | }, 437 | }, 438 | 439 | ### functions 440 | '..' => { 441 | desc => 'Print the stack contents without destroying the stack.', 442 | type => 'function', 443 | code => sub { 444 | my($self, $stack) = @_; 445 | my $dout = Dumper($stack); 446 | $dout =~ s/$re{strob}/$1/g; 447 | $self->_output($dout); 448 | }, 449 | }, 450 | 451 | '.' => { 452 | desc => 'Remove TOS and dump it to an output buffer.', 453 | type => 'function', 454 | pop => [qw/X/], 455 | code => sub { 456 | my($self, $stack) = @_; 457 | $self->_output($self->_element2text(pop @$stack)); 458 | }, 459 | }, 460 | 461 | '.ofw' => { 462 | desc => 'Print a list of all defined words etc.', 463 | type => 'function', 464 | code => sub { 465 | my($self, $stack) = @_; 466 | $self->_words2text_buffer() 467 | }, 468 | }, 469 | 470 | apply => { 471 | desc => 'Apply an unary/binary operator/word along the first dimension of an array.', 472 | type => 'function', 473 | pop => [qw/S A/], 474 | push => [qw/A/], 475 | code => sub { 476 | my ($self, $stack) = @_; 477 | 478 | my $name = pop @$stack; 479 | my $a1 = pop @$stack; 480 | 481 | unless ( ref($a1) eq 'ARRAY' ) { 482 | $self->{_last_error} = 'apply: TOS-1 is not an array'; 483 | $self->{_error} = 1; 484 | return; 485 | } 486 | 487 | my $wroot = $self->_find_word($name); 488 | 489 | unless ( $wroot ) { 490 | $self->{_last_error} 491 | = "apply: no operator/user defined word named '$name' found"; 492 | $self->{_error} = 1; 493 | return; 494 | } 495 | 496 | my $word = $wroot->{$name}; 497 | 498 | my $func = $self->_get_func($word); 499 | my $ntrl = $self->_get_ntrl($word); 500 | 501 | unless ( $word->{type} =~ /^unary|binary$/ ) { 502 | $self->{_last_error} 503 | = "apply: '$name' is not of type unary or binary"; 504 | $self->{_error} = 1; 505 | return; 506 | } 507 | 508 | my @result; 509 | 510 | if ( $word->{type} eq 'unary' ) { 511 | 512 | for my $element (@$a1) { 513 | INFO "apply calling unary word: ", $word; 514 | INFO "apply calling word with element: ", $element; 515 | push @result, $func->($self, $element); 516 | } 517 | 518 | } else { 519 | 520 | my $a2 = pop @$stack; 521 | 522 | unless ( ref($a2) eq 'ARRAY' ) { 523 | $self->{_last_error} = 'apply: TOS-2 is not an array'; 524 | $self->{_error} = 1; 525 | return; 526 | } 527 | 528 | for (my $i = 0; $i < (@$a1 > @$a2 ? @$a1 : @$a2); $i++) { 529 | 530 | my $x 531 | = ref($a1->[$i % @$a1]) eq 'ARRAY' 532 | ? dclone($a1->[$i % @$a1]) 533 | : $a1->[$i % @$a1]; 534 | 535 | my $y 536 | = ref($a2->[$i % @$a2]) eq 'ARRAY' 537 | ? dclone($a2->[$i % @$a2]) 538 | : $a2->[$i % @$a2]; 539 | 540 | push(@result, $func->($self, $x, $y)); 541 | } 542 | } 543 | 544 | push @$stack, \@result; 545 | }, 546 | }, 547 | 548 | close => { 549 | desc => 'Close a file which has been opened before.', 550 | type => 'function', 551 | pop => [qw/I/], 552 | code => sub { 553 | my($self, $stack) = @_; 554 | 555 | my $fileno = pop @$stack; 556 | 557 | DEBUG "closing file number $fileno"; 558 | 559 | unless ( $self->{_files}{$fileno} ) { 560 | $self->{_last_error} = "No such file to close: $fileno"; 561 | $self->{_error} = 1; 562 | return; 563 | } 564 | 565 | close $self->{_files}{$fileno}{handle}; 566 | delete $self->{_files}{$fileno}; 567 | }, 568 | }, 569 | 570 | compress => { 571 | desc => 'Compress data found on the stack into a structure.', 572 | type => 'function', 573 | pop => [qw/PI/], 574 | push => [qw/A/], 575 | code => sub { 576 | my($self, $stack) = @_; 577 | 578 | my $length = pop @$stack; 579 | if ( @$stack < $length ) { 580 | $self->{_last_error} = 'compress: not enough elements on stack!'; 581 | $self->{_error} = 1; 582 | return; 583 | } 584 | 585 | push @$stack, [ splice @$stack, - $length, $length ]; 586 | }, 587 | }, 588 | 589 | collapse => { 590 | desc => 'Collapses a higher dimensional structure into a one dimensional vector.', 591 | type => 'function', 592 | pop => [qw/A/], 593 | push => [qw/A/], 594 | ntrl => [], 595 | code => sub { 596 | my($self, $stack) = @_; 597 | 598 | eval { 599 | push @$stack, collapse(pop @$stack); 600 | }; 601 | 602 | if ( $@ ) { 603 | $self->{_last_error} = $Array::DeepUtils::LastError; 604 | $self->{_error} = 1; 605 | return; 606 | } 607 | }, 608 | }, 609 | 610 | del => { 611 | desc => 'Delete a variable or a word (if it does not exist nothing will happen).', 612 | type => 'function', 613 | pop => [qw/S/], 614 | code => sub { 615 | my($self, $stack) = @_; 616 | 617 | my $name = pop @$stack; 618 | 619 | DEBUG "Deleting word or variable $name"; 620 | 621 | my $wroot = $self->_find_word($name); 622 | 623 | unless ( $wroot ) { 624 | $self->{_last_error} = "del: no word named '$name' found"; 625 | $self->{_error} = 1; 626 | return; 627 | } 628 | 629 | my $word = $wroot->{$name}; 630 | 631 | my %wkeys = map { $_ => 1 } grep { 632 | ref($word->{$_}) eq 'HASH' 633 | } keys %$word; 634 | 635 | unless ( $word->{type} eq 'variable' or keys(%wkeys) ) { 636 | $self->{_last_error} = "del: '$name' is not of type variable or user defined word"; 637 | $self->{_error} = 1; 638 | return; 639 | } 640 | 641 | (my $stripped = $name) =~ s/^__//; 642 | if ( $published_vars{$stripped} ) { 643 | $self->{_last_error} = "published variable $name cannot be deleted!"; 644 | $self->{_error} = 1; 645 | return; 646 | } 647 | 648 | delete $wroot->{$name}; 649 | DEBUG "deleted $name"; 650 | }, 651 | }, 652 | 653 | depth => { 654 | desc => 'Return the depth of the stack.', 655 | type => 'function', 656 | push => [qw/I/], 657 | code => sub { 658 | my ($self, $stack) = @_; 659 | push @$stack, scalar @{$stack}; 660 | }, 661 | }, 662 | 663 | dress => { 664 | desc => 'Set the type of a structure.', 665 | type => 'function', 666 | pop => [qw/S A/], 667 | code => sub { 668 | my($self, $stack) = @_; 669 | 670 | my $name = pop @$stack; 671 | my $aref = pop @$stack; 672 | 673 | push @$stack, bless($aref, $name); 674 | }, 675 | }, 676 | 677 | 'dressed' => { 678 | desc => "Return the type of an object or undef if it isn't an object at all.", 679 | type => 'function', 680 | pop => [qw/X/], 681 | push => [qw/S/], 682 | code => sub { 683 | my ($self, $stack) = @_; 684 | 685 | my $type = ref($stack->[-1]); 686 | push @$stack, 687 | ( 688 | !$type 689 | or $type eq 'ARRAY' 690 | or $type eq 'Lang5::String' 691 | ) 692 | ? undef : $type; 693 | }, 694 | }, 695 | 696 | drop => { 697 | desc => 'Drop the TOS.', 698 | type => 'function', 699 | pop => [qw/X/], 700 | code => sub { 701 | my($self, $stack) = @_; 702 | pop @$stack; 703 | }, 704 | }, 705 | 706 | dup => { 707 | desc => 'Duplicate the TOS.', 708 | type => 'function', 709 | pop => [qw/X/], 710 | push => [qw/X X/], 711 | code => sub { 712 | my($self, $stack) = @_; 713 | 714 | my $data 715 | = ref($stack->[-1]) 716 | ? dclone($stack->[-1]) 717 | : $stack->[-1]; 718 | 719 | push @$stack, $data; 720 | }, 721 | }, 722 | 723 | eof => { 724 | desc => 'Push 1 on the TOS if the next read on current input handle would fail due to eof, else 0.', 725 | type => 'function', 726 | push => [qw/I/], 727 | code => sub { 728 | my($self, $stack) = @_; 729 | 730 | DEBUG "test eof on current input file"; 731 | 732 | my $fileno = $self->{_fin}; 733 | my $handle = $self->{_files}{$fileno}{handle}; 734 | 735 | push @$stack, eof($handle); 736 | }, 737 | }, 738 | 739 | execute => { 740 | desc => 'Execute an operator or function or word found on the TOS.', 741 | type => 'function', 742 | pop => [qw/X/], 743 | ntrl => undef, 744 | code => sub { 745 | my($self, $stack) = @_; 746 | 747 | my $el = pop @$stack; 748 | 749 | $el = [$el] unless ref($el) eq 'ARRAY'; 750 | 751 | for my $instr ( @$el ) { 752 | next if $instr eq ''; 753 | $self->add_source_line($_) 754 | for split /\n/, $instr; 755 | $self->execute($stack); 756 | last if $self->{_break}; 757 | } 758 | }, 759 | }, 760 | 761 | expand => { 762 | desc => 'Expand a structure to the next deeper level.', 763 | type => 'function', 764 | pop => [qw/A/], 765 | code => sub { 766 | my($self, $stack) = @_; 767 | 768 | my $data = pop @$stack; 769 | push @$stack, @$data, scalar(@$data); 770 | }, 771 | }, 772 | 773 | fin => { 774 | desc => 'Set the currrent input file handle.', 775 | type => 'function', 776 | pop => [qw/I/], 777 | code => sub { 778 | my($self, $stack) = @_; 779 | 780 | my $fileno = pop @$stack; 781 | 782 | DEBUG "select input file number to $fileno"; 783 | 784 | unless( $self->{_files}{$fileno} ) { 785 | $self->{_last_error} = "no open file number $fileno"; 786 | $self->{_error} = 1; 787 | return; 788 | } 789 | 790 | unless( $self->{_files}{$fileno}{type} eq 'in' ) { 791 | $self->{_last_error} = "file number $fileno: type '$self->{_files}{$fileno}{type}' <> 'in'"; 792 | $self->{_error} = 1; 793 | return; 794 | } 795 | 796 | $self->{_fin} = $fileno; 797 | }, 798 | }, 799 | 800 | fout => { 801 | desc => 'Set the currrent output file handle.', 802 | type => 'function', 803 | pop => [qw/I/], 804 | code => sub { 805 | my($self, $stack) = @_; 806 | 807 | my $fileno = pop @$stack; 808 | 809 | DEBUG "select output file number to $fileno"; 810 | 811 | unless( $self->{_files}{$fileno} ) { 812 | $self->{_last_error} = "no open file number $fileno"; 813 | $self->{_error} = 1; 814 | return; 815 | } 816 | 817 | unless( $self->{_files}{$fileno}{type} eq 'out' ) { 818 | $self->{_last_error} = "file number $fileno: type '$self->{_files}{$fileno}{type}' <> 'out'"; 819 | $self->{_error} = 1; 820 | return; 821 | } 822 | 823 | $self->{_fout} = $fileno; 824 | }, 825 | }, 826 | 827 | grade => { 828 | desc => 'Generate an index vector for sorting the elements of a vector.', 829 | type => 'function', 830 | pop => [qw/A/], 831 | push => [qw/A/], 832 | code => sub { 833 | my($self, $stack) = @_; 834 | 835 | my $data = $stack->[-1]; 836 | 837 | my %h = map { $_ => $data->[$_] } 0 .. @$data - 1; 838 | 839 | push @$stack, [ sort { $h{$a} <=> $h{$b} } keys %h ]; 840 | }, 841 | }, 842 | 843 | help => { 844 | desc => 'Print the description of a built in function or operator.', 845 | type => 'unary', 846 | pop => [qw/X/], 847 | code => sub { 848 | my($self, $name) = @_; 849 | 850 | unless( $self->{_words}{$name}{desc} ) { 851 | $self->_output("No description found for '$name'."); 852 | } else { 853 | $self->_output("$name: $self->{_words}{$name}{desc}\n"); 854 | } 855 | }, 856 | }, 857 | 858 | in => { 859 | desc => 'Set operation "in" - returns a structure consisting of 0 and 1.', 860 | type => 'function', 861 | pop => [qw/X A/], 862 | push => [qw/A/], 863 | code => sub { 864 | my($self, $stack) = @_; 865 | 866 | my $a1 = pop @$stack; 867 | my $a2 = pop @$stack; 868 | my @res; 869 | 870 | if ( ref($a1) eq 'ARRAY' ) { 871 | push(@res, $self->_is_in($_, $a2)) for (@$a1); 872 | push @$stack, \@res; 873 | } else { 874 | push @$stack, $self->_is_in($a1, $a2); 875 | } 876 | }, 877 | }, 878 | 879 | index => { 880 | desc => 'Generate an index vector.', 881 | type => 'function', 882 | pop => [qw/A A/], 883 | push => [qw/A/], 884 | code => sub { 885 | my($self, $stack) = @_; 886 | 887 | my $aref1 = pop @$stack; 888 | my $aref2 = pop @$stack; 889 | 890 | eval { push @$stack, idx($aref1, $aref2); }; 891 | 892 | if ( $@ ) { 893 | $self->{_last_error} = $Array::DeepUtils::LastError; 894 | $self->{_error} = 1; 895 | return; 896 | } 897 | }, 898 | }, 899 | 900 | join => { 901 | desc => 'Concatenate elements of a vector forming a string.', 902 | type => 'function', 903 | pop => [qw/S A/], 904 | push => [qw/S/], 905 | code => sub { 906 | my($self, $stack) = @_; 907 | 908 | my $glue = pop @$stack; 909 | 910 | my $aref = pop @$stack; 911 | 912 | push @$stack, join($glue, @$aref); 913 | }, 914 | }, 915 | 916 | length => { 917 | desc => 'Determine the length of an array.', 918 | type => 'function', 919 | pop => [qw/A/], 920 | push => [qw/PI/], 921 | code => sub { 922 | my($self, $stack) = @_; 923 | 924 | push @$stack, scalar(@{$stack->[-1]}); 925 | }, 926 | }, 927 | 928 | load => { 929 | desc => 'Load a program from a file.', 930 | type => 'function', 931 | pop => [qw/S/], 932 | code => sub { 933 | my($self, $stack) = @_; 934 | 935 | my $file_name = pop @$stack; 936 | 937 | DEBUG "Load program from file $file_name"; 938 | 939 | my $fh; 940 | unless ( open($fh, '<', $file_name) ) { 941 | $self->{_last_error} = "Could not open file '$file_name' for read!, $!"; 942 | $self->{_error} = 1; 943 | return; 944 | } 945 | 946 | while ( my $line = <$fh> ) { 947 | next unless $line; 948 | $self->add_source_line($line); 949 | } 950 | 951 | close($fh); 952 | 953 | $self->execute(); 954 | }, 955 | }, 956 | 957 | open => { 958 | desc => 'Open a file and store its handle in a hash for later use.', 959 | type => 'function', 960 | pop => [qw/S S/], 961 | push => [qw/I/], 962 | code => sub { 963 | my($self, $stack) = @_; 964 | 965 | my $file_name = pop @$stack; 966 | my $mode = pop @$stack; 967 | 968 | DEBUG "open $file_name with mode '$mode'..."; 969 | 970 | my %open = map { $_->{name} => 1 } values %{ $self->{_files} }; 971 | 972 | unless ( $mode =~ m/^[+<>]{1,3}$/ ) { 973 | $self->{_last_error} = 974 | "invalid mode '$mode' specified for file '$file_name'!"; 975 | $self->{_error} = 1; 976 | push @$stack, -1; 977 | return; 978 | } 979 | 980 | if ( $open{$file_name} ) { 981 | $self->{_last_error} = 982 | "file '$file_name' has already been opened!"; 983 | $self->{_error} = 1; 984 | push @$stack, -1; 985 | return; 986 | } 987 | 988 | my $handle; 989 | unless ( open($handle, $mode, $file_name) ) { 990 | $self->{_last_error} = 991 | "Could not open file '$file_name' in mode '$mode', $!"; 992 | $self->{_error} = 1; 993 | push @$stack, -1; 994 | return; 995 | } 996 | 997 | my $fileno = fileno($handle); 998 | $self->{_files}{$fileno} = { 999 | handle => $handle, 1000 | type => ($mode =~ />/ ? 'out' : 'in'), 1001 | name => $file_name, 1002 | }; 1003 | 1004 | push @$stack, $fileno; 1005 | }, 1006 | }, 1007 | 1008 | outer => { 1009 | desc => 'Perform an outer "product" operation although any builtin binary word can be used as the basis for this.', 1010 | type => 'function', 1011 | pop => [qw/BO A A/], 1012 | push => [qw/A/], 1013 | code => sub { 1014 | my($self, $stack) = @_; 1015 | 1016 | my $name = pop @$stack; 1017 | 1018 | my $wroot = $self->_find_word($name); 1019 | 1020 | unless ( $wroot ) { 1021 | $self->{_last_error} = "outer: no word named '$name' found"; 1022 | $self->{_error} = 1; 1023 | return; 1024 | } 1025 | 1026 | my $a1 = pop @$stack; 1027 | my $a2 = pop @$stack; 1028 | my @res; 1029 | 1030 | for my $i ( 0 .. @$a1 - 1 ) { 1031 | for my $j ( 0 .. @$a2 - 1 ) { 1032 | my $value = $a2->[$j]; 1033 | $self->_binary($wroot->{$name}, $a1->[$i], $value); 1034 | $res[$i][$j] = $value; 1035 | } 1036 | } 1037 | 1038 | push @$stack, \@res; 1039 | }, 1040 | }, 1041 | 1042 | over => { 1043 | desc => 'Push TOS - 1 onto the stack.', 1044 | type => 'function', 1045 | pop => [qw/X X/], 1046 | push => [qw/X X X/], 1047 | code => sub { 1048 | my($self, $stack) = @_; 1049 | 1050 | my $data 1051 | = ref($stack->[-2]) 1052 | ? dclone($stack->[-2]) 1053 | : $stack->[-2]; 1054 | 1055 | push @$stack, $data; 1056 | }, 1057 | }, 1058 | 1059 | panic => { 1060 | desc => 'Print TOS and leave current interpreter loop immediately.', 1061 | type => 'function', 1062 | pop => [qw/X/], 1063 | code => sub { 1064 | my($self, $stack) = @_; 1065 | 1066 | $self->_output('PANIC: '); 1067 | 1068 | $self->{_words}{'.'}{code}->($self, $stack) 1069 | if $stack->[-1]; 1070 | 1071 | $self->{_error} = 1; 1072 | }, 1073 | }, 1074 | 1075 | read => { 1076 | desc => 'Read a record from current input handle and push it on top of the stack.', 1077 | type => 'function', 1078 | push => [qw/S/], 1079 | code => sub { 1080 | my($self, $stack) = @_; 1081 | 1082 | my $fileno = $self->{_fin}; 1083 | my $handle = $self->{_files}{$fileno}{handle}; 1084 | 1085 | DEBUG "read data from file number $fileno"; 1086 | 1087 | my $value = <$handle>; 1088 | chomp $value; 1089 | push @$stack, $value; 1090 | }, 1091 | }, 1092 | 1093 | reduce => { 1094 | desc => "Reduce a vector to a scalar by applying a binary word to all vector elements (cf. APL's '/').", 1095 | type => 'function', 1096 | pop => [qw/BO A/], 1097 | push => [qw/S/], 1098 | code => sub { 1099 | my($self, $stack) = @_; 1100 | 1101 | DEBUG "reduce stack: ", $stack; 1102 | 1103 | my $name = pop @$stack; 1104 | 1105 | my $wroot = $self->_find_word($name); 1106 | 1107 | unless ( $wroot ) { 1108 | $self->{_last_error} = "reduce: no operator/user defined word named '$name' found"; 1109 | $self->{_error} = 1; 1110 | return; 1111 | } 1112 | 1113 | my $word = $wroot->{$name}; 1114 | 1115 | unless ( $word->{type} eq 'binary' ) { 1116 | $self->{_last_error} = "reduce: '$name' is not of type binary"; 1117 | $self->{_error} = 1; 1118 | return; 1119 | } 1120 | 1121 | my $aref = pop @$stack; 1122 | 1123 | unless ( @$aref ) { 1124 | push @$stack, $word->{ntrl}; 1125 | return; 1126 | } 1127 | 1128 | my $result = shift @$aref; 1129 | 1130 | for my $el ( @$aref ) { 1131 | eval { $self->_binary($word, $el, $result); }; 1132 | 1133 | if ( $@ ) { 1134 | $self->{_last_error} = "reduce: $@"; 1135 | $self->{_error} = 1; 1136 | return; 1137 | } 1138 | 1139 | DEBUG "reduce: result=$result, ", $el || ''; 1140 | } 1141 | 1142 | push @$stack, $result; 1143 | }, 1144 | }, 1145 | 1146 | remove => { 1147 | desc => 'Remove elements from a nested structure found at TOS - 1 and controlled by a structure or value found at TOS.', 1148 | type => 'function', 1149 | pop => [qw/X A/], 1150 | push => [qw/A/], 1151 | code => sub { 1152 | my($self, $stack) = @_; 1153 | 1154 | my $list = pop @$stack; 1155 | 1156 | eval { remove($stack->[-1], $list); }; 1157 | 1158 | if ( $@ ) { 1159 | $self->{_last_error} = $Array::DeepUtils::LastError; 1160 | $self->{_error} = 1; 1161 | return; 1162 | } 1163 | 1164 | }, 1165 | }, 1166 | 1167 | reshape => { 1168 | desc => 'Transform the array found on TOS-1 according to a dimension vector found on TOS.', 1169 | type => 'function', 1170 | pop => [qw/X X/], 1171 | push => [qw/A/], 1172 | code => sub { 1173 | my($self, $stack) = @_; 1174 | 1175 | my $dims = pop @$stack; 1176 | my $src = pop @$stack; 1177 | 1178 | $dims = [$dims] unless ref($dims) eq 'ARRAY'; 1179 | $src = [$src] unless ref($src) eq 'ARRAY'; 1180 | 1181 | eval { push @$stack, reshape($src, $dims); }; 1182 | 1183 | if ( $@ ) { 1184 | $self->{_last_error} = $Array::DeepUtils::LastError; 1185 | $self->{_error} = 1; 1186 | return; 1187 | } 1188 | 1189 | }, 1190 | }, 1191 | 1192 | reverse => { 1193 | desc => 'Reverse the elements of a vector.', 1194 | type => 'function', 1195 | pop => [qw/A/], 1196 | push => [qw/A/], 1197 | code => sub { 1198 | my($self, $stack) = @_; 1199 | 1200 | push @$stack, [ reverse @{ pop @$stack } ] 1201 | }, 1202 | }, 1203 | 1204 | _roll => { 1205 | desc => 'Rotate stack elements.', 1206 | type => 'function', 1207 | pop => [qw/I I/], 1208 | code => sub { 1209 | my($self, $stack) = @_; 1210 | 1211 | my $nr_shift = pop @$stack; 1212 | my $nr_elem = pop @$stack; 1213 | 1214 | return unless $nr_shift and $nr_elem; 1215 | 1216 | $nr_shift %= $nr_elem; 1217 | 1218 | push @$stack, splice(@$stack, - $nr_elem, $nr_shift); 1219 | }, 1220 | }, 1221 | 1222 | rotate => { 1223 | desc => 'Rotate n-dimensional array.', 1224 | type => 'function', 1225 | pop => [qw/A A/], 1226 | push => [qw/A/], 1227 | code => sub { 1228 | my($self, $stack) = @_; 1229 | 1230 | my $rotvec = pop @$stack; 1231 | my $struct = pop @$stack; 1232 | 1233 | eval { push @$stack, rotate($struct, $rotvec); }; 1234 | 1235 | if ( $@ ) { 1236 | $self->{_last_error} = $Array::DeepUtils::LastError; 1237 | $self->{_error} = 1; 1238 | return; 1239 | } 1240 | }, 1241 | }, 1242 | 1243 | scatter => { 1244 | desc => 'Distribute elements of a one dimensional vector into a new structure.', 1245 | type => 'function', 1246 | pop => [qw/A A/], 1247 | push => [qw/A/], 1248 | code => sub { 1249 | my($self, $stack) = @_; 1250 | 1251 | my $struct = pop @$stack; 1252 | my $aref = pop @$stack; 1253 | 1254 | eval { push @$stack, scatter($aref, $struct); }; 1255 | 1256 | if ( $@ ) { 1257 | $self->{_last_error} = $Array::DeepUtils::LastError; 1258 | $self->{_error} = 1; 1259 | return; 1260 | } 1261 | }, 1262 | }, 1263 | 1264 | select => { 1265 | desc => 'Select elements from a nested structure (TOS - 1) controlled by a selector structure containing 0 and non-zero values (TOS).', 1266 | type => 'function', 1267 | pop => [qw/A A/], 1268 | push => [qw/A/], 1269 | code => sub { 1270 | my($self, $stack) = @_; 1271 | 1272 | my $a1 = pop @$stack; 1273 | my $a2 = pop @$stack; 1274 | my @res; 1275 | 1276 | for my $i ( 0 .. @$a2-1 ) { 1277 | push @res, $a2->[$i] if $a1->[$i]; 1278 | } 1279 | push @$stack, \@res; 1280 | }, 1281 | }, 1282 | 1283 | set => { 1284 | desc => 'Set and, if necessary, define a variable.', 1285 | type => 'function', 1286 | pop => [qw/V X/], 1287 | code => sub { 1288 | my($self, $stack) = @_; 1289 | 1290 | my $name = pop @$stack; 1291 | 1292 | # first check for a non variable of the same 1293 | # name in the visible word definitions 1294 | my $wroot = $self->_find_word($name); 1295 | 1296 | if ( $wroot and $wroot->{$name}{type} ne 'variable' ) { 1297 | $self->{_last_error} = "set: variable name $name conflicts with defined word"; 1298 | $self->{_error} = 1; 1299 | return; 1300 | } 1301 | 1302 | my $value = pop @$stack; 1303 | DEBUG "setting variable '$name' to value '$value'.\n"; 1304 | 1305 | $wroot = $self->{_word_exc_stack}[-1]; 1306 | $wroot->{$name} = { 1307 | type => 'variable', 1308 | value => $value, 1309 | }; 1310 | 1311 | $name =~ s/^__//; 1312 | $self->{$name} = $value if $published_vars{$name}; 1313 | $self->_setup_logger() 1314 | if $name eq 'log_level'; 1315 | }, 1316 | }, 1317 | 1318 | shape => { 1319 | desc => 'Return dimension vector.', 1320 | type => 'function', 1321 | pop => [qw/X/], 1322 | push => [qw/A/], 1323 | code => sub { 1324 | my($self, $stack) = @_; 1325 | 1326 | eval { push @$stack, shape($stack->[-1]); }; 1327 | 1328 | if ( $@ ) { 1329 | $self->{_last_error} = $Array::DeepUtils::LastError; 1330 | $self->{_error} = 1; 1331 | return; 1332 | } 1333 | }, 1334 | }, 1335 | 1336 | slice => { 1337 | desc => 'Copies a substructure from within a larger structure.', 1338 | type => 'function', 1339 | pop => [qw/A A/], 1340 | push => [qw/A/], 1341 | ntrl => [], 1342 | code => sub { 1343 | my ($self, $stack) = @_; 1344 | 1345 | my $coord = pop @$stack; 1346 | my $struct = pop @$stack; 1347 | 1348 | my $dest = eval { dcopy($struct, $coord) }; 1349 | 1350 | if ( $@ ) { 1351 | $self->{_last_error} = $Array::DeepUtils::LastError; 1352 | $self->{_error} = 1; 1353 | return; 1354 | } 1355 | 1356 | push @$stack, $dest; 1357 | }, 1358 | }, 1359 | 1360 | spread => { 1361 | desc => 'Apply a binary operator successively between elements of a vector.', 1362 | type => 'function', 1363 | pop => [qw/BO A/], 1364 | push => [qw/A/], 1365 | code => sub { 1366 | my ($self, $stack) = @_; 1367 | 1368 | DEBUG "spread stack: ", $stack; 1369 | 1370 | my $name = pop @$stack; 1371 | my $wroot = $self->_find_word($name); 1372 | 1373 | unless ( $wroot ) { 1374 | $self->{_last_error} = "spread: no operator/user defined word named '$name' found"; 1375 | $self->{_error} = 1; 1376 | return; 1377 | } 1378 | 1379 | my $word = $wroot->{$name}; 1380 | 1381 | unless ( $word->{type} eq 'binary' ) { 1382 | $self->{_last_error} = "spread: '$name' is not of type binary"; 1383 | $self->{_error} = 1; 1384 | return; 1385 | } 1386 | 1387 | my $aref = pop @$stack; 1388 | 1389 | unless ( @$aref ) { 1390 | push @$stack, $word->{ntrl}; 1391 | return; 1392 | } 1393 | 1394 | my @result; 1395 | push @result, (my $last_value = shift @$aref); 1396 | 1397 | for my $el ( @$aref ) { 1398 | eval { $self->_binary($word, $el, $last_value) }; 1399 | push @result, $last_value; 1400 | 1401 | if ( $@ ) { 1402 | $self->{_last_error} = "spread: $@"; 1403 | $self->{_error} = 1; 1404 | return; 1405 | } 1406 | 1407 | DEBUG "spread: result=$last_value, ", $el || ''; 1408 | } 1409 | 1410 | push @$stack, \@result; 1411 | }, 1412 | }, 1413 | 1414 | strip => { 1415 | desc => 'Removes the object type from a nested data structure.', 1416 | type => 'function', 1417 | pop => [qw/A/], 1418 | push => [qw/A/], 1419 | code => sub { 1420 | my ($self, $stack) = @_; 1421 | 1422 | return unless _is_aref($stack->[-1]); 1423 | 1424 | push @$stack, [ @{ pop @$stack } ]; 1425 | }, 1426 | }, 1427 | 1428 | subscript => { 1429 | desc => 'Select elements from an array determined by their respective index numbers.', 1430 | type => 'function', 1431 | pop => [qw/A A/], 1432 | push => [qw/A/], 1433 | code => sub { 1434 | my($self, $stack) = @_; 1435 | 1436 | my $coordinates = pop @$stack; # Vector containing coordinates of element to be selected. 1437 | my $source_data = pop @$stack; # Source data structure. 1438 | 1439 | my $aref; 1440 | eval { $aref = subscript($source_data, $coordinates); }; 1441 | 1442 | if ( $@ ) { 1443 | $self->{_last_error} = $Array::DeepUtils::LastError; 1444 | $self->{_error} = 1; 1445 | return; 1446 | } 1447 | 1448 | for ( @$aref ) { $_ = undef if ref($_) eq 'NaV' } 1449 | push @$stack, $aref; 1450 | }, 1451 | }, 1452 | 1453 | swap => { 1454 | desc => 'Swap TOS and TOS - 1.', 1455 | type => 'function', 1456 | pop => [qw/X X/], 1457 | push => [qw/X X/], 1458 | code => sub { 1459 | my($self, $stack) = @_; 1460 | 1461 | ($stack->[-1], $stack->[-2]) = ($stack->[-2], $stack->[-1]); 1462 | }, 1463 | }, 1464 | 1465 | transpose => { 1466 | desc => 'Transpose n-dimensional array.', 1467 | type => 'function', 1468 | pop => [qw/I A/], 1469 | push => [qw/A/], 1470 | code => sub { 1471 | my($self, $stack) = @_; 1472 | 1473 | my $control = pop @$stack; 1474 | my $struct = pop @$stack; 1475 | 1476 | eval { push @$stack, transpose($struct, $control); }; 1477 | 1478 | if ( $@ ) { 1479 | $self->{_last_error} = $Array::DeepUtils::LastError; 1480 | $self->{_error} = 1; 1481 | return; 1482 | } 1483 | }, 1484 | }, 1485 | 1486 | type => { 1487 | desc => 'Determine type of TOS-element.', 1488 | type => 'function', 1489 | pop => [qw/X/], 1490 | push => [qw/S/], 1491 | code => sub { 1492 | my($self, $stack) = @_; 1493 | 1494 | my $tos = $stack->[-1] || ''; 1495 | 1496 | my $wroot = $self->_find_word($tos); 1497 | 1498 | my $tref = ref($tos); 1499 | 1500 | my $type 1501 | = exists $wroot->{$tos} 1502 | ? uc($element_type{ $wroot->{$tos}{type} }) 1503 | : ( 1504 | $tref eq 'ARRAY' 1505 | ? 'A' 1506 | : ( $tref && $tref ne 'Lang5::String' ? 'D' : 'S' ) 1507 | ); 1508 | 1509 | push @$stack, $type; 1510 | }, 1511 | }, 1512 | 1513 | unlink => { 1514 | desc => 'Delete a file (name on TOS).', 1515 | type => 'function', 1516 | pop => [qw/S/], 1517 | code => sub { 1518 | my($self, $stack) = @_; 1519 | 1520 | my $file_name = pop @$stack; 1521 | 1522 | DEBUG "unlinking $file_name"; 1523 | 1524 | unlink($file_name) 1525 | or $self->{_last_error} = "error unlinking $file_name, $!"; 1526 | }, 1527 | }, 1528 | ); 1529 | 1530 | # Default object parameters. 1531 | my %default = ( 1532 | # private 1533 | _state => STATE_RUN, 1534 | _word_def_stack => [], 1535 | _word_exc_stack => [], 1536 | _stack => [], 1537 | _words => {}, 1538 | _exec_hist => [], 1539 | _statistics => {}, 1540 | _steps => 0, 1541 | _exit => 0, 1542 | _files => { 1543 | fileno(STDIN), { handle => \*STDIN, type => 'in', name => 'STDIN' }, 1544 | fileno(STDOUT), { handle => \*STDOUT, type => 'out', name => 'STDOUT' }, 1545 | fileno(STDERR), { handle => \*STDERR, type => 'out', name => 'STDERR' }, 1546 | }, 1547 | _fin => fileno(STDIN), 1548 | _fout => fileno(STDOUT), 1549 | _nocrlf => 0, 1550 | _text_buffer => [], 1551 | _line_buffer => [], 1552 | 1553 | # public 1554 | log_level => 'DEBUG', 1555 | terminal_width => 80, 1556 | libdir => './lib', 1557 | libautoload => 1, 1558 | text_callback => undef, 1559 | number_format => '%4s', 1560 | steps => 0, 1561 | ); 1562 | 1563 | 1564 | # Constructor. 1565 | sub new { 1566 | my($class, %params) = @_; 1567 | 1568 | my $self = { %default }; 1569 | bless $self, $class; 1570 | 1571 | $self->init(\%params); 1572 | 1573 | return($self); 1574 | } 1575 | 1576 | 1577 | sub init { 1578 | my($self, $params) = @_; 1579 | 1580 | $self->{$_} = $params->{$_} 1581 | for grep { ! /^_/ and defined $params->{$_} } keys %$params; 1582 | 1583 | for my $name ( keys %builtin ) { 1584 | $self->{_words}{$name} = $builtin{$name}; 1585 | $self->{_words}{$name}{name} = $name; 1586 | } 1587 | 1588 | $self->_setup_logger(); 1589 | 1590 | $self->{_words}{"__$_"} = { 1591 | type => 'variable', 1592 | value => $self->{$_}, 1593 | } for keys %published_vars; 1594 | 1595 | # initialize word search stack 1596 | push @{ $self->{_word_exc_stack} }, $self->{_words}; 1597 | 1598 | if ( $self->{libautoload} ) { 1599 | my $path = "$self->{libdir}/*.5"; 1600 | if ($path =~ m/]/) # Its seems we are running on an OpenVMS system. 1601 | { 1602 | $path =~ s/]//; 1603 | $path =~ s/\//\./g; 1604 | $path =~ s/\.\*/]\*/; 1605 | } 1606 | for my $lib ( glob $path ) { 1607 | push @{ $self->{_stack} }, $lib; 1608 | $self->{_words}{load}{code}->($self, $self->{_stack}); 1609 | } 1610 | } 1611 | } 1612 | 1613 | 1614 | sub _setup_logger { 1615 | my($self) = @_; 1616 | 1617 | for my $lev ( keys %debug_level ) { 1618 | 1619 | no strict 'refs'; 1620 | no warnings qw/redefine uninitialized prototype/; 1621 | 1622 | *{$lev} = $debug_level{$lev} < $debug_level{$self->{log_level}} 1623 | ? sub () {} 1624 | : sub (@) { 1625 | 1626 | my $ts = strftime("%Y-%m-%d %H:%M:%S ", localtime); 1627 | 1628 | warn 1629 | $ts, 1630 | $lev, 1631 | ' ', 1632 | map { 1633 | ref($_) 1634 | ? do { 1635 | my $d = Dumper($_); 1636 | $d =~ s/$re{strob}/$1/g; 1637 | $d; 1638 | } 1639 | : $_ 1640 | } @_, 1641 | $_[-1] =~ /\n$/ ? '' : "\n"; 1642 | 1643 | exit(1) if $lev eq 'FATAL'; 1644 | }; 1645 | } 1646 | } 1647 | 1648 | 1649 | # Return 1 if a scalar element is found in a structure (set operation in). 1650 | sub _is_in { 1651 | my($self, $el, $data) = @_; 1652 | 1653 | for my $d ( @$data ) { 1654 | 1655 | if ( ref($d) eq 'ARRAY' ) { 1656 | return 1 if $self->_is_in($el, $d); 1657 | } else { 1658 | return 1 if $el eq $d; 1659 | } 1660 | } 1661 | 1662 | return 0; 1663 | } 1664 | 1665 | 1666 | # Quote a string and convert its contents to hexadecimal representation. 1667 | # This is done to avoid splitting strings by the simple parser - in the 1668 | # hex representation a string does not contain any special or whitespace 1669 | # characters which would confuse the parser. 1670 | sub _secure_string { 1671 | my($str, $do_quote) = @_; 1672 | 1673 | INFO '_secure_string: >>', $str, '<<'; 1674 | 1675 | if ( $do_quote ) { 1676 | # mask variable markers to avoid unwanted side effects 1677 | # TODO better resolve the metachars manually and not in 1678 | # a string eval 1679 | $str =~ s/(?>', $line , '<<'; 1732 | 1733 | push @{ $self->{_line_buffer} }, $line; 1734 | } 1735 | 1736 | # Process lines from the line buffer and return an array 1737 | # reference to the parsed results. 1738 | sub _parse_source { 1739 | my($self) = @_; 1740 | 1741 | # split all lines in line buffer to program elements 1742 | my @prog = grep { 1743 | # last throw away empty elements 1744 | /\S+/ 1745 | } map { 1746 | # then split on brackets but keep them in the list 1747 | split /([\[\]])/; 1748 | } map { 1749 | # first split on whitespace 1750 | split /\s+/; 1751 | } @{ $self->{_line_buffer} }; 1752 | 1753 | for ( @prog ) { 1754 | next unless /^\{([0-9a-f]*)\}$/; 1755 | $_ = Lang5::String->new( 1756 | $self->_cleanup_string(pack('H*', $1)) 1757 | ); 1758 | } 1759 | 1760 | INFO "_parse_source: parsed ", \@prog; 1761 | 1762 | # empty line buffer 1763 | @{ $self->{_line_buffer} } = (); 1764 | 1765 | return \@prog; 1766 | } 1767 | 1768 | 1769 | # Parse, preprocess and execute a program: 1770 | sub execute { 1771 | my($self, $stack) = @_; 1772 | 1773 | # parse lines from the line buffer 1774 | my $prog = $self->_parse_source(); 1775 | 1776 | # bring arrays back into shape 1777 | return unless $self->_transmogrify_arrays($prog); 1778 | 1779 | # create nested substructures for ifs and loops 1780 | return unless $self->_if_do_structures($prog); 1781 | 1782 | # execute program 1783 | $self->{_break} = 0; 1784 | $self->_execute($prog, 1, $stack); 1785 | } 1786 | 1787 | 1788 | # Since the parser splits its input on every whitespace a routine is 1789 | # necessary to detect the definition of nested arrays which are then 1790 | # converted into real datastructures pushed to the data stack. 1791 | sub _transmogrify_arrays { 1792 | my($self, $prog) = @_; 1793 | 1794 | my $i = 0; 1795 | my @arrays; 1796 | 1797 | while ( 1 ) { 1798 | 1799 | unless ( defined $prog->[$i] ) { 1800 | $self->{_last_error} = 'undefined value in array definition!'; 1801 | $self->{_error} = 1; 1802 | return; 1803 | } 1804 | 1805 | # start a new array 1806 | # push empty array_ref on stack 1807 | if ( $prog->[$i] eq '[' ) { 1808 | push @arrays, []; 1809 | splice @$prog, $i, 1; 1810 | next; 1811 | } 1812 | 1813 | # end of current array 1814 | # get next element from array_stack 1815 | if ( $prog->[$i] eq ']' ) { 1816 | my $aref = pop @arrays; 1817 | 1818 | # Now that we found the closing bracket of an array we 1819 | # have to look at the next element in @$prog if it exists 1820 | # to determine if it looks like "(...)" denoting an 1821 | # object type. If such an element is found, we will bless 1822 | # the array we just created and remove the type name from 1823 | # @$prog. 1824 | if ($i < $#$prog and $prog->[$i + 1] =~ /^\((\w+)\)$/ ) { 1825 | $aref = bless($aref, $1); 1826 | splice @$prog, $i + 1, 1; 1827 | } 1828 | 1829 | if ( @arrays ) { 1830 | push @{$arrays[-1]}, $aref; 1831 | splice @$prog, $i, 1; 1832 | } else { 1833 | $prog->[$i] = $aref; 1834 | } 1835 | next; 1836 | } 1837 | 1838 | # push all elements from raw data 1839 | # to previously created array 1840 | if ( @arrays ) { 1841 | $prog->[$i] =~ s/^'(\S+)$/$1/; 1842 | $prog->[$i] = undef if $prog->[$i] eq 'undef'; 1843 | 1844 | if ( 1845 | $prog->[$i] 1846 | and 1847 | $prog->[$i] !~ /^$re{float}$/ 1848 | and 1849 | ref($prog->[$i]) ne 'Lang5::String' 1850 | ) { 1851 | $self->{_last_error} = "unquoted string >>$prog->[$i]<< in array!"; 1852 | $self->{_error} = 1; 1853 | return; 1854 | } 1855 | 1856 | push @{$arrays[-1]}, $prog->[$i]; 1857 | splice @$prog, $i, 1; 1858 | next; 1859 | } 1860 | 1861 | last if ++$i >= @$prog; 1862 | } 1863 | 1864 | return 1; 1865 | } 1866 | 1867 | # if and do structures are represented within a program as nested arrays. 1868 | # This subroutine loops over the raw program represented by a flat array of 1869 | # words and values and converts the conditional and loop constructs to 1870 | # the internal representation using nested arrays. 1871 | sub _if_do_structures { 1872 | my($self, $prog) = @_; 1873 | 1874 | my @stack; 1875 | 1876 | my $i = 0; 1877 | my @last; 1878 | while ( $i < @$prog ) { 1879 | 1880 | if ( 1881 | $prog->[$i] eq 'if' 1882 | or 1883 | $prog->[$i] eq 'do' 1884 | or 1885 | $prog->[$i] eq 'else' 1886 | ) { 1887 | if ( $prog->[$i] eq 'else' ) { 1888 | if ( !@last or $last[-1] ne 'if' ) { 1889 | $self->{_last_error} = 'else without prior if'; 1890 | $self->{_error} = 1; 1891 | return; 1892 | } 1893 | pop @stack; 1894 | } 1895 | 1896 | push @last, $prog->[$i]; 1897 | my $cref = []; 1898 | 1899 | if ( @stack ) { 1900 | push @{ $stack[-1] }, splice(@$prog, $i, 1), $cref; 1901 | } else { 1902 | splice @$prog, $i + 1, 0, $cref; 1903 | $i += 2; 1904 | } 1905 | 1906 | push @stack, $cref; 1907 | next; 1908 | } 1909 | 1910 | if ( $prog->[$i] eq 'then' or $prog->[$i] eq 'loop' ) { 1911 | 1912 | if ( 1913 | $prog->[$i] eq 'then' 1914 | and 1915 | ( !@last or ($last[-1] ne 'if' and $last[-1] ne 'else') ) 1916 | ) { 1917 | $self->{_last_error} = 'then without prior if or else'; 1918 | $self->{_error} = 1; 1919 | return; 1920 | } 1921 | 1922 | if ( 1923 | $prog->[$i] eq 'loop' 1924 | and 1925 | ( !@last or $last[-1] ne 'do' ) 1926 | ) { 1927 | $self->{_last_error} = 'loop without prior do'; 1928 | $self->{_error} = 1; 1929 | return; 1930 | } 1931 | 1932 | splice(@$prog, $i, 1); 1933 | pop @stack; 1934 | pop @last if $last[-1] eq 'else'; 1935 | pop @last; 1936 | next; 1937 | } 1938 | 1939 | if ( @stack ) { 1940 | push @{ $stack[-1] }, splice(@$prog, $i, 1); 1941 | } else { 1942 | $i++; 1943 | } 1944 | 1945 | } 1946 | 1947 | return 1; 1948 | } 1949 | 1950 | # Execute a program - this routine is called for programs as well as for 1951 | # user defined words etc. 'execute' is recursive as it calls itself on 1952 | # nested structures like user defined words, if-else-then or do-loop 1953 | # constructions. 1954 | sub _execute { 1955 | my($self, $program, $keep_state, $stack) = @_; 1956 | 1957 | INFO "_execute: program ", $program; 1958 | INFO "_execute: stack ", $stack; 1959 | 1960 | $stack ||= $self->{_stack}; 1961 | 1962 | # holds the last condition of an if-else-structure. 1963 | my $condition; 1964 | 1965 | # Holds the result of an executed program block. 1966 | # This may be undef or STATE_BREAK_EXECUTED. 1967 | my $block_result; 1968 | 1969 | $self->{_error} = 0; 1970 | 1971 | DEBUG "Stack contents: ", $stack; 1972 | DEBUG "Executing program or word: ", $program; 1973 | 1974 | $self->{_state} = STATE_RUN unless $keep_state; 1975 | 1976 | for my $element ( @$program ) { 1977 | 1978 | $self->{_steps}++; # Count the instruction just executed 1979 | if ($self->{steps} > 0 and $self->{_steps} >= $self->{steps}) 1980 | { 1981 | $self->{_last_error} = 'Maximum number of steps execeeded - abort'; 1982 | $self->{_error} = 1; 1983 | $self->{_exit_called} = 1; 1984 | return; 1985 | } 1986 | 1987 | if ( $self->{_exit_called} ) { 1988 | DEBUG "exit called"; 1989 | $self->{_break} = 1; 1990 | return; 1991 | } 1992 | 1993 | $self->{_statistics}{'Max. stack depth'} = @$stack 1994 | if $stack 1995 | && (!$self->{_statistics}{'Max. stack depth'} 1996 | || @$stack > $self->{_statistics}{'Max. stack depth'}); 1997 | 1998 | TRACE "Stack contents: ", $stack, "\nElement type: ", ref($element); 1999 | 2000 | last if $self->{_error} or $self->{_break}; 2001 | 2002 | push @{ $self->{_exec_hist} }, $element; 2003 | shift @{ $self->{_exec_hist} } 2004 | if @{ $self->{_exec_hist} } > 10; 2005 | 2006 | # If we are in the state STATE_SKIP_WORD_DEFINITION we 2007 | # will skip source elements until a ';' is found. 2008 | if ( $self->{_state} == STATE_SKIP_WORD_DEFINITION ) { 2009 | $self->{_state} = STATE_RUN if $element eq ';' and ref($element) ne 'Lang5::String'; 2010 | next; 2011 | } 2012 | 2013 | if ( $self->{_state} == STATE_IF_COMPLETED ) { 2014 | DEBUG "State is STATE_IF_COMPLETED"; 2015 | if ( $element eq 'else' ) { 2016 | $self->{_state} = STATE_EXECUTE_ELSE; 2017 | next; # Skip the else instruction itself 2018 | } else { 2019 | $self->{_state} = STATE_RUN; 2020 | } 2021 | } 2022 | 2023 | # The following block deals with the definition of new words: 2024 | if ( $element eq ';' and ref($element) ne 'Lang5::String' ) { 2025 | 2026 | # 1. End of word definition 2027 | 2028 | if ( $self->{_state} != STATE_EXPAND_WORD ) { 2029 | $self->{_last_error} = 'End of word definition not preceded by word definition!'; 2030 | $self->{_error} = 1; 2031 | return; 2032 | } 2033 | 2034 | # transfer program to subroutine ref in the 2035 | # currently defined word 2036 | my $wref = pop @{ $self->{_word_def_stack} }; 2037 | my $word = $self->_prog2code($wref); 2038 | 2039 | if ( @{ $self->{_word_def_stack} } > 0 ) { 2040 | $self->{_state} = STATE_EXPAND_WORD; 2041 | } else { 2042 | $self->{_state} = STATE_RUN; 2043 | } 2044 | 2045 | INFO "End definition of word >>$wref->{wname}<<: ", $word; 2046 | 2047 | } elsif ( $self->{_state} == STATE_START_WORD ) { 2048 | 2049 | # 2. Word header parsing 2050 | 2051 | my($wname, $ops, $ntrl) 2052 | = $self->_parse_word_header($element); 2053 | 2054 | unless ( $wname ) { 2055 | ERROR "Error in word header '$element'"; 2056 | $self->{_state} = STATE_SKIP_WORD_DEFINITION; 2057 | next; 2058 | } 2059 | 2060 | if ( $ntrl ) { 2061 | if ( $ntrl =~ /^\[/ ) { 2062 | my @parts = split /([\[\]])/, $ntrl; 2063 | $self->_transmogrify_arrays(\@parts); 2064 | $ntrl = $parts[1]; 2065 | } else { 2066 | $ntrl = undef if $ntrl eq 'undef'; 2067 | } 2068 | } 2069 | 2070 | INFO 'wname: ', $wname; 2071 | INFO 'ops: ', $ops; 2072 | INFO 'ntrl: ', $ntrl; 2073 | 2074 | my $wtype 2075 | = ref($ops) 2076 | ? $op_count{@$ops} 2077 | : 'f'; 2078 | 2079 | INFO 'wtype: ', $wtype; 2080 | 2081 | my $word_skeleton 2082 | = $self->_begin_word($wname, $wtype, $ops, $ntrl); 2083 | 2084 | if ( $word_skeleton ) { 2085 | $self->{_state} = STATE_EXPAND_WORD; 2086 | DEBUG "Begin new word '$wname', ", $word_skeleton; 2087 | } else { 2088 | $self->{_state} = STATE_SKIP_WORD_DEFINITION; 2089 | ERROR "Error redefining word '$wname'"; 2090 | } 2091 | 2092 | } elsif ( $element eq ':' ) { 2093 | 2094 | # 3. Start a new word 2095 | 2096 | $self->{_statistics}{'Word definitions'}++; 2097 | unless ( 2098 | $self->{_state} == STATE_RUN 2099 | or 2100 | $self->{_state} == STATE_EXPAND_WORD 2101 | ) { 2102 | $self->{_last_error} = 'Word definition not in run or expand_word mode!'; 2103 | $self->{_error} = 1; 2104 | return; 2105 | } 2106 | 2107 | $self->{_state} = STATE_START_WORD; 2108 | 2109 | DEBUG "':' found"; 2110 | 2111 | } elsif ( $self->{_state} == STATE_EXPAND_WORD ) { 2112 | 2113 | # 4. Extending the word 2114 | 2115 | # Read elements and append them to the new word 2116 | push @{ $self->{_word_def_stack}[-1]{prog} }, $element; 2117 | 2118 | DEBUG "Extend word with '$element'"; 2119 | 2120 | } elsif ( $self->{_state} == STATE_EXECUTE_IF ) { 2121 | 2122 | # Handle if-else-then construction. 2123 | DEBUG "State is STATE_EXECUTE_IF"; 2124 | unless ( ref($element) eq 'ARRAY' ) { 2125 | $self->{_last_error} = 'Internal error executing if-construct!'; 2126 | $self->{_error} = 1; 2127 | return; 2128 | } 2129 | 2130 | # The result code could be BREAK_EXECUTED and has to be handled. 2131 | if ( $condition ) { 2132 | $block_result = $self->_execute($element, 0, $stack); 2133 | return if $self->{_error} or $self->{_break}; 2134 | } 2135 | 2136 | $self->{_state} = STATE_IF_COMPLETED; 2137 | 2138 | return $block_result 2139 | if $block_result and $block_result == STATE_BREAK_EXECUTED; 2140 | 2141 | } elsif ( $self->{_state} == STATE_EXECUTE_ELSE ) { 2142 | 2143 | $self->{_statistics}{'Else'}++; 2144 | 2145 | DEBUG "State is STATE_EXECUTE_ELSE"; 2146 | 2147 | unless ( ref($element) eq 'ARRAY' ) { 2148 | $self->{_last_error} = 'Internal error executing else-construct!'; 2149 | $self->{_error} = 1; 2150 | return; 2151 | } 2152 | 2153 | unless ( $condition ) { 2154 | $block_result = $self->_execute($element, 0, $stack); 2155 | return if $self->{_error} or $self->{_break}; 2156 | } 2157 | 2158 | $self->{_state} = STATE_RUN; 2159 | 2160 | return $block_result 2161 | if $block_result and $block_result == STATE_BREAK_EXECUTED; 2162 | 2163 | } elsif ( $self->{_state} == STATE_EXECUTE_DO ) { 2164 | 2165 | # Handle do-loop constructions. 2166 | DEBUG "State is STATE_EXECUTE_DO"; 2167 | 2168 | $self->{_statistics}{'Do...Loop'}++; 2169 | 2170 | unless ( ref($element) eq 'ARRAY' ) { 2171 | $self->{_last_error} = 'Internal error executing do-loop!'; 2172 | $self->{_error} = 1; 2173 | return; 2174 | } 2175 | 2176 | my $result = 0; 2177 | while ( ! $result ) { 2178 | $result = $self->_execute($element, 0, $stack); 2179 | return if $self->{_error} or $self->{_break}; 2180 | } 2181 | 2182 | DEBUG "Loop exited by break!" 2183 | if $result == STATE_BREAK_EXECUTED; 2184 | 2185 | $self->{_state} = STATE_RUN; 2186 | 2187 | } elsif ( $element eq 'if' ) { 2188 | 2189 | DEBUG ">>> Execute if"; 2190 | 2191 | $self->{_statistics}{'If'}++; 2192 | 2193 | $condition = pop @$stack; 2194 | 2195 | $self->{_state} = STATE_EXECUTE_IF; 2196 | 2197 | } elsif ( $element eq 'else' ) { 2198 | 2199 | $self->{_last_error} = 'Else not within if-context!'; 2200 | $self->{_error} = 1; 2201 | return; 2202 | 2203 | } elsif ( $element eq 'do' ) { 2204 | 2205 | # Execute a do-loop structure 2206 | DEBUG "Executing a do loop."; 2207 | 2208 | $self->{statistics}{'Do...Loop'}++; 2209 | 2210 | $self->{_state} = STATE_EXECUTE_DO; 2211 | 2212 | } elsif ( $element eq 'break' ) { 2213 | 2214 | DEBUG "Execute break."; 2215 | 2216 | $self->{statistics}{'Break'}++; 2217 | 2218 | return STATE_BREAK_EXECUTED; 2219 | 2220 | } elsif ( ref($element) eq 'Lang5::String' ) { 2221 | 2222 | DEBUG "Push string '$element'"; 2223 | push @$stack, $element; 2224 | $self->{_statistics}{'Push data'}++; 2225 | 2226 | } elsif ( $element =~ /^$re{float}$/ ) { 2227 | # numbers should end up as "real" numbers on the stack 2228 | 2229 | DEBUG "Push number $element"; 2230 | push @$stack, $element + 0; 2231 | $self->{_statistics}{'Push data'}++; 2232 | 2233 | } elsif ( ref($element) ) { 2234 | 2235 | DEBUG "Push array ", $element; 2236 | push @$stack, dclone($element); 2237 | $self->{_statistics}{'Push data'}++; 2238 | 2239 | } elsif ( $element eq 'undef' ) { 2240 | 2241 | DEBUG "Push undef"; 2242 | push @$stack, undef; 2243 | $self->{_statistics}{'Push data'}++; 2244 | 2245 | } elsif ( my $wroot = $self->_find_word($element) ) { 2246 | 2247 | $self->{_statistics}{'execute word'}++; 2248 | $self->{_statistics}{$element}++; 2249 | 2250 | $self->_execute_word($wroot, $element, $stack); 2251 | 2252 | } else { 2253 | 2254 | ERROR "unknown element '$element'"; 2255 | $self->{_error} = 1; 2256 | $self->{_last_error} = "unknown element '$element'"; 2257 | return; 2258 | 2259 | } 2260 | } 2261 | } 2262 | 2263 | 2264 | sub _check_params { 2265 | my($self, $ptype, $stack) = @_; 2266 | 2267 | $ptype ||= []; 2268 | 2269 | DEBUG "_check_params: types: ", join(' ', @$ptype), " stack: ", $stack; 2270 | 2271 | if ( @$stack < @$ptype ) { 2272 | $self->{_last_error} = "too few elements on stack, expected @$ptype"; 2273 | return; 2274 | } 2275 | 2276 | my $i = -1; 2277 | for my $type ( @$ptype ) { 2278 | unless ( $param_checks{$type}{code}->($self, $stack->[$i]) ) { 2279 | $self->{_last_error} = "stack element $i does not match type $type"; 2280 | return; 2281 | } 2282 | $i--; 2283 | } 2284 | 2285 | DEBUG "_check_params: stack after: ", $stack; 2286 | 2287 | return 1; 2288 | } 2289 | 2290 | 2291 | # Apply an unary word to all elements of a nested structure. 2292 | sub _unary { 2293 | my $self = shift; 2294 | my $word = shift; 2295 | 2296 | INFO "_unary: word: ", $word; 2297 | INFO "_unary: data: ", $_[0]; 2298 | 2299 | my $func = $self->_get_func($word); 2300 | my $ntrl = $self->_get_ntrl($word); 2301 | 2302 | INFO "_unary: func:", $func; 2303 | INFO "_unary: ntrl:", $ntrl; 2304 | 2305 | unless ( ref($_[0]) eq 'ARRAY' ) { 2306 | $_[0] = defined($_[0]) 2307 | ? $func->($self, $_[0]) 2308 | : $ntrl->($_[0]); 2309 | return; 2310 | } 2311 | 2312 | # no eval because _unary will be called in an evel {} 2313 | unary($_[0], $func, $ntrl, $self); 2314 | 2315 | return 1; 2316 | } 2317 | 2318 | 2319 | # Apply a binary word to a nested data structure. 2320 | sub _binary { 2321 | my($self) = shift; 2322 | my($word) = shift; 2323 | 2324 | TRACE "_binary: word: ", $word; 2325 | TRACE "_binary: x: ", $_[0]; 2326 | TRACE "_binary: y: ", $_[1]; 2327 | 2328 | my $func = $self->_get_func($word); 2329 | my $ntrl = $self->_get_ntrl($word); 2330 | 2331 | TRACE "_binary: func:", $func; 2332 | TRACE "_binary: ntrl:", $ntrl; 2333 | 2334 | # both operands not array refs -> exec and early return 2335 | if ( ref($_[0]) ne 'ARRAY' and ref($_[1]) ne 'ARRAY' ) { 2336 | $_[1] = ( defined($_[0]) and defined($_[1]) ) 2337 | ? $func->($self, $_[0], $_[1]) 2338 | : $ntrl->($_[0], $_[1]); 2339 | DEBUG "binary op func returned ", $_[1] ? $_[1] : 'undef'; 2340 | return(1); 2341 | } 2342 | 2343 | # no eval because _binary will be called in an evel {} 2344 | binary($_[0], $_[1], $func, $ntrl, $self); 2345 | 2346 | return 1; 2347 | } 2348 | 2349 | 2350 | # Strings enclosed in double quotes have been converted into hex ASCII 2351 | # representation to avoid getting them split by the simple parser. 2352 | # After parsing the program, these strings have to be converted back 2353 | # into readable text which is done here. Note that strings can be recognized 2354 | # throughout the interpreter by their enclosing double quotes which are retained. 2355 | sub _cleanup_string { 2356 | my($self, $string) = @_; 2357 | 2358 | INFO '_cleanup_string got >>', $string, '<<'; 2359 | 2360 | # marked double quotes to escaped double quotes 2361 | $string =~ s/__CTSQ__/'/g; # " 2362 | 2363 | # marked double quotes to escaped double quotes 2364 | $string =~ s/__CTDQ__/"/g; # " 2365 | 2366 | # marked backslashes to escaped backslashes 2367 | $string =~ s/__CTBS__/\\\\/g; 2368 | 2369 | # marked spaces to real spaces 2370 | $string =~ s/__CTWS__/ /g; 2371 | 2372 | # marked opening brackets to real opening brackets 2373 | $string =~ s/__CTOB__/\[/g; 2374 | 2375 | # marked closing brackets to real closing brackets 2376 | $string =~ s/__CTCB__/\]/g; 2377 | 2378 | INFO '_cleanup_string cleaned >>', $string, '<<'; 2379 | 2380 | return $string; 2381 | } 2382 | 2383 | 2384 | sub _is_aref { 2385 | return eval { @{$_[0]} + 1 }; 2386 | } 2387 | 2388 | 2389 | sub get_text { 2390 | my($self) = @_; 2391 | 2392 | my @lines = @{ $self->{_text_buffer} }; 2393 | 2394 | @{ $self->{_text_buffer} } = (); 2395 | 2396 | return @lines; 2397 | } 2398 | 2399 | # Implements '.'; dump a scalar or structure to text. 2400 | sub _element2text { 2401 | my($self, $element, $quote_strings) = @_; 2402 | 2403 | INFO "_element2text: formatting element ", $element; 2404 | INFO "_element2text: strings will" 2405 | , $quote_strings ? ' ' : ' not ' 2406 | ,"be quoted"; 2407 | 2408 | # shortcut for simple scalars 2409 | if ( !ref($element) or ref($element) eq 'Lang5::String' ) { 2410 | $element = 'undef' unless defined $element; 2411 | $element .= "\n" if $element =~ /^$re{float}$/; 2412 | return $element; 2413 | } 2414 | 2415 | my $indent = 2; 2416 | my @estack = ( $element ); 2417 | my @istack = ( 0 ); 2418 | 2419 | my $txt = ''; 2420 | 2421 | while ( @estack ) { 2422 | 2423 | my $e = $estack[-1]; 2424 | my $i = $istack[-1]; 2425 | 2426 | # new array: output opening bracket 2427 | if ( $i == 0 ) { 2428 | if ( $txt ) { 2429 | $txt .= "\n"; 2430 | $txt .= ' ' x ( $indent * ( @istack - 1 ) ); 2431 | } 2432 | $txt .= '['; 2433 | } 2434 | 2435 | if ( $i <= $#$e ) { 2436 | # push next reference and a new index onto stacks 2437 | if ( ref($e->[$i]) and ref($e->[$i]) ne 'Lang5::String' ) { 2438 | push @estack, $e->[$i]; 2439 | push @istack, 0; 2440 | next; 2441 | } 2442 | 2443 | # output element 2444 | if ( $txt =~ /\]$/ ) { 2445 | $txt .= "\n"; 2446 | $txt .= ' ' x ( $indent * @istack ); 2447 | } else { 2448 | $txt .= ' '; 2449 | } 2450 | $txt .= defined($e->[$i]) 2451 | ? ( $e->[$i] =~ m/^$re{float}$/ 2452 | ? sprintf("$self->{number_format} ", $e->[$i]) 2453 | : ( $quote_strings 2454 | ? $self->_quote_if_string($e->[$i]) 2455 | : $e->[$i] 2456 | ) 2457 | ) 2458 | : 'undef'; 2459 | } 2460 | 2461 | # after last item, close arrays 2462 | # on an own line and indent next line 2463 | if ( $i >= $#$e ) { 2464 | 2465 | my($ltxt) = $txt =~ /(?:\A|\n)([^\n]*?)$/; 2466 | 2467 | # The current text should not end in a closing bracket as it 2468 | # would if we had typed an array and it should not end in a 2469 | # parenthesis as it would if we typed an array with an object 2470 | # type . 2471 | if ( $ltxt =~ /\[/ and $ltxt !~ /\]|\)$/ ) { 2472 | $txt .= ' '; 2473 | } else { 2474 | $txt .= "\n"; 2475 | $txt .= ' ' x ( $indent * ( @istack - 1 ) ); 2476 | } 2477 | $txt .= ']'; 2478 | 2479 | # Did we print an element that had an object type set? 2480 | my $last_type = ref(pop @estack); 2481 | $txt .= "($last_type)" 2482 | if $last_type 2483 | and 2484 | $last_type ne 'ARRAY' 2485 | and 2486 | $last_type ne 'Lang5::String'; 2487 | pop @istack; 2488 | } 2489 | 2490 | $istack[-1]++ 2491 | if @istack; 2492 | } 2493 | 2494 | $txt .= "\n" unless $txt =~ /\n$/; 2495 | 2496 | return $txt; 2497 | } 2498 | 2499 | 2500 | # Handling the content of the output text buffer. 2501 | sub _output { 2502 | my $self = shift; 2503 | 2504 | TRACE "_output: ", \@_; 2505 | 2506 | push @{ $self->{_text_buffer} }, @_; 2507 | 2508 | my $current_fout = $self->{_files}{$self->{_fout}}{name}; 2509 | my $current_hout = $self->{_files}{$self->{_fout}}{handle}; 2510 | 2511 | if ( $current_fout ne 'STDOUT' and $current_fout ne 'STDERR' ) { 2512 | 2513 | # an output file is specified -> print buffer to file 2514 | 2515 | print $current_hout @{ $self->{_text_buffer} }; 2516 | 2517 | } elsif ( $self->{text_callback} ) { 2518 | 2519 | # STDOUT|STDERR and callback set -> call callback 2520 | TRACE "calling text_callback"; 2521 | $self->{text_callback}->( @{ $self->{_text_buffer} } ); 2522 | 2523 | } else { 2524 | 2525 | # let calling app handle text with get_text() 2526 | return; 2527 | } 2528 | 2529 | # clearing text_buffer 2530 | @{ $self->{_text_buffer} } = (); 2531 | } 2532 | 2533 | # Put an evenly spaced multiline list of all user defined words known to 2534 | # the interpreter into the text buffer. Each word is preceded by a letter 2535 | # denoting its type (cf. subroutine word_list). 2536 | sub _words2text_buffer { 2537 | my($self) = @_; 2538 | 2539 | my $i = 0; 2540 | my $txt = ''; 2541 | for my $entry ( sort keys %{ $self->{_words} } ) { 2542 | 2543 | my $type = uc($element_type{$self->{_words}{$entry}{type}}) || '-'; 2544 | 2545 | $txt .= sprintf "%s:%-12s ", $type, $entry; 2546 | $txt .= "\n" if ++$i % 5 == 0; 2547 | } 2548 | 2549 | $txt .= "\n" if $i % 5 != 0; 2550 | 2551 | $self->_output($txt); 2552 | } 2553 | 2554 | 2555 | # Dump the definition of a word, making use of 2556 | # _explain_word, defined below: 2557 | sub _dump_word { 2558 | my($self, $name) = @_; 2559 | 2560 | my $wroot = $self->_find_word($name); 2561 | 2562 | unless ( $wroot ) { 2563 | ERROR "no user defined word or element named '$name' found"; 2564 | return; 2565 | } 2566 | 2567 | my $word = $wroot->{$name}; 2568 | my $type = $word->{type}; 2569 | 2570 | INFO "_dump_word: word: ", $word; 2571 | 2572 | my %wkeys = map { $_ => 1 } grep { 2573 | ref($word->{$_}) eq 'HASH' 2574 | } keys %$word; 2575 | 2576 | INFO "_dump_word: wkeys:", \%wkeys; 2577 | 2578 | unless ( $type eq 'variable' or keys(%wkeys) ) { 2579 | ERROR "'$name' is not of type variable or user defined word"; 2580 | return; 2581 | } 2582 | 2583 | if ( $type eq 'variable' ) { 2584 | my $value = (ref($word->{value}) || $word->{value} =~ /$re{float}/) 2585 | ? $word->{value} 2586 | : "\"$word->{value}\""; 2587 | return "$value '$name set\n"; 2588 | } 2589 | 2590 | my $wtype = $element_type{$type}; 2591 | 2592 | my $txt; 2593 | for my $wkey ( sort keys %wkeys ) { 2594 | my $exp = $self->_explain_word($word, $name, $wkey); 2595 | my $ntrl = $word->{$wkey}{ntrl}; 2596 | $txt .= ": $name"; 2597 | if ( $word->{pop} ) { 2598 | my @wk = split(/\s/, $wkey); 2599 | my $oc = $#{ $word->{pop} }; 2600 | $txt .= '('; 2601 | $txt .= join(',', map { $wk[$_] || '*' } 0..$oc); 2602 | $txt .= ')'; 2603 | } 2604 | $txt .= "{$ntrl}" if $ntrl; 2605 | $txt .= "\n$exp"; 2606 | $txt .= "\n" unless $exp =~ /\n$/; 2607 | $txt .= ";\n" 2608 | } 2609 | 2610 | $txt .= "\n"; 2611 | 2612 | return($txt); 2613 | } 2614 | 2615 | 2616 | # iteratively dump a word definition. 2617 | sub _explain_word { 2618 | my($self, $word, $name, $wkey) = @_; 2619 | 2620 | $wkey ||= ' '; 2621 | 2622 | my @prog = @{ $word->{$wkey}{prog} }; 2623 | 2624 | INFO "_explain_word: prog: ", \@prog; 2625 | 2626 | my $i = -1; 2627 | while ( ++$i < @prog ) { 2628 | 2629 | next if !ref($prog[$i]) or ref($prog[$i]) eq 'Lang5::String'; 2630 | 2631 | my $flatten = 0; 2632 | if ( $i > 0 and $prog[$i - 1] eq 'do' ) { 2633 | splice @prog, $i + 1, 0, 'loop'; 2634 | $flatten = 1; 2635 | } 2636 | 2637 | if ( $i > 0 and $prog[$i - 1] eq 'else' ) { 2638 | splice @prog, $i + 1, 0, 'then'; 2639 | $flatten = 1; 2640 | } 2641 | 2642 | if ( $i > 0 and $prog[$i - 1] eq 'if' ) { 2643 | splice @prog, $i + 1, 0, 'then' 2644 | unless $prog[$i + 1] and $prog[$i + 1] eq 'else'; 2645 | $flatten = 1; 2646 | } 2647 | 2648 | splice @prog, $i , 1, @{ $prog[$i] } 2649 | if $flatten; 2650 | } 2651 | 2652 | $i = -1; 2653 | my $indent = " " x 2; 2654 | my $depth = 1; 2655 | my $txt = ''; 2656 | 2657 | while ( ++$i < @prog ) { 2658 | 2659 | INFO "E:$prog[$i], D:$depth"; 2660 | 2661 | my $el; 2662 | if ( $prog[$i] =~ /^(?:if|else|then|do|loop)$/ ) { 2663 | $el = $prog[$i]; 2664 | } elsif ( ref($prog[$i]) eq 'ARRAY' ) { 2665 | INFO "_explain_word: formatting ", $prog[$i]; 2666 | $el = $self->_element2text($prog[$i], 1); 2667 | } else { 2668 | $el = $self->_quote_if_string($prog[$i]); 2669 | } 2670 | 2671 | my($lastline) = $txt =~ /([^\n]+)$/; 2672 | $lastline ||= ''; 2673 | TRACE "L: >>$lastline<<"; 2674 | 2675 | if ( 2676 | $prog[$i] eq 'else' 2677 | or ( 2678 | $prog[$i] =~ /^(?:if|then|do|loop)$/ 2679 | and 2680 | $prog[$i-1] !~ /^(?:if|then|do|loop)$/ 2681 | ) 2682 | or 2683 | length($lastline || '') + length($el) > $self->{terminal_width} - 10 2684 | ) { 2685 | TRACE "add newline before element"; 2686 | $txt .= "\n"; 2687 | } 2688 | 2689 | my $prefix; 2690 | if ( $prog[$i] =~ /^(?:if|do)$/ ) { 2691 | $prefix = $indent x $depth++; 2692 | } elsif ( $prog[$i] =~ /^(?:loop|then)$/ ) { 2693 | $prefix = $indent x --$depth; 2694 | } elsif ( $prog[$i] eq 'else' ) { 2695 | $prefix = $indent x ($depth - 1); 2696 | } else { 2697 | $prefix = $indent x $depth; 2698 | } 2699 | 2700 | $prefix = ' ' if $txt !~ /(\A|\n)$/; 2701 | 2702 | my $postfix = ''; 2703 | if ( $prog[$i] =~ /^(?:if|else|then|do|loop)$/ ) { 2704 | $postfix = "\n"; 2705 | } 2706 | 2707 | $txt .= $prefix . $el . $postfix; 2708 | } 2709 | 2710 | return $txt; 2711 | } 2712 | 2713 | 2714 | sub _parse_word_header { 2715 | my($self, $el) = @_; 2716 | 2717 | TRACE '_parse_word_header -> el: ', $el; 2718 | 2719 | my@parts = $el =~ /^ 2720 | ([^\(\)]+) # non parens --> name 2721 | (?: # do not capture 2722 | \((.*?)\) # everything in parens --> opstr 2723 | )? # the parens section is optional 2724 | (?: # do not capture 2725 | \{(.+?)\} # everything in braces --> ntrl 2726 | )? # the braces section is optional 2727 | $/x; 2728 | 2729 | TRACE 'parts:', \@parts; 2730 | 2731 | $parts[1] = [ split /\s*,\s*/, $parts[1] || '' ] 2732 | if defined $parts[1] ; 2733 | 2734 | return @parts; 2735 | } 2736 | 2737 | 2738 | sub _begin_word { 2739 | my($self, $wname, $wtype, $ops, $ntrl) = @_; 2740 | 2741 | # long name for word type wtype==b --> type==binary 2742 | my $type = $wtype eq 'f' ? 'function' : $reverse_type{$wtype}; 2743 | 2744 | # hash key for operand types 2745 | my $wkey = ' '; 2746 | if ( $type eq 'unary' ) { 2747 | $wkey = $ops->[0] || '*'; 2748 | } elsif ( $type eq 'binary') { 2749 | $wkey = join(' ', map { $ops->[$_] || '*' } 0 .. 1); 2750 | } 2751 | 2752 | my $wroot 2753 | = @{ $self->{_word_def_stack} } 2754 | ? $self->{_word_def_stack}[-1]{words} 2755 | : $self->{_words}; 2756 | 2757 | # checks 2758 | if ( exists $wroot->{$wname} ) { 2759 | 2760 | # type cannot be changed 2761 | my $old_type = $wroot->{$wname}{type}; 2762 | if ( $type ne $old_type ) { 2763 | my $msg = "Word name '$wname' already defined with type '$old_type'"; 2764 | $self->{_last_error} = $msg; 2765 | ERROR $msg; 2766 | return; 2767 | } 2768 | 2769 | if ( exists $wroot->{$wname}{$wkey} ) { 2770 | WARN "redefining word $wname($wkey)"; 2771 | } 2772 | 2773 | } else { 2774 | 2775 | # create default entry 2776 | $wroot->{$wname} = { 2777 | name => $wname, 2778 | type => $type, 2779 | $wtype eq 'f' ? () : ( pop => $stack_type{$wtype} ), 2780 | $wtype eq 'f' ? () : ( stack => [] ), 2781 | }; 2782 | } 2783 | 2784 | # create entry in word hash 2785 | $wroot->{$wname}{$wkey} = { 2786 | prog => [], 2787 | words => {}, 2788 | $ntrl ? ( ntrl => $ntrl ) : (), 2789 | }; 2790 | 2791 | # push new word definition values to word_stack 2792 | push @{ $self->{_word_def_stack} }, { 2793 | words => $wroot->{$wname}{$wkey}{words}, 2794 | wkey => $wkey, 2795 | wname => $wname, 2796 | prog => $wroot->{$wname}{$wkey}{prog}, 2797 | }; 2798 | 2799 | return $wroot->{$wname}; 2800 | } 2801 | 2802 | 2803 | sub _prog2code { 2804 | my($self, $wref) = @_; 2805 | 2806 | my $wroot 2807 | = @{ $self->{_word_def_stack} } 2808 | ? $self->{_word_def_stack}[-1]{words} 2809 | : $self->{_words}; 2810 | 2811 | my $wkey = $wref->{wkey}; 2812 | my $wname = $wref->{wname}; 2813 | 2814 | my $word = $wroot->{$wname}; 2815 | my $wpop = $word->{pop} || []; 2816 | 2817 | INFO "_prog2code: wname:>>$wname<<, wkey:>>$wkey<<"; 2818 | 2819 | $word->{$wkey}{code} = sub { 2820 | 2821 | INFO "called anon sub '$wname' with key '$wkey'"; 2822 | INFO "Params: ", [@_[1..$#_]]; 2823 | 2824 | my $udf 2825 | = $word->{type} =~ /^unary|binary$/ 2826 | and 2827 | exists($word->{prog}); 2828 | 2829 | my $wstack; 2830 | if ( $udf ) { 2831 | push @{ $word->{stack} }, $_[$_] 2832 | for reverse 1 .. @$wpop; 2833 | $wstack = $word->{stack}; 2834 | } else { 2835 | $wstack = $_[1]; 2836 | } 2837 | 2838 | INFO "$wname: wstack: ", $wstack; 2839 | 2840 | push @{ $self->{_word_exc_stack} }, $word->{$wkey}{words} || {}; 2841 | 2842 | $self->{_last_error} = undef; 2843 | $self->_execute($word->{$wkey}{prog}, 1, $wstack); 2844 | 2845 | pop @{ $self->{_word_exc_stack} }; 2846 | 2847 | # $word->{code} should be run in an eval 2848 | die $self->{_last_error} . "\n" 2849 | if $self->{_last_error}; 2850 | 2851 | INFO 'word stack: ', $word->{stack}; 2852 | 2853 | if ( $udf ) { 2854 | return pop @{ $word->{stack} }; 2855 | } else { 2856 | return; 2857 | } 2858 | }; 2859 | 2860 | TRACE "_prog2code: word: ", $word; 2861 | 2862 | return $word; 2863 | } 2864 | 2865 | 2866 | sub _execute_word { 2867 | my($self, $wroot, $wname, $stack) = @_; 2868 | 2869 | my $word = $wroot->{$wname}; 2870 | 2871 | INFO "_execute_word: word ", $word; 2872 | INFO "_execute_word: stack ", $stack; 2873 | 2874 | if ( $word->{type} eq 'variable' ) { 2875 | 2876 | # if the current element is the name of a variable, 2877 | # push its contents onto the data stack 2878 | DEBUG "Push contents of variable $wname onto stack"; 2879 | $self->{_statistics}{'Push variable'}++; 2880 | push @$stack, ref($word->{value}) ? dclone($word->{value}) : $word->{value}; 2881 | return 1; 2882 | } 2883 | 2884 | # check the stack 2885 | if ( $word->{pop} and @{ $word->{pop} } ) { 2886 | unless ( $self->_check_params($word->{pop}, $stack) ) { 2887 | $self->{_error} = 1; 2888 | return; 2889 | } 2890 | } 2891 | 2892 | my @result; 2893 | if ( $word->{type} eq 'unary' ) { 2894 | 2895 | eval { $self->_unary($word, $stack->[-1]) }; 2896 | 2897 | } elsif ( $word->{type} eq 'binary' ) { 2898 | 2899 | eval { $self->_binary($word, $stack->[-1], $stack->[-2]) }; 2900 | 2901 | } else { 2902 | 2903 | my $func 2904 | = exists($word->{' '}) 2905 | ? $word->{' '}{code} 2906 | : $word->{code}; 2907 | 2908 | @result = eval { $func->($self, $stack) }; 2909 | 2910 | } 2911 | 2912 | if ( $@ ) { 2913 | $self->{_last_error} = $@; 2914 | $self->{_error} = 1; 2915 | return; 2916 | } else { 2917 | push @$stack, @result 2918 | if $word->{type} eq 'niladic'; 2919 | } 2920 | 2921 | $self->{_statistics}{ucfirst($word->{type})}++; 2922 | 2923 | # binary words modify TOS - 1 --> remove TOS 2924 | pop @$stack 2925 | if $word->{type} eq 'binary'; 2926 | 2927 | return 1; 2928 | } 2929 | 2930 | 2931 | sub _get_func { 2932 | my($self, $word) = @_; 2933 | 2934 | return sub { 2935 | 2936 | my @refs = map { 2937 | my $r = ref($_[$_]); 2938 | (!$r or $r eq 'Lang5::String') ? '*' : $r; 2939 | } 1 .. 2; 2940 | my $wkey 2941 | = $word->{type} eq 'unary' 2942 | ? ($refs[0] eq 'ARRAY' ? '*' : $refs[0]) 2943 | : join(' ', map { 2944 | $_ eq 'ARRAY' ? '*' : $_ 2945 | } reverse @refs); 2946 | 2947 | if ( exists $word->{$wkey} ) { 2948 | $word->{$wkey}{code}->(@_); 2949 | } elsif ( 2950 | ($wkey eq '*' or $wkey eq '* *') 2951 | and 2952 | exists $word->{code} 2953 | ) { 2954 | $word->{code}->(@_); 2955 | } else { 2956 | die "no handler for type '$wkey'\n"; 2957 | } 2958 | }; 2959 | } 2960 | 2961 | 2962 | sub _get_ntrl { 2963 | my($self, $word) = @_; 2964 | 2965 | return sub { 2966 | 2967 | my @refs = map { 2968 | my $r = ref($_[$_]); 2969 | (!$r or $r eq 'Lang5::String') ? '*' : $r; 2970 | } 1 .. 2; 2971 | my $wkey 2972 | = $word->{type} eq 'unary' 2973 | ? ($refs[0] eq 'ARRAY' ? '*' : $refs[0]) 2974 | : join(' ', map { 2975 | $_ eq 'ARRAY' ? '*' : $_ 2976 | } reverse @refs); 2977 | 2978 | if ( exists $word->{$wkey} ) { 2979 | return $word->{$wkey}{ntrl}; 2980 | } else { 2981 | return $word->{ntrl} || ''; 2982 | } 2983 | 2984 | }; 2985 | } 2986 | 2987 | 2988 | sub _find_word { 2989 | my($self, $wname) = @_; 2990 | 2991 | my $wroot; 2992 | for $wroot ( reverse @{ $self->{_word_exc_stack} } ) { 2993 | return $wroot if $wroot->{$wname}; 2994 | } 2995 | 2996 | return; 2997 | } 2998 | 2999 | # quote item if its a string 3000 | sub _quote_if_string { 3001 | my($self, $value) = @_; 3002 | 3003 | return $value unless ref($value) eq 'Lang5::String'; 3004 | 3005 | (my $quoted = $$value) =~ s/\\/\\\\/; 3006 | $quoted =~ s/\n/\\n/; 3007 | $quoted =~ s/\t/\\t/; 3008 | $quoted = '"' . $quoted . '"'; 3009 | 3010 | return $quoted; 3011 | } 3012 | 3013 | 3014 | sub statistics { $_[0]->{_statistics} } 3015 | 3016 | sub error { $_[0]->{_error} } 3017 | 3018 | sub exit_called { $_[0]->{_exit_called} } 3019 | 3020 | sub set_break { $_[0]->{_break} = 1 } 3021 | 3022 | sub break_called { $_[0]->{_break} } 3023 | 3024 | sub last_error { $_[0]->{_last_error} } 3025 | 3026 | sub get_stack { [ @{ $_[0]->{_stack} } ] } 3027 | 3028 | 1; 3029 | -------------------------------------------------------------------------------- /perl_modules/Lang5/String.pm: -------------------------------------------------------------------------------- 1 | package Lang5::String; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use overload 7 | '""' => sub { ${$_[0]} }, 8 | 'cmp' => sub { 9 | no warnings qw/uninitialized/; 10 | my($l, $r, $s) = @_; 11 | $l = $$l if ref($l); 12 | $r = $$r if ref($r); 13 | $s ? $l cmp $r : $r cmp $l; 14 | }, 15 | '<=>' => sub { 16 | no warnings qw/uninitialized/; 17 | my($l, $r, $s) = @_; 18 | $l = $$l if ref($l); 19 | $r = $$r if ref($r); 20 | $s ? $l <=> $r : $r <=> $l; 21 | }, 22 | ; 23 | 24 | use Carp; 25 | 26 | sub new { 27 | my($class, $val) = @_; 28 | 29 | croak "cannot bless reference" 30 | if ref($val); 31 | 32 | bless \$val, $class; 33 | } 34 | 35 | 1; 36 | -------------------------------------------------------------------------------- /perl_modules/Term/ReadLine/Perl.pm: -------------------------------------------------------------------------------- 1 | package Term::ReadLine::Perl; 2 | use Carp; 3 | @ISA = qw(Term::ReadLine::Stub Term::ReadLine::Compa Term::ReadLine::Perl::AU); 4 | #require 'readline.pl'; 5 | 6 | $VERSION = $VERSION = 1.0303; 7 | 8 | sub readline { 9 | shift; 10 | #my $in = 11 | &readline::readline(@_); 12 | #$loaded = defined &Term::ReadKey::ReadKey; 13 | #print STDOUT "\nrl=`$in', loaded = `$loaded'\n"; 14 | #if (ref \$in eq 'GLOB') { # Bug under debugger 15 | # ($in = "$in") =~ s/^\*(\w+::)+//; 16 | #} 17 | #print STDOUT "rl=`$in'\n"; 18 | #$in; 19 | } 20 | 21 | #sub addhistory {} 22 | *addhistory = \&AddHistory; 23 | 24 | #$term; 25 | $readline::minlength = 1; # To peacify -w 26 | $readline::rl_readline_name = undef; # To peacify -w 27 | $readline::rl_basic_word_break_characters = undef; # To peacify -w 28 | 29 | sub new { 30 | if (defined $term) { 31 | warn "Cannot create second readline interface, falling back to dumb.\n"; 32 | return Term::ReadLine::Stub::new(@_); 33 | } 34 | shift; # Package 35 | if (@_) { 36 | if ($term) { 37 | warn "Ignoring name of second readline interface.\n" if defined $term; 38 | shift; 39 | } else { 40 | $readline::rl_readline_name = shift; # Name 41 | } 42 | } 43 | if (!@_) { 44 | if (!defined $term) { 45 | ($IN,$OUT) = Term::ReadLine->findConsole(); 46 | # Old Term::ReadLine did not have a workaround for a bug in Win devdriver 47 | $IN = 'CONIN$' if $^O eq 'MSWin32' and "\U$IN" eq 'CON'; 48 | open IN, 49 | # A workaround for another bug in Win device driver 50 | (($IN eq 'CONIN$' and $^O eq 'MSWin32') ? "+< $IN" : "< $IN") 51 | or croak "Cannot open $IN for read"; 52 | open(OUT,">$OUT") || croak "Cannot open $OUT for write"; 53 | $readline::term_IN = \*IN; 54 | $readline::term_OUT = \*OUT; 55 | } 56 | } else { 57 | if (defined $term and ($term->IN ne $_[0] or $term->OUT ne $_[1]) ) { 58 | croak "Request for a second readline interface with different terminal"; 59 | } 60 | $readline::term_IN = shift; 61 | $readline::term_OUT = shift; 62 | } 63 | eval {require Term::ReadLine::readline}; die $@ if $@; 64 | # The following is here since it is mostly used for perl input: 65 | # $readline::rl_basic_word_break_characters .= '-:+/*,[])}'; 66 | $term = bless [$readline::term_IN,$readline::term_OUT]; 67 | unless ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/) { 68 | local $Term::ReadLine::termcap_nowarn = 1; # With newer Perls 69 | local $SIG{__WARN__} = sub {}; # With older Perls 70 | $term->ornaments(1); 71 | } 72 | return $term; 73 | } 74 | sub newTTY { 75 | my ($self, $in, $out) = @_; 76 | $readline::term_IN = $self->[0] = $in; 77 | $readline::term_OUT = $self->[1] = $out; 78 | my $sel = select($out); 79 | $| = 1; # for DB::OUT 80 | select($sel); 81 | } 82 | sub ReadLine {'Term::ReadLine::Perl'} 83 | sub MinLine { 84 | my $old = $readline::minlength; 85 | $readline::minlength = $_[1] if @_ == 2; 86 | return $old; 87 | } 88 | sub SetHistory { 89 | shift; 90 | @readline::rl_History = @_; 91 | $readline::rl_HistoryIndex = @readline::rl_History; 92 | } 93 | sub GetHistory { 94 | @readline::rl_History; 95 | } 96 | sub AddHistory { 97 | shift; 98 | push @readline::rl_History, @_; 99 | $readline::rl_HistoryIndex = @readline::rl_History + @_; 100 | } 101 | %features = (appname => 1, minline => 1, autohistory => 1, getHistory => 1, 102 | setHistory => 1, addHistory => 1, preput => 1, 103 | attribs => 1, 'newTTY' => 1, 104 | tkRunning => Term::ReadLine::Stub->Features->{'tkRunning'}, 105 | ornaments => Term::ReadLine::Stub->Features->{'ornaments'}, 106 | ); 107 | sub Features { \%features; } 108 | # my %attribs; 109 | tie %attribs, 'Term::ReadLine::Perl::Tie' or die ; 110 | sub Attribs { 111 | \%attribs; 112 | } 113 | sub DESTROY {} 114 | 115 | package Term::ReadLine::Perl::AU; 116 | 117 | sub AUTOLOAD { 118 | { $AUTOLOAD =~ s/.*:://; } # preserve match data 119 | my $name = "readline::rl_$AUTOLOAD"; 120 | die "Unknown method `$AUTOLOAD' in Term::ReadLine::Perl" 121 | unless exists $readline::{"rl_$AUTOLOAD"}; 122 | *$AUTOLOAD = sub { shift; &$name }; 123 | goto &$AUTOLOAD; 124 | } 125 | 126 | package Term::ReadLine::Perl::Tie; 127 | 128 | sub TIEHASH { bless {} } 129 | sub DESTROY {} 130 | 131 | sub STORE { 132 | my ($self, $name) = (shift, shift); 133 | $ {'readline::rl_' . $name} = shift; 134 | } 135 | sub FETCH { 136 | my ($self, $name) = (shift, shift); 137 | $ {'readline::rl_' . $name}; 138 | } 139 | 140 | package Term::ReadLine::Compa; 141 | 142 | sub get_c { 143 | my $self = shift; 144 | getc($self->[0]); 145 | } 146 | 147 | sub get_line { 148 | my $self = shift; 149 | my $fh = $self->[0]; 150 | scalar <$fh>; 151 | } 152 | 153 | 1; 154 | -------------------------------------------------------------------------------- /tests/000_adu_tests.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Data::Dumper; 5 | $Data::Dumper::Indent = 0; 6 | 7 | use Test::More; 8 | use Storable qw/dclone/; 9 | use File::Spec::Functions; 10 | use FindBin qw/$Bin/; 11 | use lib catfile($Bin, '../perl_modules'); 12 | 13 | BEGIN { use_ok( 'Array::DeepUtils', qw/:all/ ) } 14 | 15 | my $a1 = [[1,2,3], [4,5,6], [7,8,9]]; 16 | my $a2 = [1,2,3,4,5,6,7,8,9]; 17 | my $a3 = [[1,0], [1,1], [2,0], [2,1]]; 18 | my $a4 = [[0,0], [0,1], [1,0], [1,1]]; 19 | my $a5 = [4,5,7,8]; 20 | my $a6 = [[2,3], [5,6], [8,9]]; 21 | my $a7 = [[1,2,3], [4,6], [7,8,9]]; 22 | my $a8 = [[1,1], [2,0]]; 23 | my $a9 = [2, 6, [7,8,9]]; 24 | my $a10 = [[1,2,3],4,[5,[6,7,8,[9,0]]]]; 25 | my $a11 = [3,3,4,2]; 26 | my $a12 = [[1,2,3],4,[5,6],[7,8,9]]; 27 | my $a13 = [[1,2,3],[0,0,0],[5,6,0],[7,8,9]]; 28 | my $a14 = [1,0,2,0,3,[1,0,3]]; 29 | my $a15 = [1,0,2,0,3,[0,1,0]]; 30 | my $a16 = [[11,12], [13,14]]; 31 | my $a17 = [1, -1]; 32 | my $a18 = [[11,24,3], [52,70,-6], [7,-8,9]]; 33 | my $a19 = [[1,2,3], [7,8,9]]; 34 | my $a20 = [[1,3],[4,5]]; 35 | my $a21 = [[1,0], [2,1]]; 36 | my $a22 = [[9,7,8],[3,1,2],[6,4,5]]; 37 | my $a23 = [[1,2],[3,4]]; 38 | my $a24 = [[[0,0],[0,2]],[[1,0],[1,1]]]; 39 | my $a25 = [[8,9,7],[2,3,1],[5,6,4]]; 40 | my $a26 = [[1,4,7],[2,5,8],[3,6,9]]; 41 | 42 | my(@s, @d, @v); 43 | my @tests = ( 44 | 45 | sub { 46 | my $c = collapse($a1); 47 | is_deeply($c, $a2, 'collapse'); 48 | }, 49 | 50 | sub { 51 | my $iterator = vector_iterator([1,0], [2,1]); 52 | 53 | while ( my($svec, $dvec) = $iterator->() ) { 54 | push @s, $svec; 55 | push @d, $dvec; 56 | push @v, value_by_path($a1, $svec); 57 | } 58 | 59 | is_deeply([\@s, \@d], [$a3, $a4], 'vector_iterator forwards'); 60 | }, 61 | 62 | sub { 63 | 64 | @s = @d = (); 65 | my $iterator = vector_iterator([2,1], [1,0]); 66 | 67 | while ( my($svec, $dvec) = $iterator->() ) { 68 | push @s, $svec; 69 | push @d, $dvec; 70 | } 71 | 72 | is_deeply([[reverse @s], \@d], [$a3, $a4], 'vector_iterator backwards'); 73 | }, 74 | 75 | sub { 76 | is_deeply(\@v, $a5, 'value_by_path'); 77 | }, 78 | 79 | sub { 80 | my $c = dcopy($a1, [[0,1], [2,2]]); 81 | 82 | is_deeply($c, $a6, 'dcopy'); 83 | }, 84 | 85 | sub { 86 | my $c = dclone($a1); 87 | 88 | purge($c, '5'); 89 | 90 | is_deeply($c, $a7, 'purge'); 91 | }, 92 | 93 | sub { 94 | my $c = dclone($a1); 95 | 96 | remove($c, 1); 97 | 98 | is_deeply($c, $a19, 'remove 1'); 99 | }, 100 | 101 | sub { 102 | my $c = dclone($a3); 103 | 104 | remove($c, [0,3]); 105 | 106 | is_deeply($c, $a8, 'remove 2'); 107 | }, 108 | 109 | sub { 110 | my $c = dclone($a1); 111 | 112 | remove($c, [[0,1], [1,2], 2]); 113 | 114 | is_deeply($c, $a20, 'remove 3'); 115 | }, 116 | 117 | sub { 118 | my $c = dclone($a1); 119 | 120 | my $s = subscript($c, 1); 121 | 122 | is_deeply($s, [[4,5,6]], 'subscript 1'); 123 | }, 124 | 125 | sub { 126 | my $c = dclone($a3); 127 | 128 | my $s = subscript($c, [0,3]); 129 | 130 | is_deeply($s, $a21, 'subscript 2'); 131 | }, 132 | 133 | sub { 134 | my $c = dclone($a1); 135 | 136 | my $s = subscript($a1, [[0,1], [1,2], 2]); 137 | 138 | is_deeply($s, $a9, 'subscript 3'); 139 | }, 140 | 141 | sub { 142 | my $c = shape($a10); 143 | 144 | is_deeply($c, $a11, 'shape'); 145 | }, 146 | 147 | sub { 148 | my $c = dclone($a12); 149 | my $s = shape($c); 150 | 151 | my $r = reshape($c, $s, [0]); 152 | 153 | is_deeply($r, $a13, 'reshape'); 154 | }, 155 | 156 | sub { 157 | my $c = dclone($a14); 158 | 159 | unary($c, sub { ! $_[0] + 0 }); 160 | 161 | is_deeply($c, $a15, 'unary'); 162 | }, 163 | 164 | sub { 165 | my $c = dclone($a1); 166 | 167 | binary($a16, $c, sub { $_[0] * $_[1] }, 1, undef, $a17); 168 | 169 | is_deeply($c, $a18, 'binary'); 170 | }, 171 | 172 | sub { 173 | my $x = dclone($a2); 174 | 175 | my $y = reshape($x, [3,3,3,3], $a2); 176 | 177 | my $z = dcopy($y, [[1,1,1,1],[2,2,2,2]]); 178 | 179 | my $c = reshape([], [2,2], collapse($z)); 180 | 181 | is_deeply($c, [[5,6],[8,9]], 'combined'); 182 | }, 183 | 184 | sub { 185 | my $x = dclone($a1); 186 | 187 | my $y = rotate($x, [1,1]); 188 | 189 | is_deeply($y, $a22, 'rotate'); 190 | }, 191 | 192 | sub { 193 | my $y = scatter($a2, $a4); 194 | 195 | is_deeply($y, $a23, 'scatter'); 196 | }, 197 | 198 | sub { 199 | my $y = idx($a20, $a1); 200 | 201 | is_deeply($y, $a24, 'idx'); 202 | }, 203 | 204 | sub { 205 | my $y = rotate($a1, $a17); 206 | 207 | is_deeply($y, $a25, 'rotate'); 208 | }, 209 | 210 | sub { 211 | my $y = transpose($a1, 1); 212 | 213 | is_deeply($y, $a26, 'transpose'); 214 | }, 215 | ); 216 | 217 | die "using module Array::DeepUtils failed\n" 218 | unless $Array::DeepUtils::VERSION; 219 | 220 | plan(tests => scalar(@tests) + 1); 221 | 222 | $_->() for @tests; 223 | -------------------------------------------------------------------------------- /tests/001_basic.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use lib '../perl_modules/'; 6 | 7 | BEGIN { use_ok( 'Lang5' ); } 8 | 9 | my $obj; 10 | my $err; 11 | my $txt; 12 | 13 | my @tests = ( 14 | sub { 15 | $obj = Lang5->new( 16 | log_level => 'ERROR', 17 | libautoload => 0, 18 | ); 19 | 20 | is( ref($obj), 'Lang5', 'constructor without libraries'); 21 | }, 22 | sub { 23 | my $s = addexec('42'); 24 | is_deeply( $s, [42], 'put value onto stack'); 25 | }, 26 | sub { 27 | my $s = addexec('.'); 28 | is_deeply( $s, [], 'output value with . a) empty stack'); 29 | }, 30 | sub { 31 | like( $txt, qr/^\s*42\s*$/, 'output value with . b) check output'); 32 | }, 33 | ); 34 | 35 | plan(tests => scalar(@tests) + 1); 36 | 37 | $_->() for @tests; 38 | 39 | sub addexec { 40 | $obj->add_source_line($_) for @_; 41 | $obj->execute(); 42 | if ( $obj->error() ) { 43 | $err = $obj->last_error(); 44 | return; 45 | } 46 | $txt = join('', $obj->get_text()); 47 | return $obj->get_stack(); 48 | } 49 | -------------------------------------------------------------------------------- /tests/001_health_check.5: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bernd-ulmann/lang5/f0da7279bba222fb18cb0d6b0caa45f7cfd6f661/tests/001_health_check.5 --------------------------------------------------------------------------------